729 lines
30 KiB
Racket
729 lines
30 KiB
Racket
#lang racket/base
|
|
|
|
(require "private/git-provider.rkt"
|
|
"private/git-commands.rkt"
|
|
"private/config.rkt"
|
|
"private/diff.rkt"
|
|
"private/info.rkt"
|
|
simple-log
|
|
racket/string
|
|
net/sendurl
|
|
)
|
|
|
|
(provide git
|
|
git-add
|
|
git-status
|
|
git-commit
|
|
git-pull
|
|
git-push
|
|
git-fetch
|
|
git-branch
|
|
git-clone
|
|
git-log
|
|
git-rev-list
|
|
git-diff
|
|
git-grep
|
|
git-help
|
|
git-switch
|
|
git-restore
|
|
git-show
|
|
git-tag
|
|
git-stash
|
|
git-remote
|
|
git-init
|
|
git-current-branch
|
|
git-branches
|
|
git-remotes
|
|
git-tags
|
|
git-stashes
|
|
git-save
|
|
git-save-all
|
|
git-sync
|
|
git-start-branch
|
|
git-release
|
|
git-version
|
|
git-new-version
|
|
git-exe
|
|
set-git-exe!
|
|
git-config
|
|
set-git-config!
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Internal variables
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define git-commands (make-hash))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Command invocation using 'git'
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Invoke a supported Git command through the command table.
|
|
; pre : command is a registered Git command symbol.
|
|
; post : The selected command has processed all supplied arguments.
|
|
; result : The command-specific result.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (git command . args)
|
|
((hash-ref git-commands command
|
|
(λ ()
|
|
(error "Not a supported or recognized git command: " command)))
|
|
args))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Supporting functions
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Read one line of input after displaying a prompt.
|
|
; pre : p can be displayed.
|
|
; post : The prompt has been flushed before input is read.
|
|
; result : The line entered by the user or an EOF object.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (git-prompt p)
|
|
(display p)
|
|
(flush-output)
|
|
(read-line))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Add --porcelain to a Git argument list when it is absent.
|
|
; pre : args is a list and an optional transformation accepts a list.
|
|
; post : Existing porcelain options have not been duplicated.
|
|
; result : The transformed Git argument list.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (add-porcelain args info . f)
|
|
(let ((m (has-git-arg? args #px"^[-][-]porcelain([=](.*))?"))
|
|
(g (if (null? f) (λ (x) x) (car f)))
|
|
)
|
|
(if m
|
|
(g args)
|
|
(g (cons '--porcelain args)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Convert one porcelain status character to a semantic symbol.
|
|
; pre : status is one Git porcelain v1 status character.
|
|
; post : Unknown status characters have raised an exception.
|
|
; result : The corresponding semantic status symbol.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (status->symbol status)
|
|
(cond
|
|
((string=? status " ") 'unchanged)
|
|
((string=? status "M") 'modified)
|
|
((string=? status "T") 'type-changed)
|
|
((string=? status "A") 'added)
|
|
((string=? status "D") 'deleted)
|
|
((string=? status "R") 'renamed)
|
|
((string=? status "C") 'copied)
|
|
((string=? status "U") 'unmerged)
|
|
((string=? status "?") 'untracked)
|
|
((string=? status "!") 'ignored)
|
|
(else (error 'git-status "Unexpected status: ~a" status))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Recognize Git output that reports there is nothing to commit.
|
|
; pre : out is a list of output lines.
|
|
; post : The output has only been inspected.
|
|
; result : #t when a known nothing-to-commit message occurs, otherwise #f.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (nothing-to-commit? out)
|
|
(ormap (λ (line)
|
|
(let ((line* (string-downcase line)))
|
|
(or (string-contains? line* "nothing to commit")
|
|
(string-contains? line* "no changes added to commit"))))
|
|
out))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Select the standard-output lines from ordered process output.
|
|
; pre : output contains (source line) items returned by run-git.
|
|
; post : The order of the selected lines has been preserved.
|
|
; result : A list of standard-output lines.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (stdout-lines output)
|
|
(map cadr
|
|
(filter (lambda (entry) (eq? (car entry) 'stdout)) output)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Process a Git command whose useful result is a list of lines.
|
|
; pre : exit-code and output belong to the completed Git command.
|
|
; post : A non-zero exit code has raised a Git exception.
|
|
; result : The standard-output lines when Git exits with status zero.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (process-lines-result cmd exit-code result output out info)
|
|
(if (= exit-code 0)
|
|
(stdout-lines output)
|
|
(git-error cmd (format "Exitcode <> 0: ~a" exit-code) out)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Command definition macro
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Define, register and connect a public Git command procedure.
|
|
; pre : The preprocessor and result processor use the proxy interfaces.
|
|
; post : cmd-sym is registered in the generic git command table.
|
|
; result : Definitions for the public and internal command procedures.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define-syntax def-cmd
|
|
(syntax-rules ()
|
|
((_ cmd cmd* cmd-sym)
|
|
(def-cmd cmd cmd* cmd-sym (λ (args info) args) std-process-git-result))
|
|
((_ cmd cmd* cmd-sym pre-code)
|
|
(def-cmd cmd cmd* cmd-sym pre-code std-process-git-result))
|
|
((_ cmd cmd* cmd-sym pre-code process-result)
|
|
(def-cmd cmd cmd* cmd-sym cmd-sym pre-code process-result))
|
|
((_ cmd cmd* cmd-sym git-cmd pre-code process-result)
|
|
(begin
|
|
(def-git-cmd-proxy cmd* git-cmd
|
|
pre-code
|
|
process-result)
|
|
(define (cmd . args) (cmd* args))
|
|
(hash-set! git-commands cmd-sym cmd*)))
|
|
)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Typical git commands
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Return the complete Git index and worktree status for every file.
|
|
; pre : The current directory is inside a Git working tree.
|
|
; post : Git status has been invoked with --porcelain.
|
|
; result : A list of (index-status worktree-status file) items.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-status cmd-git-status 'status
|
|
add-porcelain
|
|
(λ (cmd exit-code result output out info)
|
|
(dbg-git (format "~a" output))
|
|
(if (= exit-code 0)
|
|
(map (λ (line)
|
|
(if (< (string-length line) 3)
|
|
(git-error 'status "Unexpected output" line)
|
|
(list (status->symbol (substring line 0 1))
|
|
(status->symbol (substring line 1 2))
|
|
(substring line 3))))
|
|
(stdout-lines output))
|
|
(git-error 'status "Exitcode <> 0" (cons (format "~a\n" exit-code) output))
|
|
))
|
|
)
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Add file contents to the Git index.
|
|
; pre : The supplied arguments are valid for git add.
|
|
; post : Git add has completed successfully or an exception has been raised.
|
|
; result : #t after a successful Git command.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-add cmd-git-add 'add)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Create a Git commit.
|
|
; pre : A commit message is supplied or can be requested from the user.
|
|
; post : A commit exists, nothing needed committing, or an exception was raised.
|
|
; result : #t after a commit or when the repository has nothing to commit.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-commit cmd-git-commit 'commit
|
|
(λ (args info)
|
|
(with-handlers ([exn:fail? (λ (e)
|
|
(let ((msg (string-trim (git-prompt "Commit message:\n>"))))
|
|
(if (string=? msg "")
|
|
(raise "A commit message is mandatory")
|
|
(cons '-m (cons msg args)))))])
|
|
(check-git-args 'commit args '((-m 1 "A commit message is mandatory")))))
|
|
(λ (cmd exit-code result output out info)
|
|
(cond
|
|
((and (= exit-code 1)
|
|
(nothing-to-commit? out))
|
|
(git-displ out)
|
|
#t)
|
|
(else
|
|
(std-process-git-result cmd exit-code result output out info))))
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Push local changes to a remote repository.
|
|
; pre : The supplied arguments are valid for git push.
|
|
; post : Git push has completed successfully or an exception has been raised.
|
|
; result : #t after a successful push.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-push cmd-git-push 'push add-porcelain)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Fetch and integrate changes from a remote repository.
|
|
; pre : The supplied arguments are valid for git pull.
|
|
; post : Git pull has completed successfully or an exception has been raised.
|
|
; result : #t after a successful pull.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-pull cmd-git-pull 'pull)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Download refs and objects from a remote repository.
|
|
; pre : The supplied arguments are valid for git fetch.
|
|
; post : Git fetch has completed successfully or an exception has been raised.
|
|
; result : #t after a successful fetch.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-fetch cmd-git-fetch 'fetch)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : List, create or delete branches.
|
|
; pre : The supplied arguments are valid for git branch.
|
|
; post : Git branch has completed successfully or an exception has been raised.
|
|
; result : #t after a successful branch command.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-branch cmd-git-branch 'branch)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Clone a repository into a new directory.
|
|
; pre : The supplied arguments are valid for git clone.
|
|
; post : The clone exists or an exception has been raised.
|
|
; result : #t after a successful clone.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-clone cmd-git-clone 'clone)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Display the Git commit log.
|
|
; pre : The supplied arguments are valid for git log.
|
|
; post : Git log has completed successfully or an exception has been raised.
|
|
; result : #t after successfully displaying the log.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-log cmd-git-log 'log)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : List commit objects reachable from supplied revisions.
|
|
; pre : The supplied arguments are valid for git rev-list.
|
|
; post : Git rev-list has completed successfully or an exception was raised.
|
|
; result : #t after successfully displaying the result.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-rev-list cmd-git-rev-list 'rev-list)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Render a Git diff in the browser.
|
|
; pre : The supplied arguments are valid for git diff.
|
|
; post : A successful non-empty diff has been rendered as HTML.
|
|
; result : #t for a rendered diff, otherwise #f.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-diff cmd-git-diff 'diff
|
|
(λ (args info) args)
|
|
(λ (cmd exit-code result output out info)
|
|
(if (and (zero? exit-code)
|
|
result)
|
|
(let ((diff (string-join
|
|
(filter (λ (line)
|
|
(not (string-prefix? (string-downcase line) "warning:")))
|
|
out)
|
|
"\n")))
|
|
(diff->html diff)
|
|
#t)
|
|
#f)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Search tracked files for a pattern.
|
|
; pre : The supplied arguments are valid for git grep.
|
|
; post : Git grep has completed; exit code one is treated as no matches.
|
|
; result : A list containing file, line number, match count and matched text.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-grep cmd-git-grep 'grep
|
|
(λ (args info)
|
|
(let ((matches #f)
|
|
(line-nr #f)
|
|
)
|
|
|
|
(let ((nargs (map
|
|
(λ (e)
|
|
(let ((o (format "~a" e)))
|
|
(cond
|
|
((string=? o "-c") (set! matches #t))
|
|
((string=? o "-n") (set! line-nr #t))))
|
|
e)
|
|
(map (λ (x) (if (eq? x '-i) "-i" x)) args))))
|
|
(when (eq? line-nr #f)
|
|
(set! nargs (cons "-n" nargs))) ;; add line numbers / counts for pattern recognition
|
|
(hash-set! info 'matches matches)
|
|
(hash-set! info 'line-nr (if matches #f line-nr))
|
|
nargs)))
|
|
(λ (cmd exit-code result output out info)
|
|
(with-handlers ([exn:fail? (λ (e)
|
|
(err-git (string-join (map cadr output) "\n"))
|
|
(raise e))])
|
|
(if (and result
|
|
(or (= exit-code 0) (= exit-code 1)))
|
|
(let ((re #px"([^:]+)[:]([^:]+)([:](.*))?"))
|
|
(map (λ (line)
|
|
(let ((m (regexp-match re line)))
|
|
(let ((line-nr (if (hash-ref info 'line-nr #f)
|
|
(if (eq? m #f)
|
|
#f
|
|
(string->number (caddr m)))
|
|
#f))
|
|
(matches (if (hash-ref info 'matches #f)
|
|
(if (eq? m #f)
|
|
#f
|
|
(string->number (caddr m)))
|
|
#f))
|
|
)
|
|
(if m
|
|
(list (cadr m) line-nr matches (cadddr (cdr m)))
|
|
(list line #f #f #f)))))
|
|
out))
|
|
(begin
|
|
(err-git (string-join (map cadr output) "\n"))
|
|
#f))))
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Display help for Git or a Git command.
|
|
; pre : The supplied arguments are valid for git help.
|
|
; post : Git help has completed successfully or an exception has been raised.
|
|
; result : #t after successfully displaying help.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-help cmd-git-help 'help)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Switch branches or restore working-tree files.
|
|
; pre : The supplied arguments are valid for git switch.
|
|
; post : Git switch has completed successfully or an exception was raised.
|
|
; result : #t after a successful switch.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-switch cmd-git-switch 'switch)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Restore working-tree or index files.
|
|
; pre : The supplied arguments are valid for git restore.
|
|
; post : Git restore has completed successfully or an exception was raised.
|
|
; result : #t after a successful restore.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-restore cmd-git-restore 'restore)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Display one or more Git objects.
|
|
; pre : The supplied arguments are valid for git show.
|
|
; post : Git show has completed successfully or an exception was raised.
|
|
; result : #t after successfully displaying the objects.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-show cmd-git-show 'show)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : List, create, verify or delete tags.
|
|
; pre : The supplied arguments are valid for git tag.
|
|
; post : Git tag has completed successfully or an exception was raised.
|
|
; result : #t after a successful tag command.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-tag cmd-git-tag 'tag)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Store or restore uncommitted changes.
|
|
; pre : The supplied arguments are valid for git stash.
|
|
; post : Git stash has completed successfully or an exception was raised.
|
|
; result : #t after a successful stash command.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-stash cmd-git-stash 'stash)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Manage the repositories whose branches are tracked.
|
|
; pre : The supplied arguments are valid for git remote.
|
|
; post : Git remote has completed successfully or an exception was raised.
|
|
; result : #t after a successful remote command.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-remote cmd-git-remote 'remote)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Create an empty Git repository or reinitialize an existing one.
|
|
; pre : The supplied arguments are valid for git init.
|
|
; post : Git init has completed successfully or an exception was raised.
|
|
; result : #t after a successful initialization.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-init cmd-git-init 'init)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Git information
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Obtain the name of the currently checked-out branch.
|
|
; pre : No arguments are supplied and the current directory is a repository.
|
|
; post : The repository has only been inspected.
|
|
; result : The branch name, or #f when HEAD is detached.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-current-branch cmd-git-current-branch 'current-branch 'branch
|
|
(lambda (args info)
|
|
(unless (null? args)
|
|
(error 'git-current-branch "No arguments expected"))
|
|
(list '--show-current))
|
|
(lambda (cmd exit-code result output out info)
|
|
(let ((lines (process-lines-result cmd exit-code result output out info)))
|
|
(if (null? lines) #f (car lines)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Obtain the local branch names.
|
|
; pre : No arguments are supplied and the current directory is a repository.
|
|
; post : The repository has only been inspected.
|
|
; result : A list of local branch names.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-branches cmd-git-branches 'branches 'branch
|
|
(lambda (args info)
|
|
(unless (null? args)
|
|
(error 'git-branches "No arguments expected"))
|
|
(list "--format=%(refname:short)"))
|
|
process-lines-result)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Obtain the configured remote names.
|
|
; pre : No arguments are supplied and the current directory is a repository.
|
|
; post : The repository has only been inspected.
|
|
; result : A list of remote names.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-remotes cmd-git-remotes 'remotes 'remote
|
|
(lambda (args info)
|
|
(unless (null? args)
|
|
(error 'git-remotes "No arguments expected"))
|
|
args)
|
|
process-lines-result)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Obtain the repository tag names.
|
|
; pre : No arguments are supplied and the current directory is a repository.
|
|
; post : The repository has only been inspected.
|
|
; result : A list of tag names.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-tags cmd-git-tags 'tags 'tag
|
|
(lambda (args info)
|
|
(unless (null? args)
|
|
(error 'git-tags "No arguments expected"))
|
|
(list '--list))
|
|
process-lines-result)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Convert one formatted stash line to a semantic list item.
|
|
; pre : line was produced by git stash list with the configured format.
|
|
; post : The line has only been inspected.
|
|
; result : A list containing the stash reference and description.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (stash-line->result line)
|
|
(let ((m (regexp-match #px"^([^\t]+)\t(.*)$" line)))
|
|
(if m
|
|
(list (cadr m) (caddr m))
|
|
(list line ""))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Obtain stash references and descriptions.
|
|
; pre : No arguments are supplied and the current directory is a repository.
|
|
; post : The repository has only been inspected.
|
|
; result : A list of (reference description) items.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(def-cmd git-stashes cmd-git-stashes 'stashes 'stash
|
|
(lambda (args info)
|
|
(unless (null? args)
|
|
(error 'git-stashes "No arguments expected"))
|
|
(list 'list "--format=%gd%x09%s"))
|
|
(lambda (cmd exit-code result output out info)
|
|
(map stash-line->result
|
|
(process-lines-result cmd exit-code result output out info))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Easy workflows
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Add selected paths and commit them with one message.
|
|
; pre : message is non-empty and at least one path is supplied.
|
|
; post : The paths have been staged and committed, or an exception was raised.
|
|
; result : #t after a successful save.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (git-save message . files)
|
|
(when (string=? (string-trim (format "~a" message)) "")
|
|
(error 'git-save "A commit message is mandatory"))
|
|
(when (null? files)
|
|
(error 'git-save "At least one file is mandatory"))
|
|
(apply git-add files)
|
|
(git-commit '-m message))
|
|
|
|
(hash-set! git-commands 'save
|
|
(lambda (args) (apply git-save args)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Stage every change and commit it with one message.
|
|
; pre : message is non-empty.
|
|
; post : All changes have been staged and committed, or an exception was raised.
|
|
; result : #t after a successful save.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (git-save-all message)
|
|
(when (string=? (string-trim (format "~a" message)) "")
|
|
(error 'git-save-all "A commit message is mandatory"))
|
|
(git-add '-A)
|
|
(git-commit '-m message))
|
|
|
|
(hash-set! git-commands 'save-all
|
|
(lambda (args) (apply git-save-all args)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Pull and then push a clean working tree.
|
|
; pre : Either no arguments or a remote and branch are supplied.
|
|
; post : Pull and push completed, or an exception was raised.
|
|
; result : #t after a successful synchronization.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (git-sync . args)
|
|
(unless (or (null? args) (= (length args) 2))
|
|
(error 'git-sync "Expected no arguments or a remote and branch"))
|
|
(unless (null? (git-status))
|
|
(error 'git-sync "The working tree must be clean"))
|
|
(apply git-pull args)
|
|
(apply git-push args))
|
|
|
|
(hash-set! git-commands 'sync
|
|
(lambda (args) (apply git-sync args)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Create and switch to a new branch.
|
|
; pre : A name and at most one optional start point are supplied.
|
|
; post : The new branch is checked out, or an exception was raised.
|
|
; result : #t after successfully creating the branch.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (git-start-branch name . start-point)
|
|
(when (> (length start-point) 1)
|
|
(error 'git-start-branch "Expected a name and optionally one start point"))
|
|
(apply git-switch (append (list '-c name) start-point)))
|
|
|
|
(hash-set! git-commands 'start-branch
|
|
(lambda (args) (apply git-start-branch args)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Format a three-part version list as dotted text.
|
|
; pre : version contains major, minor and patch numbers.
|
|
; post : version has only been inspected.
|
|
; result : The dotted version string.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (version->string version)
|
|
(string-join (map number->string version) "."))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Increment, commit and tag a clean package release.
|
|
; pre : kind is a supported version kind and the working tree is clean.
|
|
; post : info.rkt is committed and the release tag exists, or an exception occurred.
|
|
; result : The created tag name.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (git-release kind)
|
|
(unless (null? (git-status))
|
|
(error 'git-release "The working tree must be clean"))
|
|
(let* ((version (git-new-version kind))
|
|
(version-text (version->string version))
|
|
(tag (string-append (git-config 'tag-prefix) version-text)))
|
|
(git-add "info.rkt")
|
|
(git-commit '-m (format "Version ~a" version-text))
|
|
(git-tag tag)
|
|
tag))
|
|
|
|
(hash-set! git-commands 'release
|
|
(lambda (args) (apply git-release args)))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Racket module versioning
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Return the package version from info.rkt.
|
|
; pre : No arguments are required.
|
|
; post : info.rkt has only been inspected.
|
|
; result : A list containing major, minor and patch.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (git-version . args)
|
|
(cmd-git-version args))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Implement the registered version command.
|
|
; pre : args is empty.
|
|
; post : info.rkt has only been inspected.
|
|
; result : A list containing major, minor and patch.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (cmd-git-version args)
|
|
(unless (null? args)
|
|
(error 'git-version "No arguments expected"))
|
|
(info-version "."))
|
|
|
|
(hash-set! git-commands 'version cmd-git-version)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Increment the package version in info.rkt.
|
|
; pre : kind is 'maj, 'major, 'min, 'minor or 'patch.
|
|
; post : The version definition in info.rkt has been updated.
|
|
; result : The new version as a list containing major, minor and patch.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (git-new-version . args)
|
|
(cmd-git-new-version args))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Implement the registered new-version command.
|
|
; pre : args contains a supported version kind.
|
|
; post : The version definition in info.rkt has been updated.
|
|
; result : The new version as a list containing major, minor and patch.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (cmd-git-new-version args)
|
|
(unless (= (length args) 1)
|
|
(error 'git-new-version "Expected 'maj, 'major, 'min, 'minor or 'patch"))
|
|
(let ((kind (car args)))
|
|
(git-next-version kind ".")
|
|
(git-version)))
|
|
|
|
(hash-set! git-commands 'new-version cmd-git-new-version)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Configuration
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Return the default value for a public configuration key.
|
|
; pre : key is a supported public configuration key.
|
|
; post : Configuration has not been changed.
|
|
; result : The default value for key.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (git-config-default key)
|
|
(case key
|
|
((display-output) #t)
|
|
((display-command) #f)
|
|
((tag-prefix) "v")
|
|
(else (error 'git-config "Unknown configuration key: ~a" key))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Validate a value for a public configuration key.
|
|
; pre : key is a supported public configuration key.
|
|
; post : An invalid value has raised an exception.
|
|
; result : The validated value.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (validate-git-config key value)
|
|
(case key
|
|
((display-output display-command)
|
|
(unless (boolean? value)
|
|
(error 'set-git-config! "~a must be a boolean" key)))
|
|
((tag-prefix)
|
|
(unless (string? value)
|
|
(error 'set-git-config! "tag-prefix must be a string")))
|
|
(else (error 'set-git-config! "Unknown configuration key: ~a" key)))
|
|
value)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Read a public git-cli configuration value.
|
|
; pre : key is display-output, display-command or tag-prefix.
|
|
; post : Configuration has not been changed.
|
|
; result : The configured value or its default.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (git-config key)
|
|
(cfg-get (if (eq? key 'tag-prefix) 'release 'git)
|
|
key
|
|
(git-config-default key)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
; goal : Store a public git-cli configuration value.
|
|
; pre : key and value form a supported configuration setting.
|
|
; post : The setting has been persisted.
|
|
; result : The stored value.
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(define (set-git-config! key value)
|
|
(cfg-set! (if (eq? key 'tag-prefix) 'release 'git)
|
|
key
|
|
(validate-git-config key value))
|
|
value)
|
|
|
|
|