git command structure now in place

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)
+(define git-commands (make-hash))
-  (cond
+
-    ([eq? command 'status] (cmd-git-status args))
+(define-syntax git
-    ([eq? command 'add] (cmd-git-add args))
+  (syntax-rules ()
-    ([eq? command 'commit] (cmd-git-commit args))
+    ((_ command b1 ...)
-    (else (error "Not supported git command '~a" command))
+     ((hash-ref git-commands 'command
+                (λ ()
+                  (error "Not supported git command '~a" 'command)))
+      (list b1 ...)))
     )
   )
 
 (define-syntax def-cmd
   (syntax-rules ()
-    ((_ cmd cmd*)
+    ((_ cmd cmd* cmd-sym)
-     (define (cmd . args)
+     (def-cmd cmd cmd* cmd-sym (λ (args) args) std-process-git-result))
-       (cmd* args)))))
+    ((_ 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-add cmd-git-add 'add)
-(def-cmd git-status cmd-git-status)
+(def-cmd git-commit cmd-git-commit 'commit
-(def-cmd git-add cmd-git-add)
+  (λ (args) (check-git-args 'commit args '((-m 1 "A commit message is mandatory"))))
-(def-cmd git-commit cmd-git-commit)
+  )
-
+(def-cmd git-push cmd-git-push 'push)
+(def-cmd git-pull cmd-git-pull 'pull)

private/git-commands.rkt

@@ -4,13 +4,29 @@
          racket/string
          )
 
-(provide cmd-git-status
+(provide def-git-cmd-proxy
-         cmd-git-add
+         check-git-args
-         cmd-git-commit
+         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))
+   flags)
-
+  args)
-(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)
-          )
-      )
-    )
-  )
 
 
+(define (std-process-git-result cmd result output out)
+  (git-displ out)
+  (if result
+      result
+      (git-error cmd "Error" out)))
 
-
+(define-syntax def-git-cmd-proxy
-(define-syntax def-proxy-cmd
   (syntax-rules ()
     ((_ f cmd)
-     (def-proxy-cmd f cmd (λ args (begin #t))))
+     (def-proxy-cmd f cmd (λ args t) standard-result))
-    ((_ f cmd code)
+    ((_ 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 ((nargs (pre-code args)))
-       (let ((output (run-git (cons 'cmd args))))
+         (let ((output (run-git (cons cmd nargs))))
-         (let-values (((result out) (git-out 'cmd output)))
+           (let-values (((result out) (git-out cmd output)))
-           (if result
+             (process-result cmd result output out))))))
-               (begin
-                 (git-displ out)
-                 result)
-               (git-error 'cmd "Error" 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

@@ -136,13 +136,19 @@
 
 (define-syntax git-error
   (syntax-rules ()
-    ((_ cmd msg* out)
+    ((_ cmd msg* outp)
-     (let ((msg (format "git ~a: ~a: ~a" cmd msg* (string-join
+     (let* ((out (map (λ (e) (if (list? e)
-                                                   (map (λ (e) (format "~a" e))
+                                 (if (null? e)
-                                                        (if (list? out)
+                                     ""
-                                                            out
+                                     (if (or (eq? (car e) 'stdout)
-                                                            (list out)))
+                                             (eq? (car e) 'stderr))
-                                                   "\n"))))
+                                         (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))
      )