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

git command structure now in place

Browse Source
This commit is contained in:
Hans Dijkema
2026-08-12 15:50:53 +02:00
parent 5773450329
commit 90a2b1758d
3 changed files with 109 additions and 71 deletions
Download Patch File Download Diff File Expand all files Collapse all files
main.rkt
+60 -15
View File
@@ -4,32 +4,77 @@
"private/git-commands.rkt"
"private/config.rkt"
simple-log
racket/string
)
(provide git)
(provide git
git-add
git-status
git-commit
git-pull
git-push
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided commands
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (git command . args)
(cond
([eq? command 'status] (cmd-git-status args))
([eq? command 'add] (cmd-git-add args))
([eq? command 'commit] (cmd-git-commit args))
(else (error "Not supported git command '~a" command))
(define git-commands (make-hash))
(define-syntax git
(syntax-rules ()
((_ command b1 ...)
((hash-ref git-commands 'command
(λ ()
(error "Not supported git command '~a" 'command)))
(list b1 ...)))
)
)
(define-syntax def-cmd
(syntax-rules ()
((_ cmd cmd*)
(define (cmd . args)
(cmd* args)))))
((_ cmd cmd* cmd-sym)
(def-cmd cmd cmd* cmd-sym (λ (args) 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)
(begin
(def-git-cmd-proxy cmd* cmd-sym pre-code process-result)
(define (cmd . args) (cmd* args))
(hash-set! git-commands cmd-sym cmd*)))
)
)
(def-cmd git-status cmd-git-status 'status
(λ (args) (if (has-git-arg? args '-s)
args
(cons '-s args)))
(λ (cmd result output out)
(if result
(map (λ (line)
(let* ((state (string->symbol (string-trim (substring line 0 2))))
(file (string-trim (substring line 3))))
(cond
([eq? state '??] (list 'new file))
([eq? state 'M] (list 'modified file))
([eq? state 'A] (list 'added file))
([eq? state 'D] (list 'deleted file))
([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)))
)
(def-cmd git-status cmd-git-status)
(def-cmd git-add cmd-git-add)
(def-cmd git-commit cmd-git-commit)
(def-cmd git-add cmd-git-add 'add)
(def-cmd git-commit cmd-git-commit 'commit
(λ (args) (check-git-args 'commit args '((-m 1 "A commit message is mandatory"))))
)
(def-cmd git-push cmd-git-push 'push)
(def-cmd git-pull cmd-git-pull 'pull)
private/git-commands.rkt
+36 -49
View File
@@ -4,13 +4,29 @@
racket/string
)
(provide cmd-git-status
cmd-git-add
cmd-git-commit
(provide def-git-cmd-proxy
check-git-args
has-git-arg?
std-process-git-result
)
(define (check-arg cmd args flags)
(define (has-git-arg? args opt)
(if (list? args)
(if (null? args)
#f
(if (symbol? opt)
(if (or (eq? (car args) opt)
(and (string? (car args))
(string=? (car args) (symbol->string opt))))
#t
(has-git-arg? (cdr args) opt))
(error 'has-git-arg? "opt must be of type symbol?")))
(error 'has-git-arg? "args must be a list of arguments")
)
)
(define (check-git-args cmd args flags)
(for-each
(λ (opt)
(let ((flag (car opt))
@@ -29,59 +45,30 @@
(error 'git (format "git ~a: ~a" cmd err-msg))))
)
))
flags))
(define (cmd-git-status args)
(let ((output (run-git '(status -s))))
(let-values (((result out) (git-out 'status output)))
(if result
(map (λ (line)
(let* ((state (string->symbol (string-trim (substring line 0 2))))
(file (string-trim (substring line 3))))
(cond
([eq? state '??] (list 'new file))
([eq? state 'M] (list 'modified file))
([eq? state 'A] (list 'added file))
([eq? state 'D] (list 'deleted file))
([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" out)
)
)
)
)
flags)
args)
(define (std-process-git-result cmd result output out)
(git-displ out)
(if result
result
(git-error cmd "Error" out)))
(define-syntax def-proxy-cmd
(define-syntax def-git-cmd-proxy
(syntax-rules ()
((_ f cmd)
(def-proxy-cmd f cmd (λ args (begin #t))))
((_ f cmd code)
(def-proxy-cmd f cmd (λ args t) standard-result))
((_ f cmd pre-code)
(def-proxy-cmd f cmd pre-code standard-result))
((_ f cmd pre-code process-result)
(define (f args)
(code args)
(let ((output (run-git (cons 'cmd args))))
(let-values (((result out) (git-out 'cmd output)))
(if result
(begin
(git-displ out)
result)
(git-error 'cmd "Error" out)))))
)
(let ((nargs (pre-code args)))
(let ((output (run-git (cons cmd nargs))))
(let-values (((result out) (git-out cmd output)))
(process-result cmd result output out))))))
)
)
(def-proxy-cmd cmd-git-add add)
(def-proxy-cmd cmd-git-commit commit
(λ (args) (check-arg 'commit args '((-m 1 "A commit message is mandatory"))))
)
private/git-provider.rkt
+13 -7
View File
@@ -136,13 +136,19 @@
(define-syntax git-error
(syntax-rules ()
((_ cmd msg* out)
(let ((msg (format "git ~a: ~a: ~a" cmd msg* (string-join
(map (λ (e) (format "~a" e))
(if (list? out)
out
(list out)))
"\n"))))
((_ cmd msg* outp)
(let* ((out (map (λ (e) (if (list? e)
(if (null? e)
""
(if (or (eq? (car e) 'stdout)
(eq? (car e) 'stderr))
(format "~a" (cadr e))
(format "~a" e)))
(format "~a" e)))
(if (list? outp) outp (list outp))))
(enter (if (eq? (system-type 'os) 'windows) "\r\n" "\n"))
(msg (format "git ~a: ~a: ~a" cmd msg* (string-join out enter)))
)
(err-git msg)
(error 'git msg))
)