Fallback created for git commands not standard handled by this module

main.rkt

@@ -10,6 +10,7 @@
          "private/find-mergetool.rkt"
          simple-log
          racket/string
+         racket/list
          net/sendurl
          )
 
@@ -48,11 +49,15 @@
          git-next-version
          find-editor
          find-editors
+         editor-downloads
          set-editor!
          set-editor-auto!
          find-mergetool
+         find-mergetools
          find-mergetool-path
+         mergetool-downloads
          set-mergetool!
+         set-mergetool-auto!
          default-git-authentication-handler
          current-git-authentication-handler
          exn:fail:git-auth?
@@ -91,17 +96,26 @@
      (git* cmd arg ...))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-; 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.
+; goal   : Invoke a Git command through a registered wrapper or direct fallback.
+; pre    : command identifies a Git command and args contains its arguments.
+; post   : Registered commands use their wrapper; other commands are passed to Git.
+; result : The command-specific result or the standard Git command result.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define (git command . args)
-  ((hash-ref git-commands command
-             (λ ()
-               (error "Not a supported or recognized git command: " command)))
-   args))
+  (let ((cmd (hash-ref git-commands command #f)))
+    (if cmd
+        (cmd args)
+        (let-values (((exit-code output)
+                      (run-git (cons command (flatten args)))))
+          (let-values (((result out) (git-out command output)))
+            (std-process-git-result
+             command
+             exit-code
+             result
+             output
+             out
+             (make-hash)))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Supporting functions
@@ -261,6 +275,8 @@
                      (+ (length editors) 1)))
   (displayln (format "  ~a. Automatic detection"
                      (+ (length editors) 2)))
+  (displayln (format "  ~a. Download/install suggestions"
+                     (+ (length editors) 3)))
   (displayln "  0. Cancel")
   (newline))
 
@@ -275,6 +291,7 @@
     (display-editor-selection editors)
     (let* ((custom-index (+ (length editors) 1))
            (auto-index (+ (length editors) 2))
+           (downloads-index (+ (length editors) 3))
            (choice
             (input-prompt
              "Editor: "
@@ -286,7 +303,7 @@
                   (let ((n (string->number value)))
                     (if (and n
                              (integer? n)
-                             (<= 0 n auto-index))
+                             (<= 0 n downloads-index))
                         n
                         #f))))))))
       (cond
@@ -309,6 +326,10 @@
                (set-editor! command))))
         ((= choice auto-index)
          (set-editor-auto!))
+        ((= choice downloads-index)
+         (display-download-pointers
+          "Suggested editors:"
+          (editor-downloads)))
         (else #f)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -326,6 +347,10 @@
           (git-argument=? (car args) '--list))
      (available-editors))
 
+    ((and (= (length args) 1)
+          (git-argument=? (car args) '--downloads))
+     (editor-downloads))
+
     ((and (= (length args) 1)
           (git-argument=? (car args) 'auto))
      (set-editor-auto!))
@@ -337,7 +362,177 @@
            (set-editor! (format "~a" (car args))))))
 
     (else
-     (error 'git-config "Expected config editor [--list|auto|editor-name|editor-command]"))))
+     (error 'git-config "Expected config editor [--list|--downloads|auto|editor-name|editor-command]"))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Display official download pointers.
+; pre    : items contains (name description url) items.
+; post   : The pointers have been displayed.
+; result : void.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (display-download-pointers title items)
+  (displayln title)
+  (newline)
+  (for-each
+   (λ (item)
+     (displayln (format "  ~a" (cadr item)))
+     (displayln (format "  ~a" (caddr item)))
+     (newline))
+   items)
+  (void))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Return the merge tool description matching a configured tool name.
+; pre    : name can be formatted as a merge tool name.
+; post   : The merge tool list has only been inspected.
+; result : A (name description path) item, or #f.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (find-mergetool-by-name name)
+  (let ((name* (string-downcase (format "~a" name))))
+    (let loop ((tools (find-mergetools)))
+      (cond
+        ((null? tools) #f)
+        ((string=? (string-downcase (car (car tools))) name*)
+         (car tools))
+        (else
+         (loop (cdr tools)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Return a Racket-oriented list of available merge tools.
+; pre    : The platform merge tool finder is available.
+; post   : No merge tool has been started.
+; result : (name description path current?) items.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (available-mergetools)
+  (let ((current (find-mergetool)))
+    (map
+     (λ (tool)
+       (list (car tool)
+             (cadr tool)
+             (caddr tool)
+             (and current
+                  (string=? current (car tool)))))
+     (find-mergetools))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Display the interactive git-cli merge tool selection.
+; pre    : tools contains the discovered merge tool descriptions.
+; post   : The choices have been displayed.
+; result : void.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (display-mergetool-selection tools)
+  (displayln "Available merge tools:")
+  (newline)
+  (let loop ((items tools)
+             (index 1))
+    (unless (null? items)
+      (let* ((tool (car items))
+             (current (find-mergetool))
+             (current? (and current
+                            (string=? current (car tool)))))
+        (displayln
+         (format "  ~a. ~a~a"
+                 index
+                 (cadr tool)
+                 (if current? "  [current]" "")))
+        (displayln (format "     ~a" (caddr tool)))
+        (newline)
+        (loop (cdr items) (+ index 1)))))
+  (displayln (format "  ~a. Specify another merge tool name"
+                     (+ (length tools) 1)))
+  (displayln (format "  ~a. Automatic detection"
+                     (+ (length tools) 2)))
+  (displayln (format "  ~a. Download/install suggestions"
+                     (+ (length tools) 3)))
+  (displayln "  0. Cancel")
+  (newline))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Ask the user to choose or enter the merge tool used by git-cli.
+; pre    : Standard input and output are available.
+; post   : A selected merge tool has been stored, automatic detection was restored,
+;          download pointers were shown, or the operation was cancelled.
+; result : The selected merge tool name, #f after cancellation, or void after pointers.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (configure-mergetool-interactively)
+  (let ((tools (find-mergetools)))
+    (display-mergetool-selection tools)
+    (let* ((custom-index (+ (length tools) 1))
+           (auto-index (+ (length tools) 2))
+           (downloads-index (+ (length tools) 3))
+           (choice
+            (input-prompt
+             "Merge tool: "
+             #:loop-until
+             (λ (value)
+               (cond
+                 ((eof-object? value) 'cancel)
+                 (else
+                  (let ((n (string->number value)))
+                    (if (and n
+                             (integer? n)
+                             (<= 0 n downloads-index))
+                        n
+                        #f))))))))
+      (cond
+        ((eq? choice 'cancel) #f)
+        ((= choice 0) #f)
+        ((<= choice (length tools))
+         (set-mergetool! (car (list-ref tools (- choice 1)))))
+        ((= choice custom-index)
+         (let ((tool
+                (input-prompt
+                 "Merge tool name: "
+                 #:loop-until
+                 (λ (value)
+                   (cond
+                     ((eof-object? value) 'cancel)
+                     ((string=? (string-trim value) "") #f)
+                     (else value))))))
+           (if (eq? tool 'cancel)
+               #f
+               (set-mergetool! tool))))
+        ((= choice auto-index)
+         (set-mergetool-auto!))
+        ((= choice downloads-index)
+         (display-download-pointers
+          "Suggested merge tools:"
+          (mergetool-downloads)))
+        (else #f)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; goal   : Process the git-cli-specific `config mergetool` command.
+; pre    : args contains the arguments following `mergetool`.
+; post   : The requested merge tool configuration action has been performed.
+; result : Merge tool data, the selected tool name, download pointers, or #f.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (git-config-mergetool args)
+  (cond
+    ((null? args)
+     (configure-mergetool-interactively))
+
+    ((and (= (length args) 1)
+          (git-argument=? (car args) '--list))
+     (available-mergetools))
+
+    ((and (= (length args) 1)
+          (git-argument=? (car args) '--downloads))
+     (mergetool-downloads))
+
+    ((and (= (length args) 1)
+          (git-argument=? (car args) 'auto))
+     (set-mergetool-auto!))
+
+    ((= (length args) 1)
+     (let ((tool (find-mergetool-by-name (car args))))
+       (if tool
+           (set-mergetool! (car tool))
+           (set-mergetool! (format "~a" (car args))))))
+
+    (else
+     (error 'git-config
+            "Expected config mergetool [--list|--downloads|auto|tool-name]"))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (define (git-config-args args info)
@@ -579,10 +774,15 @@
   process-git-config-result)
 
 (define (cmd-git-config args)
-  (if (and (pair? args)
-           (git-argument=? (car args) 'editor))
-      (git-config-editor (cdr args))
-      (cmd-git-config-git args)))
+  (cond
+    ((and (pair? args)
+          (git-argument=? (car args) 'editor))
+     (git-config-editor (cdr args)))
+    ((and (pair? args)
+          (git-argument=? (car args) 'mergetool))
+     (git-config-mergetool (cdr args)))
+    (else
+     (cmd-git-config-git args))))
 
 (define (git-config . args)
   (cmd-git-config args))