Simplify save-repositories-list
Simplify `save-repositories-list' by extracting some of the functionality into its own procedures. Since there is now a `repository-name<?' procedure the `repository<?' procedure is renamed to `repository-location<?' for clarity and accuracy, since that is what it really checks.
This commit is contained in:
parent
95125d682c
commit
9df3b848e0
3 changed files with 30 additions and 18 deletions
|
@ -37,7 +37,8 @@
|
||||||
repo-location
|
repo-location
|
||||||
repo-name
|
repo-name
|
||||||
repository?
|
repository?
|
||||||
repository<?
|
repository-location<?
|
||||||
|
repository-name<?
|
||||||
same-repository?))
|
same-repository?))
|
||||||
|
|
||||||
(define show-unchanged-branches? #f)
|
(define show-unchanged-branches? #f)
|
||||||
|
@ -60,10 +61,14 @@
|
||||||
(define (repository? repo)
|
(define (repository? repo)
|
||||||
(is-a? repo <repository>))
|
(is-a? repo <repository>))
|
||||||
|
|
||||||
(define (repository<? repo1 repo2)
|
(define (repository-location<? repo1 repo2)
|
||||||
"Compary REPO1 and REPO2 to see if REPO1 should be considered smaller."
|
"Compary REPO1 and REPO2 to see if REPO1 should be considered less."
|
||||||
(string<? (repo-location repo1) (repo-location repo2)))
|
(string<? (repo-location repo1) (repo-location repo2)))
|
||||||
|
|
||||||
|
(define (repository-name<? repo1 repo2)
|
||||||
|
"Compare REPO1 and REPO2 to see if REPO1 should be considered less."
|
||||||
|
(string<? (repo-name repo1) (repo-name repo2)))
|
||||||
|
|
||||||
(define-method (branch-pullable (branch <branch>))
|
(define-method (branch-pullable (branch <branch>))
|
||||||
(force (slot-ref branch 'pullable)))
|
(force (slot-ref branch 'pullable)))
|
||||||
|
|
||||||
|
|
|
@ -43,7 +43,8 @@
|
||||||
|
|
||||||
(define (list-repository-locations)
|
(define (list-repository-locations)
|
||||||
"List the registered locations of repositories."
|
"List the registered locations of repositories."
|
||||||
(for-each print-repository-location (sort repositories repository<?)))
|
(for-each print-repository-location
|
||||||
|
(sort repositories repository-location<?)))
|
||||||
|
|
||||||
(define (print-repository-location repo)
|
(define (print-repository-location repo)
|
||||||
"Print the location of REPO."
|
"Print the location of REPO."
|
||||||
|
@ -60,20 +61,10 @@
|
||||||
|
|
||||||
(define (save-repositories-list)
|
(define (save-repositories-list)
|
||||||
"Save the list of repositories."
|
"Save the list of repositories."
|
||||||
(let ((dir (data-dir)))
|
(ensure-directory-exists. (data-dir))
|
||||||
(unless (file-exists? dir)
|
|
||||||
(mkdir dir)))
|
|
||||||
|
|
||||||
;; Sort first
|
;; Sort first
|
||||||
(set! repositories
|
(set! repositories (sort repositories repository-name<?))
|
||||||
(sort repositories
|
(write-repositories!))
|
||||||
(lambda (s1 s2)
|
|
||||||
(string<? (repo-name s1) (repo-name s2)))))
|
|
||||||
|
|
||||||
(let ((port (open-output-file repositories-file))
|
|
||||||
(repos (map repo-location repositories)))
|
|
||||||
(write repos port)
|
|
||||||
(close-port port)))
|
|
||||||
|
|
||||||
(define (show-global-config)
|
(define (show-global-config)
|
||||||
"Show the template specified in `global-config'."
|
"Show the template specified in `global-config'."
|
||||||
|
@ -112,6 +103,13 @@ Don't do anything if REPO has been added to `config-exclusion-list'."
|
||||||
"Check if REPO is or could be made usable as a repository."
|
"Check if REPO is or could be made usable as a repository."
|
||||||
(or (repository? repo) (string? repo)))
|
(or (repository? repo) (string? repo)))
|
||||||
|
|
||||||
|
(define (write-repositories!)
|
||||||
|
"Write the repositories to the repositories file."
|
||||||
|
(let ((port (open-output-file repositories-file))
|
||||||
|
(repos (map repo-location repositories)))
|
||||||
|
(write repos port)
|
||||||
|
(close-port port)))
|
||||||
|
|
||||||
(define config-exclusion-list '())
|
(define config-exclusion-list '())
|
||||||
(define repositories-file (data-file "repos.scm"))
|
(define repositories-file (data-file "repos.scm"))
|
||||||
|
|
||||||
|
|
|
@ -17,6 +17,15 @@
|
||||||
;; along with gitto. If not, see <http://www.gnu.org/licenses/>.
|
;; along with gitto. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
(define-module (gitto path)
|
(define-module (gitto path)
|
||||||
#:export (realpath))
|
#:export (realpath
|
||||||
|
ensure-directory-exists.))
|
||||||
|
|
||||||
(load-extension "libguile-gitto-path" "init_gitto")
|
(load-extension "libguile-gitto-path" "init_gitto")
|
||||||
|
|
||||||
|
(define (ensure-directory-exists. path)
|
||||||
|
"Make sure PATH exists.
|
||||||
|
|
||||||
|
Check if PATH exists, and if so do nothing. If PATH doesn't exist,
|
||||||
|
create it."
|
||||||
|
(unless (file-exists? path)
|
||||||
|
(mkdir path)))
|
||||||
|
|
Loading…
Reference in a new issue