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:
Tom Willemse 2014-03-01 20:40:06 +01:00
parent 95125d682c
commit 9df3b848e0
3 changed files with 30 additions and 18 deletions

View file

@ -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)))

View file

@ -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"))

View file

@ -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)))