hans/git-cli
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Diverse commando's toegevoegd. Ik weet nog niet of ik ze allemaal ga houden

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-13 02:14:49 +02:00
parent 2cb7e9310e
commit 003f3713f0
9 changed files with 830 additions and 131 deletions
Download Patch File Download Diff File Expand all files Collapse all files
README.md
+42 -37
View File
@@ -1,49 +1,54 @@
# git # git-cli
A small command-line-like Git module for Racket, implemented directly on top of the `libgit2` package. A small command-line-like Git module for Racket. It invokes the installed
`git` executable and exposes commands both through `git` and through direct
procedures.
```racket ```racket
(require git) (require git-cli)
(git 'help)
(git 'help 'grep)
(git 'status) (git 'status)
(git 'diff) (git 'fetch '--prune)
(git 'diff '--cached)
(git 'add "main.rkt" "info.rkt")
(git 'restore '--staged "scratch.rkt")
(git 'reset 'HEAD "--" "main.rkt")
(git 'grep '-i '-n "todo")
(git 'commit "Implement raco support")
(git 'tag "v0.2")
(git 'branch-current)
(git 'switch "main") (git 'switch "main")
(git 'restore '--staged "scratch.rkt")
(git 'grep '-i '-n "todo")
;; Display-oriented variant: (git-status)
(dgit 'status) (git-current-branch)
(git-branches)
(git-remotes)
``` ```
`git` is an ordinary procedure; command names are symbols. `dgit` performs the `git-status` returns the index and working-tree status separately:
same operation, displays a compact human-readable result, and returns that result.
`(git 'help)` opens the locally installed Scribble documentation. A command can
be supplied to jump directly to its section, for example `(git 'help 'restore)`
or `(git 'help 'grep)`.
For `grep`, the natural `(git 'grep '-i "pattern")` spelling is supported even
though Racket's reader represents `-i` as the complex number `0-1i`; in grep
option position that value is interpreted as Git's `-i` flag.
The same operations are available as normal procedures such as `git-status`, `git-add`, `git-commit`, `git-tag`, `git-current-branch`, `git-switch`, and `git-checkout`.
## Help
Open the locally installed Scribble documentation through Racket's
documentation cross-reference index:
```racket ```racket
(git 'help) '((modified unchanged "staged.rkt")
(git 'help 'grep) (unchanged modified "working-tree.rkt")
(git 'help 'restore) (untracked untracked "new.rkt"))
``` ```
The module also provides a few direct workflows:
```racket
(git-save "Implement status parser" "main.rkt" "scribblings/git.scrbl")
(git-save-all "Finish release")
(git-start-branch "feature")
(git-sync)
(git-release 'patch)
```
`git-sync` requires a clean working tree and performs pull followed by push.
`git-release` increments `info.rkt`, commits it, and creates a tag; it does not
push automatically.
Git is searched on `PATH`. If it cannot be found, `git-cli` asks for the path
to `git` or `git.exe` and stores it in its simple-ini configuration.
```racket
(set-git-config! 'display-output #t)
(set-git-config! 'display-command #f)
(set-git-config! 'tag-prefix "v")
```
Remote names, upstream branches, pull strategy, credentials and SSH keys remain
normal Git configuration.
info.rkt
+1 -1
View File
@@ -2,7 +2,7 @@
(define collection "git-cli") (define collection "git-cli")
(define pkg-desc "Command-line-like Git operations for Racket, interface to the git cli command") (define pkg-desc "Command-line-like Git operations for Racket, interface to the git cli command")
(define version "0.3.11") (define version "0.3.12")
(define pkg-authors '("Hans Dijkema")) (define pkg-authors '("Hans Dijkema"))
(define license 'MIT) (define license 'MIT)
main.rkt
+490 -44
View File
@@ -16,9 +16,37 @@
git-commit git-commit
git-pull git-pull
git-push git-push
git-fetch
git-branch
git-clone
git-log git-log
git-rev-list
git-diff
git-grep 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-new-version
git-exe
set-git-exe!
git-config
set-git-config!
) )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -31,10 +59,12 @@
;; Command invocation using 'git' ;; Command invocation using 'git'
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; goal: Invoke a supported Git command through the command table. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pre: command is a registered Git command symbol. ; goal : Invoke a supported Git command through the command table.
;; post: The selected command has processed all supplied arguments. ; pre : command is a registered Git command symbol.
;; result: The command-specific result. ; post : The selected command has processed all supplied arguments.
; result : The command-specific result.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (git command . args) (define (git command . args)
((hash-ref git-commands command ((hash-ref git-commands command
@@ -46,11 +76,23 @@
;; Supporting functions ;; 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) (define (git-prompt p)
(display p) (display p)
(flush-output) (flush-output)
(read-line)) (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) (define (add-porcelain args info . f)
(let ((m (has-git-arg? args #px"^[-][-]porcelain([=](.*))?")) (let ((m (has-git-arg? args #px"^[-][-]porcelain([=](.*))?"))
(g (if (null? f) (λ (x) x) (car f))) (g (if (null? f) (λ (x) x) (car f)))
@@ -59,6 +101,12 @@
(g args) (g args)
(g (cons '--porcelain 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) (define (status->symbol status)
(cond (cond
((string=? status " ") 'unchanged) ((string=? status " ") 'unchanged)
@@ -73,6 +121,12 @@
((string=? status "!") 'ignored) ((string=? status "!") 'ignored)
(else (error 'git-status "Unexpected status: ~a" status)))) (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) (define (nothing-to-commit? out)
(ormap (λ (line) (ormap (λ (line)
(let ((line* (string-downcase line))) (let ((line* (string-downcase line)))
@@ -80,10 +134,37 @@
(string-contains? line* "no changes added to commit")))) (string-contains? line* "no changes added to commit"))))
out)) 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 ;; 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 (define-syntax def-cmd
(syntax-rules () (syntax-rules ()
((_ cmd cmd* cmd-sym) ((_ cmd cmd* cmd-sym)
@@ -91,8 +172,10 @@
((_ cmd cmd* cmd-sym pre-code) ((_ cmd cmd* cmd-sym pre-code)
(def-cmd cmd cmd* cmd-sym pre-code std-process-git-result)) (def-cmd cmd cmd* cmd-sym pre-code std-process-git-result))
((_ cmd cmd* cmd-sym pre-code process-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 (begin
(def-git-cmd-proxy cmd* cmd-sym (def-git-cmd-proxy cmd* git-cmd
pre-code pre-code
process-result) process-result)
(define (cmd . args) (cmd* args)) (define (cmd . args) (cmd* args))
@@ -104,10 +187,12 @@
;; Typical git commands ;; Typical git commands
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; goal: Return the complete Git index and worktree status for every reported file. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pre: The current directory is inside a Git working tree. ; goal : Return the complete Git index and worktree status for every file.
;; post: Git status has been invoked with --porcelain. ; pre : The current directory is inside a Git working tree.
;; result: A list containing (index-status worktree-status file) for every file. ; 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 (def-cmd git-status cmd-git-status 'status
add-porcelain add-porcelain
(λ (cmd exit-code result output out info) (λ (cmd exit-code result output out info)
@@ -119,23 +204,26 @@
(list (status->symbol (substring line 0 1)) (list (status->symbol (substring line 0 1))
(status->symbol (substring line 1 2)) (status->symbol (substring line 1 2))
(substring line 3)))) (substring line 3))))
(map cadr (stdout-lines output))
(filter (λ (entry) (eq? (car entry) 'stdout)) output)))
(git-error 'status "Exitcode <> 0" (cons (format "~a\n" exit-code) 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. ; goal : Add file contents to the Git index.
;; post: Git add has completed successfully or an exception has been raised. ; pre : The supplied arguments are valid for git add.
;; result: #t after a successful Git command. ; 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) (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. ; goal : Create a Git commit.
;; post: The commit was created, nothing needed committing, or an exception was raised. ; pre : A commit message is supplied or can be requested from the user.
;; result: #t after a commit or when the repository has nothing to commit. ; 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 (def-cmd git-commit cmd-git-commit 'commit
(λ (args info) (λ (args info)
(with-handlers ([exn:fail? (λ (e) (with-handlers ([exn:fail? (λ (e)
@@ -154,30 +242,68 @@
(std-process-git-result cmd exit-code result output out info)))) (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. ; goal : Push local changes to a remote repository.
;; post: Git push has completed successfully or an exception has been raised. ; pre : The supplied arguments are valid for git push.
;; result: #t after a successful 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) (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. ; goal : Fetch and integrate changes from a remote repository.
;; post: Git pull has completed successfully or an exception has been raised. ; pre : The supplied arguments are valid for git pull.
;; result: #t after a successful 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) (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) (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) (def-cmd git-clone cmd-git-clone 'clone)
;; goal: Display the Git commit log. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pre: The supplied arguments are valid for git log. ; goal : Display the Git commit log.
;; post: Git log has completed successfully or an exception has been raised. ; pre : The supplied arguments are valid for git log.
;; result: #t after successfully displaying the 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) (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) (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 (def-cmd git-diff cmd-git-diff 'diff
(λ (args info) args) (λ (args info) args)
(λ (cmd exit-code result output out info) (λ (cmd exit-code result output out info)
@@ -192,10 +318,12 @@
#t) #t)
#f))) #f)))
;; goal: Search tracked files for a pattern. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pre: The supplied arguments are valid for git grep. ; goal : Search tracked files for a pattern.
;; post: Git grep has completed; exit code one is treated as no matches. ; pre : The supplied arguments are valid for git grep.
;; result: A list containing file, line number, match count and matched text. ; 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 (def-cmd git-grep cmd-git-grep 'grep
(λ (args info) (λ (args info)
(let ((matches #f) (let ((matches #f)
@@ -244,39 +372,357 @@
#f)))) #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) (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 ;; 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) (define (git-version . args)
(cmd-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) (define (cmd-git-version args)
(unless (null? args)
(error 'git-version "No arguments expected"))
(info-version ".")) (info-version "."))
(hash-set! git-commands 'version cmd-git-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. ; goal : Increment the package version in info.rkt.
;; post: The version definition in info.rkt has been updated. ; pre : kind is 'maj, 'major, 'min, 'minor or 'patch.
;; result: The new version as a list containing major, minor and 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) (define (git-new-version . args)
(cmd-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) (define (cmd-git-new-version args)
(when(null? args) (unless (= (length args) 1)
(error "git-new-version expects 'maj, 'major, 'min, 'minor or 'patch")) (error 'git-new-version "Expected 'maj, 'major, 'min, 'minor or 'patch"))
(let ((kind (car args))) (let ((kind (car args)))
(git-next-version kind ".") (git-next-version kind ".")
(git-version))) (git-version)))
(hash-set! git-commands 'new-version cmd-git-new-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)
private/config.rkt
+12 -1
View File
@@ -43,13 +43,24 @@
;; Provided functions ;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Store one git-cli configuration value.
; pre : section and key identify a simple-ini setting.
; post : value has been persisted.
; result : The result returned by simple-ini.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (cfg-set! section key value) (define (cfg-set! section key value)
(critical (critical
(check-ini) (check-ini)
(send ini set! section key value))) (send ini set! section key value)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Read one git-cli configuration value.
; pre : section and key identify a simple-ini setting.
; post : Configuration has not been changed.
; result : The stored value or default-value.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (cfg-get section key default-value) (define (cfg-get section key default-value)
(critical (critical
(check-ini) (check-ini)
(send ini get section key default-value))) (send ini get section key default-value)))
private/diff.rkt
+6 -1
View File
@@ -11,6 +11,12 @@
(define (make-js . args) (define (make-js . args)
(string-join args "\n")) (string-join args "\n"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Render a Git diff in a temporary HTML file.
; pre : diff is a unified Git diff string.
; post : The generated HTML file has been opened in the default browser.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (diff->html diff) (define (diff->html diff)
(let ((highlight-css "https://cdnjs.cloudflare.com/ajax/libs/highlight.js/11.8.0/styles/github.min.css") (let ((highlight-css "https://cdnjs.cloudflare.com/ajax/libs/highlight.js/11.8.0/styles/github.min.css")
(diff2html-min-css "https://cdn.jsdelivr.net/npm/diff2html/bundles/css/diff2html.min.css") (diff2html-min-css "https://cdn.jsdelivr.net/npm/diff2html/bundles/css/diff2html.min.css")
@@ -52,4 +58,3 @@
(send-url/file tmp-file))))) (send-url/file tmp-file)))))
private/git-commands.rkt
+24 -9
View File
@@ -11,7 +11,12 @@
std-process-git-result std-process-git-result
) )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Determine whether a Git option occurs in an argument list.
; pre : args is a list and opt is a symbol, string or regular expression.
; post : args has only been inspected.
; result : The match result, or #f when the option is absent.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (has-git-arg? args opt) (define (has-git-arg? args opt)
(let ((cmp (cond ((symbol? opt) (λ (x) (eq? x opt))) (let ((cmp (cond ((symbol? opt) (λ (x) (eq? x opt)))
((string? opt) (λ (x) (string=? (format "~a" x) opt))) ((string? opt) (λ (x) (string=? (format "~a" x) opt)))
@@ -28,6 +33,12 @@
(f args) (f args)
(error 'has-git-arg? "args must be a list of arguments"))))) (error 'has-git-arg? "args must be a list of arguments")))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Check that mandatory Git options and their arguments are present.
; pre : flags contains (option argument-count error-message) items.
; post : Missing options have raised an exception.
; result : args when every mandatory option is present.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (check-git-args cmd args flags) (define (check-git-args cmd args flags)
(for-each (for-each
(λ (opt) (λ (opt)
@@ -51,10 +62,12 @@
args) args)
;; goal: Process the standard result of a Git command. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pre: exit-code and out belong to the completed Git command. ; goal : Process the standard result of a Git command.
;; post: Successful output has been displayed or a Git exception has been raised. ; pre : exit-code and out belong to the completed Git command.
;; result: #t when exit-code is zero. ; post : Successful output has been displayed or a Git exception has been raised.
; result : #t when exit-code is zero.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (std-process-git-result cmd exit-code result output out info) (define (std-process-git-result cmd exit-code result output out info)
(if (= exit-code 0) (if (= exit-code 0)
(begin (begin
@@ -65,10 +78,12 @@
) )
;; goal: Define the internal proxy for a Git command. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; pre: pre-code and process-result accept the command proxy arguments. ; goal : Define the internal proxy for a Git command.
;; post: The proxy invokes Git without standard input and processes its result. ; pre : pre-code and process-result accept the command proxy arguments.
;; result: A procedure named f accepting a list of Git arguments. ; post : The proxy invokes Git without standard input and processes its result.
; result : A procedure named f accepting a list of Git arguments.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax def-git-cmd-proxy (define-syntax def-git-cmd-proxy
(syntax-rules () (syntax-rules ()
((_ f cmd pre-code process-result) ((_ f cmd pre-code process-result)
private/git-provider.rkt
+38 -1
View File
@@ -47,6 +47,12 @@
;; Provided functions ;; Provided functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Find the configured Git executable.
; pre : Git is on PATH or a valid executable can be selected interactively.
; post : The executable path has been cached.
; result : The path to git or git.exe.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (git-exe) (define/contract (git-exe)
(-> (or/c path? #f)) (-> (or/c path? #f))
(if (eq? cached-git-exe #f) (if (eq? cached-git-exe #f)
@@ -64,6 +70,12 @@
the-git-exe) the-git-exe)
cached-git-exe)) cached-git-exe))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Configure the Git executable.
; pre : exe-path names an executable path.
; post : The path has been stored and cached.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define/contract (set-git-exe! exe-path) (define/contract (set-git-exe! exe-path)
(-> path? void?) (-> path? void?)
(void (void
@@ -71,9 +83,17 @@
(cfg-set! 'git 'exe exe-path) (cfg-set! 'git 'exe exe-path)
(set! cached-git-exe exe-path)))) (set! cached-git-exe exe-path))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Run Git without allowing interactive terminal prompts.
; pre : args contains the Git command and its arguments.
; post : Standard output and error have been read completely.
; result : The exit code and ordered (source line) output items.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (run-git args) (define (run-git args)
(putenv "GIT_TERMINAL_PROMPT" "0") (putenv "GIT_TERMINAL_PROMPT" "0")
(when (cfg-get 'git 'display-command #f)
(displayln
(string-join (cons "git" (map (lambda (arg) (format "~a" arg)) args)) " ")))
(let-values (((process stdout stdin stderr) (let-values (((process stdout stdin stderr)
(apply subprocess (apply subprocess
#f #f
@@ -123,6 +143,12 @@
(define (is-error? e) (define (is-error? e)
(not (is-output? e))) (not (is-output? e)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Separate normal Git output from error output.
; pre : output contains (source line) items returned by run-git.
; post : output has only been inspected.
; result : Whether no error occurred and either normal or error lines.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (git-out cmd output) (define (git-out cmd output)
(let* ((out (map (λ (e) (cadr e)) (filter (λ (e) (is-output? e)) output))) (let* ((out (map (λ (e) (cadr e)) (filter (λ (e) (is-output? e)) output)))
(err (map (λ (e) (cadr e)) (filter (λ (e) (is-error? e)) output))) (err (map (λ (e) (cadr e)) (filter (λ (e) (is-error? e)) output)))
@@ -130,6 +156,11 @@
) )
(values r (if (eq? r #t) out err)))) (values r (if (eq? r #t) out err))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Log and raise a Git exception.
; pre : cmd, msg* and outp describe a failed Git command.
; post : The message has been logged and an exception has been raised.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax git-error (define-syntax git-error
(syntax-rules () (syntax-rules ()
((_ cmd msg* outp) ((_ cmd msg* outp)
@@ -153,6 +184,12 @@
(define re-a #px"~+") (define re-a #px"~+")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Log Git output and optionally display it.
; pre : out is a string or a list of displayable lines.
; post : Non-empty output has been logged.
; result : void.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (git-displ out) (define (git-displ out)
(let ((str (if (string? out) out (string-join out "\n")))) (let ((str (if (string? out) out (string-join out "\n"))))
(unless (string=? (string-trim str) "") (unless (string=? (string-trim str) "")
private/info.rkt
+18
View File
@@ -9,6 +9,12 @@
git-next-version git-next-version
) )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Read a package version from info.rkt.
; pre : dir contains a readable info.rkt.
; post : info.rkt has only been inspected.
; result : A list containing major, minor and patch.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (info-version dir) (define (info-version dir)
(let* ((l (get-info/full dir)) (let* ((l (get-info/full dir))
(re #px"([0-9]+)[.]([0-9]+)([.]([0-9]+))?") (re #px"([0-9]+)[.]([0-9]+)([.]([0-9]+))?")
@@ -23,6 +29,12 @@
(cadddr (cdr m))))) (cadddr (cdr m)))))
)) ))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Store a package version in info.rkt.
; pre : dir contains info.rkt and version parts are numbers.
; post : The version definition has been replaced.
; result : #t after writing the file.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (set-info-version! dir maj min patch) (define (set-info-version! dir maj min patch)
(define (write-version fh) (define (write-version fh)
@@ -54,6 +66,12 @@
#t))))) #t)))))
) )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal : Increment a package version.
; pre : kind is maj, major, min, minor or patch.
; post : The version definition in info.rkt has been updated.
; result : #t after writing the new version.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (git-next-version kind . dir*) (define (git-next-version kind . dir*)
(let ((dir (if (null? dir*) (let ((dir (if (null? dir*)
"." "."
scribblings/git.scrbl
+177 -15
View File
@@ -1,8 +1,8 @@
#lang scribble/manual #lang scribble/manual
@(require (for-label racket/base @(require (for-label racket/base
racket/contract
"../main.rkt")) "../main.rkt"))
@;git-cli))
@title[#:tag "top"]{git-cli} @title[#:tag "top"]{git-cli}
@author{Hans Dijkema} @author{Hans Dijkema}
@@ -10,30 +10,42 @@
@defmodule[git-cli] @defmodule[git-cli]
The @racketmodname[git-cli] module provides a command-line-like Git interface The @racketmodname[git-cli] module provides a command-line-like Git interface
implemented by invoking the @tt{git} executable. Commands never read from implemented by invoking the @tt{git} executable. Git never reads credentials or
standard input. other answers from standard input.
@section{Command interface}
@defform[(git command argument ...)]{ @defform[(git command argument ...)]{
Runs a supported Git @racket[command]. The arguments are passed to the Git Runs a registered command. Every command is also available as a normal
command. Supported commands include @racket['status], @racket['add], procedure. For example, @racket[(git 'fetch '--prune)] and
@racket['commit], @racket['push], @racket['pull], @racket['branch], @racket[(git-fetch '--prune)] are equivalent.
@racket['clone], @racket['log], @racket['rev-list], @racket['diff],
@racket['grep], @racket['help], @racket['version], and Registered command symbols are @racket['status], @racket['add],
@racket['commit], @racket['push], @racket['pull], @racket['fetch],
@racket['branch], @racket['clone], @racket['log], @racket['rev-list],
@racket['diff], @racket['grep], @racket['help], @racket['switch],
@racket['restore], @racket['show], @racket['tag], @racket['stash],
@racket['remote], @racket['init], @racket['current-branch],
@racket['branches], @racket['remotes], @racket['tags], @racket['stashes],
@racket['save], @racket['save-all], @racket['sync],
@racket['start-branch], @racket['release], @racket['version], and
@racket['new-version]. @racket['new-version].
} }
@section{Basic commands}
@defproc[(git-status [argument any/c] ...) list?]{ @defproc[(git-status [argument any/c] ...) list?]{
Runs @tt{git status --porcelain} with the supplied arguments. Runs @tt{git status --porcelain} with the supplied arguments.
Each result item has the form Each result item has the form
@racket[(index-status worktree-status file)]. The index status describes the @racket[(index-status worktree-status file)]. The first status describes the
change staged for the next commit. The worktree status describes the change in index: the change already staged for the next commit. The second describes the
the working tree relative to the index. working tree relative to the index: the change that is not staged yet.
Both statuses are one of @racket['unchanged], @racket['modified], Both statuses are one of @racket['unchanged], @racket['modified],
@racket['type-changed], @racket['added], @racket['deleted], @racket['renamed], @racket['type-changed], @racket['added], @racket['deleted], @racket['renamed],
@racket['copied], @racket['unmerged], @racket['untracked], or @racket['copied], @racket['unmerged], @racket['untracked], or
@racket['ignored]. For an untracked file, Git reports @tt{??}, so both statuses @racket['ignored]. Git reports an untracked file as @tt{??}, so both statuses
are @racket['untracked]. are @racket['untracked].
@racketblock[ @racketblock[
@@ -62,21 +74,171 @@ status zero; otherwise an exception is raised.
@defproc[(git-pull [argument any/c] ...) boolean?]{ @defproc[(git-pull [argument any/c] ...) boolean?]{
Fetches and integrates changes. Normal progress written by Git to standard Fetches and integrates changes. Normal progress written by Git to standard
error is treated as output when Git exits successfully. error is accepted when Git exits successfully.
}
@defproc[(git-fetch [argument any/c] ...) boolean?]{
Downloads refs and objects without integrating them into the current branch.
}
@defproc[(git-branch [argument any/c] ...) boolean?]{
Passes the arguments to @tt{git branch}. Use @racket[git-branches] when a list
of local branch names is required.
}
@defproc[(git-clone [argument any/c] ...) boolean?]{
Clones a repository. Normal progress on standard error is accepted when Git
exits successfully.
} }
@defproc[(git-log [argument any/c] ...) boolean?]{ @defproc[(git-log [argument any/c] ...) boolean?]{
Displays Git log output and returns @racket[#t] when Git exits successfully. Displays the commit log.
} }
@defproc[(git-grep [argument any/c] ...) list?]{ @defproc[(git-rev-list [argument any/c] ...) boolean?]{
Lists commit objects reachable from the supplied revisions.
}
@defproc[(git-diff [argument any/c] ...) boolean?]{
Renders the Git diff as HTML and opens it in the default browser. Returns
@racket[#t] when a diff was rendered and @racket[#f] otherwise.
}
@defproc[(git-grep [argument any/c] ...) (or/c list? #f)]{
Searches tracked files. Each result contains the file, optional line number, Searches tracked files. Each result contains the file, optional line number,
optional match count, and matched text. Exit status one means that no matches optional match count, and matched text. Exit status one means that no matches
were found and returns an empty list. were found and returns an empty list.
} }
@defproc[(git-help [argument any/c] ...) boolean?]{
Displays help for Git or a supplied Git command.
}
@defproc[(git-switch [argument any/c] ...) boolean?]{
Switches branches. @racket[(git-switch '-c "feature")] creates and checks out a
new branch.
}
@defproc[(git-restore [argument any/c] ...) boolean?]{
Restores working-tree or index files. For example,
@racket[(git-restore '--staged "main.rkt")] removes a file from the index
without discarding its working-tree changes.
}
@defproc[(git-show [argument any/c] ...) boolean?]{
Displays one or more Git objects.
}
@defproc[(git-tag [argument any/c] ...) boolean?]{
Lists, creates, verifies or deletes tags. Use @racket[git-tags] when a list of
tag names is required.
}
@defproc[(git-stash [argument any/c] ...) boolean?]{
Stores or restores uncommitted work, for example
@racket[(git-stash 'push '-m "Temporary work")] and @racket[(git-stash 'pop)].
}
@defproc[(git-remote [argument any/c] ...) boolean?]{
Lists or manages remotes. Use @racket[git-remotes] when a list of remote names
is required.
}
@defproc[(git-init [argument any/c] ...) boolean?]{
Creates an empty repository or reinitializes an existing repository.
}
@section{Repository information}
@defproc[(git-current-branch) (or/c string? #f)]{
Returns the current local branch name, or @racket[#f] for a detached HEAD.
}
@defproc[(git-branches) (listof string?)]{
Returns the local branch names.
}
@defproc[(git-remotes) (listof string?)]{
Returns the configured remote names.
}
@defproc[(git-tags) (listof string?)]{
Returns the repository tag names.
}
@defproc[(git-stashes) list?]{
Returns stash information as @racket[(reference description)] items.
}
@section{Easy workflows}
@defproc[(git-save [message string?] [file any/c] ...) boolean?]{
Stages only the supplied files and commits them with @racket[message]. At least
one file is required.
}
@defproc[(git-save-all [message string?]) boolean?]{
Runs @tt{git add -A} and commits every change with @racket[message].
}
@defproc[(git-start-branch [name any/c] [start-point any/c #f]) boolean?]{
Creates and switches to a branch with @tt{git switch -c}. When
@racket[start-point] is supplied, the branch starts there.
}
@defproc[(git-sync [argument any/c] ...) boolean?]{
Requires a clean working tree, then pulls and pushes. Supply either no
arguments, so Git uses the configured upstream, or both a remote and branch.
The pull behavior remains controlled by Git configuration such as
@tt{pull.rebase}.
}
@defproc[(git-release [kind symbol?]) string?]{
Requires a clean working tree, increments the package version in
@filepath{info.rkt}, commits it as @tt{Version <version>}, creates a tag, and
returns the tag name. The release is not pushed automatically.
}
@section{Package version}
@defproc[(git-version) list?]{
Returns the version from @filepath{info.rkt} as a list containing major, minor
and patch.
}
@defproc[(git-new-version [kind symbol?]) list?]{ @defproc[(git-new-version [kind symbol?]) list?]{
Updates the version in @filepath{info.rkt}. The kind is @racket['major], Updates the version in @filepath{info.rkt}. The kind is @racket['major],
@racket['minor], or @racket['patch], with @racket['maj] and @racket['min] as @racket['minor], or @racket['patch], with @racket['maj] and @racket['min] as
abbreviations. The result is the new version as a list of three integers. abbreviations. The result is the new version as a list of three integers.
} }
@section{Configuration}
@defproc[(git-exe) (or/c path? #f)]{
Returns the configured Git executable. Git is first searched on @tt{PATH}. If
it is absent, the executable is requested interactively and stored in the
@tt{git-cli} simple-ini file.
}
@defproc[(set-git-exe! [exe-path path?]) void?]{
Stores and caches the path to Git.
}
@defproc[(git-config [key symbol?]) any/c]{
Returns one of the public settings:
@itemlist[
@item{@racket['display-output], default @racket[#t], controls normal Git output.}
@item{@racket['display-command], default @racket[#f], displays the command before execution.}
@item{@racket['tag-prefix], default @racket["v"], controls tags made by @racket[git-release].}
]}
The display settings are stored in section @tt{git}; the tag prefix is stored
in section @tt{release}. Git settings such as remotes, upstream branches,
@tt{pull.rebase}, credentials and SSH keys remain Git's own configuration.
}
@defproc[(set-git-config! [key symbol?] [value any/c]) any/c]{
Validates and stores a public setting, then returns @racket[value]. The display
settings require booleans and @racket['tag-prefix] requires a string.
}