More commands

main.rkt

@@ -12,6 +12,7 @@
          )
 
 (provide gt
+         git*
          git
          git-add
          git-status
@@ -26,6 +27,13 @@
          git-grep
          git-branch
          git-remote
+         git-stash
+         git-restore
+         git-reset
+         git-revert
+         git-rebase
+         git-merge
+         git-cherry-pick
          git-clone
          git-rev-list
          git-diff
@@ -54,10 +62,22 @@
 ;; Command invocation using 'git'
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(define-syntax git*-argument
+  (syntax-rules (eval)
+    ((_ (eval expr))
+     expr)
+    ((_ arg)
+     (format "~a" 'arg))))
+
+(define-syntax git*
+  (syntax-rules ()
+    ((_ cmd arg ...)
+     (git 'cmd (git*-argument arg) ...))))
+
 (define-syntax gt
   (syntax-rules ()
-    ((_ cmd a1 ...)
-     (git 'cmd 'a1 ...))))
+    ((_ cmd arg ...)
+     (git* cmd arg ...))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : Invoke a supported Git command through the command table.
@@ -85,6 +105,26 @@
 (define (git-prompt p)
   (input-prompt p))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Compare a Git argument independent of its Racket representation.
+; pre    : arg and expected can be formatted as command-line arguments.
+; post   : Neither value has been changed.
+; result : #t when both arguments have the same command-line text.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (git-argument=? arg expected)
+  (string=? (format "~a" arg)
+            (format "~a" expected)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Test whether a Git argument occurs in a set of accepted values.
+; pre    : values is a list of Git argument representations.
+; post   : arg and values have only been inspected.
+; result : #t when arg matches one of values.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (git-argument-member? arg values)
+  (ormap (λ (value) (git-argument=? arg value))
+         values))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : Add --porcelain to a Git argument list when it is absent.
 ; pre    : args is a list and an optional transformation accepts a list.
@@ -152,7 +192,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (define (git-config-args args info)
   (define (scope? x)
-    (member x '(--global --local --system)))
+    (git-argument-member? x '(--global --local --system)))
 
   (define (split-scope args)
     (cond
@@ -166,7 +206,7 @@
       ;; Short form: (git 'config '--all)
       ((and (not scope)
             (= (length args*) 1)
-            (eq? (car args*) '--all))
+            (git-argument=? (car args*) '--all))
        (hash-set! info 'config-operation 'all)
        '(--list))
 
@@ -177,7 +217,7 @@
        (let ((action (car args*))
              (rest (cdr args*)))
          (cond
-           ((eq? action 'get)
+           ((git-argument=? action 'get)
             ;; Also accept scope directly after get.
             (let-values (((scope* rest*) (split-scope rest)))
               (let ((effective-scope (or scope scope*)))
@@ -187,7 +227,7 @@
                   ((null? rest*)
                    (error 'git-config "Expected a configuration key or --all"))
 
-                  ((eq? (car rest*) '--all)
+                  ((git-argument=? (car rest*) '--all)
                    (cond
                      ((null? (cdr rest*))
                       (hash-set! info 'config-operation 'all)
@@ -208,7 +248,7 @@
                   (else
                    (error 'git-config "Too many arguments for config get"))))))
 
-           ((eq? action 'set!)
+           ((git-argument=? action 'set!)
             ;; Also accept scope directly after set!.
             (let-values (((scope* rest*) (split-scope rest)))
               (let ((effective-scope (or scope scope*)))
@@ -443,13 +483,13 @@
        args)
 
       ((and (= (length args) 1)
-            (member (car args) '(-v --verbose)))
+            (git-argument-member? (car args) '(-v --verbose)))
        (hash-set! info 'remote-operation 'verbose-list)
        args)
 
-      ((eq? (car args) 'get-url)
+      ((git-argument=? (car args) 'get-url)
        (hash-set! info 'remote-operation
-                  (if (member '--all args)
+                  (if (ormap (λ (arg) (git-argument=? arg '--all)) args)
                       'get-url-all
                       'get-url))
        args)
@@ -497,6 +537,94 @@
         (else
          (std-process-git-result cmd exit-code result output out info)))))
   )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Store, inspect or restore stashed working tree changes.
+; pre    : The supplied arguments are valid for git stash.
+; post   : Git stash has completed successfully or an exception was raised.
+; result : Structured stash entries for `stash list`, otherwise the normal result.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(def-cmd git-stash cmd-git-stash 'stash
+  (λ (args info)
+    (let ((list-output
+           (and (pair? args)
+                (git-argument=? (car args) 'list)
+                (not
+                 (ormap
+                  (λ (arg)
+                    (regexp-match?
+                     #px"^--(format|pretty)(=|$)"
+                     (format "~a" arg)))
+                  args)))))
+      (hash-set! info 'stash-list list-output)
+      (if list-output
+          (append args
+                  '("--format=%gd%x00%gs"))
+          args)))
+  (λ (cmd exit-code result output out info)
+    (if (hash-ref info 'stash-list #f)
+        (if (= exit-code 0)
+            (map
+             (λ (line)
+               (let ((parts (string-split line "\u0000" #:trim? #f)))
+                 (if (null? (cdr parts))
+                     (list (car parts) "")
+                     (list (car parts) (cadr parts)))))
+             (map cadr
+                  (filter (λ (entry) (eq? (car entry) 'stdout))
+                          output)))
+            (std-process-git-result cmd exit-code result output out info))
+        (std-process-git-result cmd exit-code result output out info)))
+  )
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Restore working tree or index files from a Git source.
+; 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   : Reset HEAD or selected paths according to Git reset semantics.
+; pre    : The supplied arguments are valid for git reset.
+; post   : Git reset has completed successfully or an exception was raised.
+; result : #t after a successful reset.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(def-cmd git-reset cmd-git-reset 'reset)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Revert one or more commits using Git's revert command.
+; pre    : The supplied arguments are valid for git revert.
+; post   : Git revert has completed successfully or an exception was raised.
+; result : #t after a successful revert or sequencer command.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(def-cmd git-revert cmd-git-revert 'revert)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Reapply commits on top of another base with Git rebase.
+; pre    : The supplied arguments are valid for git rebase.
+; post   : Git rebase has completed successfully or an exception was raised.
+; result : #t after a successful rebase or rebase control command.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(def-cmd git-rebase cmd-git-rebase 'rebase)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Join development histories with Git merge.
+; pre    : The supplied arguments are valid for git merge.
+; post   : Git merge has completed successfully or an exception was raised.
+; result : #t after a successful merge or merge control command.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(def-cmd git-merge cmd-git-merge 'merge)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Apply changes introduced by existing commits.
+; pre    : The supplied arguments are valid for git cherry-pick.
+; post   : Git cherry-pick has completed successfully or an exception was raised.
+; result : #t after a successful cherry-pick or sequencer command.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(def-cmd git-cherry-pick cmd-git-cherry-pick 'cherry-pick)
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ; goal   : Switch branches.
 ; pre    : The supplied arguments are valid for git switch.
@@ -760,7 +888,7 @@
                           ((string=? o "-c") (set! matches #t))
                           ((string=? o "-n") (set! line-nr #t))))
                       e)
-                    (map (λ (x) (if (eq? x '-i) "-i" x)) args))))
+                    (map (λ (x) (if (git-argument=? x '-i) "-i" x)) args))))
         (when (eq? line-nr #f)
           (set! nargs (cons "-n" nargs)))  ;; add line numbers / counts for pattern recognition
         (hash-set! info 'matches matches)