From 90a2b1758d501a28bab8e3a2d1fb451af3c22df1 Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Wed, 12 Aug 2026 15:50:53 +0200 Subject: [PATCH] git command structure now in place --- main.rkt | 75 ++++++++++++++++++++++++++++------- private/git-commands.rkt | 85 +++++++++++++++++----------------------- private/git-provider.rkt | 20 ++++++---- 3 files changed, 109 insertions(+), 71 deletions(-) diff --git a/main.rkt b/main.rkt index 127d823..3248cd8 100644 --- a/main.rkt +++ b/main.rkt @@ -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) diff --git a/private/git-commands.rkt b/private/git-commands.rkt index 06c3722..e79dd0e 100644 --- a/private/git-commands.rkt +++ b/private/git-commands.rkt @@ -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")))) - ) diff --git a/private/git-provider.rkt b/private/git-provider.rkt index 25c2ef2..5cfaf76 100644 --- a/private/git-provider.rkt +++ b/private/git-provider.rkt @@ -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)) )