Cleaned up the code. added some documentation.

This commit is contained in:
2026-08-13 00:33:22 +02:00
parent c556b4f452
commit a025481ae4
4 changed files with 177 additions and 73 deletions
+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.9") (define version "0.3.10")
(define pkg-authors '("Hans Dijkema")) (define pkg-authors '("Hans Dijkema"))
(define license 'MIT) (define license 'MIT)
+70 -19
View File
@@ -28,6 +28,10 @@
(define git-commands (make-hash)) (define git-commands (make-hash))
;; 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-syntax git (define-syntax git
(syntax-rules () (syntax-rules ()
((_ command b1 ...) ((_ command b1 ...)
@@ -51,6 +55,27 @@
(g args) (g args)
(g (cons '--porcelain args))))) (g (cons '--porcelain args)))))
(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))))
(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))
(define-syntax def-cmd (define-syntax def-cmd
(syntax-rules () (syntax-rules ()
@@ -68,37 +93,38 @@
) )
) )
;; goal: Return the complete Git index and worktree status for every reported file.
;; pre: The current directory is inside a Git working tree.
;; post: Git status has been invoked with --porcelain.
;; result: A list containing (index-status worktree-status file) for every file.
(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)
(dbg-git (format "~a" output)) (dbg-git (format "~a" output))
(if (= exit-code 0) (if (= exit-code 0)
(if result
(map (λ (line) (map (λ (line)
(let* ((state (string->symbol (string-trim (substring line 0 2)))) (if (< (string-length line) 3)
(file (string-trim (substring line 3)))) (git-error 'status "Unexpected output" line)
(cond (list (status->symbol (substring line 0 1))
([eq? state '??] (list 'new file)) (status->symbol (substring line 1 2))
([eq? state 'M] (list 'modified file)) (substring line 3))))
([eq? state 'A] (list 'added file)) (map cadr
([eq? state 'D] (list 'deleted file)) (filter (λ (entry) (eq? (car entry) 'stdout)) output)))
([eq? state 'AM] (list 'modified file))
([eq? state 'AD] (list 'deleted file))
([eq? state 'MM] (list 'modified file))
([eq? state 'MD] (list 'deleted file))
(else
(git-error 'status "Unexpected state" state))
)
))
out)
(git-error 'status "Error" 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.
;; 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.
;; post: The commit was created, 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)
@@ -109,15 +135,32 @@
(check-git-args 'commit args '((-m 1 "A commit message is mandatory"))))) (check-git-args 'commit args '((-m 1 "A commit message is mandatory")))))
(λ (cmd exit-code result output out info) (λ (cmd exit-code result output out info)
(cond (cond
((= exit-code 1) (git-displ out) #t) ((and (= exit-code 1)
(nothing-to-commit? out))
(git-displ out)
#t)
(else (else
(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.
;; 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.
;; 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)
(def-cmd git-branch cmd-git-branch 'branch) (def-cmd git-branch cmd-git-branch 'branch)
(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.
;; 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)
(def-cmd git-rev-list cmd-git-rev-list 'rev-list) (def-cmd git-rev-list cmd-git-rev-list 'rev-list)
@@ -129,6 +172,10 @@
(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.
;; 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))
@@ -155,6 +202,10 @@
#t) #t)
#f))) #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 (def-cmd git-grep cmd-git-grep 'grep
(λ (args info) (λ (args info)
(let ((matches #f) (let ((matches #f)
+9 -10
View File
@@ -51,24 +51,26 @@
args) args)
;; goal: Process the standard result of a Git command.
;; pre: exit-code and out belong to the completed Git command.
;; 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)
(if result
(begin (begin
(git-displ out) (git-displ (map cadr output))
#t) #t)
(git-error cmd "Error" out))
(git-error cmd (format "Exitcode <> 0: ~a" exit-code) out) (git-error cmd (format "Exitcode <> 0: ~a" exit-code) out)
) )
) )
;; goal: Define the internal proxy for a Git command.
;; pre: pre-code and process-result accept the command proxy 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)
(def-proxy-cmd f cmd (λ (args info) args) standard-result))
((_ f cmd pre-code)
(def-proxy-cmd f cmd pre-code standard-result))
((_ f cmd pre-code process-result) ((_ f cmd pre-code process-result)
(define (f args*) (define (f args*)
(let* ((args (flatten args*)) (let* ((args (flatten args*))
@@ -79,6 +81,3 @@
(process-result cmd exit-code result output out info)))))) (process-result cmd exit-code result output out info))))))
) )
) )
+71 -17
View File
@@ -1,27 +1,81 @@
#lang scribble/manual #lang scribble/manual
@(require (for-label racket/base git)) @(require (for-label racket/base
git-cli))
@title[#:tag "top"]{git} @title[#:tag "top"]{git-cli}
@author{Hans Dijkema} @author{Hans Dijkema}
@defmodule[git] @defmodule[git-cli]
The @racketmodname[git] module provides a small command-line-like Git interface implemented on top of the @tt{libgit2} package. It does not invoke the @tt{git} executable. The @racketmodname[git-cli] module provides a command-line-like Git interface
implemented by invoking the @tt{git} executable. Commands never read from
standard input.
The short form is intended for build scripts and interactive use: @defform[(git command argument ...)]{
Runs a supported Git @racket[command]. The arguments are passed to the Git
command. Supported commands include @racket['status], @racket['add],
@racket['commit], @racket['push], @racket['pull], @racket['branch],
@racket['clone], @racket['log], @racket['rev-list], @racket['diff],
@racket['grep], @racket['help], @racket['version], and
@racket['new-version].
}
@defproc[(git-status [argument any/c] ...) list?]{
Runs @tt{git status --porcelain} with the supplied arguments.
Each result item has the form
@racket[(index-status worktree-status file)]. The index status describes the
change staged for the next commit. The worktree status describes the change in
the working tree relative to the index.
Both statuses are one of @racket['unchanged], @racket['modified],
@racket['type-changed], @racket['added], @racket['deleted], @racket['renamed],
@racket['copied], @racket['unmerged], @racket['untracked], or
@racket['ignored]. For an untracked file, Git reports @tt{??}, so both statuses
are @racket['untracked].
@racketblock[ @racketblock[
(require git) ((modified unchanged "staged.rkt")
(unchanged modified "working-tree.rkt")
(modified modified "both.rkt")
(renamed unchanged "old.rkt -> new.rkt")
(untracked untracked "new.rkt"))
]}
(git 'status) @defproc[(git-add [argument any/c] ...) boolean?]{
(git 'diff) Adds file contents to the index. Returns @racket[#t] when Git exits with status
(git 'diff '--cached) zero; otherwise an exception is raised.
(git 'add "main.rkt" "info.rkt") }
(git 'restore '--staged "scratch.rkt")
(git 'reset 'HEAD "--" "main.rkt") @defproc[(git-commit [argument any/c] ...) boolean?]{
(git 'grep '-i '-n "todo") Creates a commit. When @tt{-m} is omitted, a commit message is requested before
(git 'commit "Implement raco support") Git is started. A repository with nothing to commit returns @racket[#t]. Other
(git 'tag "v0.1") non-zero exit statuses, including a rejected commit hook, raise an exception.
(git 'checkout "main") }
]
@defproc[(git-push [argument any/c] ...) boolean?]{
Pushes changes using @tt{--porcelain}. Returns @racket[#t] when Git exits with
status zero; otherwise an exception is raised.
}
@defproc[(git-pull [argument any/c] ...) boolean?]{
Fetches and integrates changes. Normal progress written by Git to standard
error is treated as output when Git exits successfully.
}
@defproc[(git-log [argument any/c] ...) boolean?]{
Displays Git log output and returns @racket[#t] when Git exits successfully.
}
@defproc[(git-grep [argument any/c] ...) list?]{
Searches tracked files. Each result contains the file, optional line number,
optional match count, and matched text. Exit status one means that no matches
were found and returns an empty list.
}
@defproc[(git-new-version [kind symbol?]) list?]{
Updates the version in @filepath{info.rkt}. The kind is @racket['major],
@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.
}