Add some docstrings
This commit is contained in:
parent
62627e6cf6
commit
c00a0ca730
3 changed files with 73 additions and 5 deletions
|
@ -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)
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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)
|
||||||
|
|
Loading…
Reference in a new issue