Add some docstrings

This commit is contained in:
Tom Willemse 2013-05-31 23:41:16 +02:00
parent 62627e6cf6
commit c00a0ca730
3 changed files with 73 additions and 5 deletions

View file

@ -32,6 +32,7 @@
(define hook-alist '()) (define hook-alist '())
(define (install-hooks repo-location) (define (install-hooks repo-location)
"Install each hook in `hook-alist' into REPO-LOCATION."
(for-each (for-each
(lambda (hook) (lambda (hook)
(let ((new-name (string-append repo-location "/.git/hooks/" (let ((new-name (string-append repo-location "/.git/hooks/"
@ -41,6 +42,10 @@
hook-alist)) hook-alist))
(define (merge-config repo-name x y) (define (merge-config repo-name x y)
"Merge configuration X with configuration Y.
The values in configuration Y will have `%a' substituted with
REPO-NAME."
(let ((lst (if x (list-copy x) '()))) (let ((lst (if x (list-copy x) '())))
(for-each (for-each
(lambda (s) (lambda (s)
@ -52,11 +57,18 @@
lst)) lst))
(define (merge-setting repo-name lst var val) (define (merge-setting repo-name lst var val)
"Merge VAL into LST under VAR, substituting `%a' with REPO-NAME.
In case val is a list, all values in it have `%a' substituted with
REPO-NAME."
(if (list? val) (if (list? val)
(assoc-set! lst var (map (lambda (v) (format #f v repo-name)) val)) (assoc-set! lst var (map (lambda (v) (format #f v repo-name)) val))
(assoc-set! lst var (format #f val repo-name)))) (assoc-set! lst var (format #f val repo-name))))
(define (merge-settings repo-name x y) (define (merge-settings repo-name x y)
"Merge the settings in X with those in Y.
During merging values in Y will have `%a' substituted with REPO-NAME."
(let ((lst (if x (list-copy x) '()))) (let ((lst (if x (list-copy x) '())))
(for-each (for-each
(lambda (v) (lambda (v)
@ -65,11 +77,22 @@
lst)) lst))
(define (split-setting line) (define (split-setting line)
"Split LINE into a cons cell.
LINE should be a string which looks like `key=value'. The result is a
cons cell with `(key . value)'."
(let ((idx (string-index line #\=))) (let ((idx (string-index line #\=)))
(cons (string-trim-both (substring line 0 idx)) (cons (string-trim-both (substring line 0 idx))
(string-trim-both (substring line (1+ idx)))))) (string-trim-both (substring line (1+ idx))))))
(define (read-setting settings line) (define (read-setting settings line)
"Read and put the setting in LINE into SETTINGS.
LINE should be a string which looks like `key=value'. The result is
SETTINGS with either the setting in LINE added to it, the current
value of the variable specified in LINE overwritten with the value in
LINE or the value in LINE appended to the existing variable in
SETTINGS."
(let* ((new-setting (split-setting line)) (let* ((new-setting (split-setting line))
(var (car new-setting)) (val (cdr new-setting)) (var (car new-setting)) (val (cdr new-setting))
(current-value (assoc-ref settings var))) (current-value (assoc-ref settings var)))
@ -80,6 +103,10 @@
(assoc-set! settings var val)))) (assoc-set! settings var val))))
(define (read-config repo-location) (define (read-config repo-location)
"Read the configuration for the git repository at REPO-LOCATION.
This procedure returns an alist of `(SECTION-TITLE . SETTINGS)' cells
where SETTINGS is an alist of `(VARIABLE . VALUE)' cells."
(let ((port (open-input-file (let ((port (open-input-file
(string-append repo-location "/.git/config"))) (string-append repo-location "/.git/config")))
(config '()) (config '())
@ -104,10 +131,20 @@
(thunk)))) (thunk))))
(define (write-section section) (define (write-section section)
"Output SECTION as a git config section.
This prints SECTION's car as a section header and prints all the
settings in SECTION's cdr."
(format #t "[~a]~%" (car section)) (format #t "[~a]~%" (car section))
(for-each write-setting (cdr section))) (for-each write-setting (cdr section)))
(define (write-setting setting) (define (write-setting setting)
"Write SETTING to `standard-output'.
SETTING should be a cons cell or a proper list. In the case of it
being a proper list a key=value line will be printed for each item in
the cdr of SETTING. In case of a cons cell where the cdr isn't a list
just one line will be printed."
(let ((value (cdr setting))) (let ((value (cdr setting)))
(if (list? value) (if (list? value)
(map (lambda (v) (map (lambda (v)

View file

@ -62,21 +62,27 @@
(force (slot-ref branch 'updated))) (force (slot-ref branch 'updated)))
(define (git-branches dir) (define (git-branches dir)
"Call git-branch and parse its output."
(let ((pipe (start-git dir "branch"))) (let ((pipe (start-git dir "branch")))
(map (map
(lambda (b) (string-trim-both b (char-set #\* #\space))) (lambda (b) (string-trim-both b (char-set #\* #\space)))
(string-split (string-trim-right (read-string pipe)) #\newline)))) (string-split (string-trim-right (read-string pipe)) #\newline))))
(define (git-clean? dir) (define (git-clean? dir)
"Check whether a repository is clean, meaning there are no changes "Check whether a repository is clean.
to the tracked files. Utracked files will not register."
Clean means there are no changes to the tracked files. Untracked files
will not register."
(let* ((pipe (start-git dir "status -suno")) (let* ((pipe (start-git dir "status -suno"))
(clean? (eof-object? (read-delimited "" pipe)))) (clean? (eof-object? (read-delimited "" pipe))))
(close-pipe pipe) (close-pipe pipe)
clean?)) clean?))
(define (git-dir? dir) (define (git-dir? dir)
"Check whether or not DIR/.git exists." "Check whether or not DIR is a git repository.
DIR will be considered a git repository if it has a `.git'
sub-directory."
(let ((dir (string-append dir "/.git"))) (let ((dir (string-append dir "/.git")))
(if (file-exists? dir) (if (file-exists? dir)
(let ((dirstat (stat dir))) (let ((dirstat (stat dir)))
@ -84,7 +90,7 @@ to the tracked files. Utracked files will not register."
#f))) #f)))
(define (git-last-update dir branch) (define (git-last-update dir branch)
"Check when the last update upstream was." "Check when the last update in DIR of upstream for BRANCH was."
(let* ((pipe (start-git (let* ((pipe (start-git
dir (format #f "log -1 --format=%ar ~a@{u}" branch))) dir (format #f "log -1 --format=%ar ~a@{u}" branch)))
(relative-last-update (read-line pipe))) (relative-last-update (read-line pipe)))
@ -134,11 +140,17 @@ to the tracked files. Utracked files will not register."
(branch-name branch) (branch-pushable branch) (branch-name branch) (branch-pushable branch)
(branch-pullable branch) (branch-updated branch))) (branch-pullable branch) (branch-updated branch)))
(define (repo-state-description repo)
"Return the state of REPO as either clean or dirty.
REPO should be of type `<repository>' and the result is a string."
(if (repo-clean? repo) "clean" "dirty"))
(define-method (print (repo <repository>)) (define-method (print (repo <repository>))
(if (file-exists? (repo-location repo)) (if (file-exists? (repo-location repo))
(begin (begin
(format #t "~a: Worktree is ~a~%" (repo-name repo) (format #t "~a: Worktree is ~a~%" (repo-name repo)
(if (repo-clean? repo) "clean" "dirty")) (repo-state-description repo))
(for-each print (repo-branches repo)) (for-each print (repo-branches repo))
(newline)) (newline))
(format #t "~a:~15tnot found at ~s\n" (format #t "~a:~15tnot found at ~s\n"

View file

@ -32,6 +32,11 @@
(define config-exclusion-list '()) (define config-exclusion-list '())
(define (storage-dir xdg-env fallback) (define (storage-dir xdg-env fallback)
"Get the location where gitto stores information.
XDG-ENV specifies which XDG environment variable should be looked at
and FALLBACK specifies the directory to use if XDG-ENV has not been
set in the current environment."
(let ((xdg (getenv xdg-env))) (let ((xdg (getenv xdg-env)))
(string-append (string-append
(or xdg (getenv "HOME")) (if xdg "" fallback) "/gitto"))) (or xdg (getenv "HOME")) (if xdg "" fallback) "/gitto")))
@ -168,9 +173,19 @@ gitto [command [arguments ...]]
(set! command-list (append command-list `(("purge" . ,purge)))) (set! command-list (append command-list `(("purge" . ,purge))))
(define (show-global-config) (define (show-global-config)
"Show the template specified in `global-config'."
(write-config global-config)) (write-config global-config))
(define (show-config . args) (define (show-config . args)
"Do something with the config module.
If ARGS is an empty list, show each repository's current
configuration. If the car of ARGS is `global' show the template
specified in the user's init file. If the car of ARGS is `update'
merge the specified template and each repository's configuration,
excluding the repositories in `config-exclusion-list'. If the car of
ARGS is `hooks' install configured hooks in each repository, excluding
repositories in `config-exclusion-list'."
(cond (cond
((eq? args '()) ((eq? args '())
(for-each (lambda (repo) (for-each (lambda (repo)
@ -190,6 +205,9 @@ gitto [command [arguments ...]]
(set! command-list (append command-list `(("config" . ,show-config)))) (set! command-list (append command-list `(("config" . ,show-config))))
(define (update-repo-config repo) (define (update-repo-config repo)
"Merge the configured configuration with REPO's configuration.
Don't do anything if REPO has been added to `config-exclusion-list'."
(unless (member (repo-name repo) config-exclusion-list) (unless (member (repo-name repo) config-exclusion-list)
(write-config (write-config
(merge-config (repo-name repo) (merge-config (repo-name repo)
@ -198,6 +216,7 @@ gitto [command [arguments ...]]
(string-append (repo-location repo) "/.git/config")))) (string-append (repo-location repo) "/.git/config"))))
(define (update-config) (define (update-config)
"Merge the configured configuration with all repositories."
(for-each update-repo-config repositories)) (for-each update-repo-config repositories))
(define (main args) (define (main args)