#lang racket/base

(require "private/git-provider.rkt"
         "private/git-commands.rkt"
         "private/config.rkt"
         "private/diff.rkt"
         "private/info-handler.rkt"
         "private/utils.rkt"
         "private/find-editor.rkt"
         "private/find-mergetool.rkt"
         simple-log
         racket/string
         net/sendurl
         )

(provide gt
         git*
         git
         git-add
         git-status
         git-commit
         git-pull
         git-push
         git-fetch
         git-switch
         git-tag
         git-config
         git-log
         git-grep
         git-branch
         git-remote
         git-stash
         git-restore
         git-reset
         git-revert
         git-rebase
         git-merge
         git-cherry-pick
         git-mergetool
         git-clone
         git-rev-list
         git-diff
         git-show
         git-help
         git-version
         git-new-version
         git-next-version
         find-editor
         set-editor!
         find-mergetool
         find-mergetool-path
         set-mergetool!
         default-git-authentication-handler
         current-git-authentication-handler
         exn:fail:git-auth?
         exn:fail:git-auth-command
         exn:fail:git-auth-args
         exn:fail:git-auth-exit-code
         exn:fail:git-auth-output
         (all-from-out "private/diff.rkt")
         )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define git-commands (make-hash))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 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 arg ...)
     (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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (git command . args)
  ((hash-ref git-commands command
             (λ ()
               (error "Not a supported or recognized git command: " command)))
   args))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Supporting functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Read one line of input after displaying a prompt.
; pre    : p can be displayed.
; post   : The prompt has been flushed before input is read.
; result : The entered line or an EOF object.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(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.
; post   : Existing porcelain options have not been duplicated.
; result : The transformed Git argument list.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (add-porcelain args info . f)
  (let ((m (has-git-arg? args #px"^[-][-]porcelain([=](.*))?"))
        (g (if (null? f) (λ (x) x) (car f)))
        )
    (if m
        (g args)
        (g (cons '--porcelain args)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Convert one porcelain status character to a semantic symbol.
; pre    : status is one Git porcelain v1 status character.
; post   : Unknown status characters have raised an exception.
; result : The corresponding semantic status symbol.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (status->symbol status)
  (cond
    ((string=? status " ") 'unchanged)
    ((string=? status "M") 'modified)
    ((string=? status "T") 'type-changed)
    ((string=? status "A") 'added)
    ((string=? status "D") 'deleted)
    ((string=? status "R") 'renamed)
    ((string=? status "C") 'copied)
    ((string=? status "U") 'unmerged)
    ((string=? status "?") 'untracked)
    ((string=? status "!") 'ignored)
    (else (error 'git-status "Unexpected status: ~a" status))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Recognize Git output that reports there is nothing to commit.
; pre    : out is a list of Git output lines.
; post   : out has only been inspected.
; result : #t when a known nothing-to-commit message occurs, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (nothing-to-commit? out)
  (ormap (λ (line)
           (let ((line* (string-downcase line)))
             (or (string-contains? line* "nothing to commit")
                 (string-contains? line* "no changes added to commit"))))
         out))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Convert one git config --list output line to a key/value item.
; pre    : line is one line produced by git config --list.
; post   : line has only been inspected.
; result : A list containing the configuration key and value.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (config-line->item line)
  (let ((m (regexp-match #px"^([^=]+)=(.*)$" line)))
    (if m
        (list (cadr m) (caddr m))
        (list line ""))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Translate the Racket-oriented config interface to git config arguments.
; pre    : args starts with get or set! and follows one of the supported forms.
; post   : info contains the config operation used to process Git's result.
; result : Arguments accepted by git config.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (git-config-args args info)
  (define (scope? x)
    (git-argument-member? x '(--global --local --system)))

  (define (split-scope args)
    (cond
      ((and (pair? args) (scope? (car args)))
       (values (car args) (cdr args)))
      (else
       (values #f args))))

  (let-values (((scope args*) (split-scope args)))
    (cond
      ;; Short form: (git 'config '--all)
      ((and (not scope)
            (= (length args*) 1)
            (git-argument=? (car args*) '--all))
       (hash-set! info 'config-operation 'all)
       '(--list))

      ((null? args*)
       (error 'git-config "Expected get or set!"))

      (else
       (let ((action (car args*))
             (rest (cdr args*)))
         (cond
           ((git-argument=? action 'get)
            ;; Also accept scope directly after get.
            (let-values (((scope* rest*) (split-scope rest)))
              (let ((effective-scope (or scope scope*)))
                (when (and scope scope*)
                  (error 'git-config "Configuration scope specified twice"))
                (cond
                  ((null? rest*)
                   (error 'git-config "Expected a configuration key or --all"))

                  ((git-argument=? (car rest*) '--all)
                   (cond
                     ((null? (cdr rest*))
                      (hash-set! info 'config-operation 'all)
                      (append (if effective-scope (list effective-scope) '())
                              '(--list)))
                     ((null? (cddr rest*))
                      (hash-set! info 'config-operation 'get-all)
                      (append (if effective-scope (list effective-scope) '())
                              (list '--get-all (cadr rest*))))
                     (else
                      (error 'git-config "Too many arguments for config get --all"))))

                  ((null? (cdr rest*))
                   (hash-set! info 'config-operation 'get)
                   (append (if effective-scope (list effective-scope) '())
                           (list '--get (car rest*))))

                  (else
                   (error 'git-config "Too many arguments for config get"))))))

           ((git-argument=? action 'set!)
            ;; Also accept scope directly after set!.
            (let-values (((scope* rest*) (split-scope rest)))
              (let ((effective-scope (or scope scope*)))
                (when (and scope scope*)
                  (error 'git-config "Configuration scope specified twice"))
                (if (= (length rest*) 2)
                    (begin
                      (hash-set! info 'config-operation 'set)
                      (append (if effective-scope (list effective-scope) '())
                              rest*))
                    (error 'git-config "Expected config set! [scope] key value")))))

           (else
            (error 'git-config "Expected get or set!"))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Process the result of the Racket-oriented git config interface.
; pre    : info contains the operation selected by git-config-args.
; post   : Successful query output has been converted to Racket data.
; result : Config data, #f for a missing single key, or #t after set!.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (process-git-config-result cmd exit-code result output out info)
  (let* ((operation (hash-ref info 'config-operation))
         (stdout (map cadr
                      (filter (λ (entry) (eq? (car entry) 'stdout))
                              output))))
    (cond
      ((eq? operation 'all)
       (if (= exit-code 0)
           (map config-line->item stdout)
           (std-process-git-result cmd exit-code result output out info)))

      ((eq? operation 'get-all)
       (cond
         ((= exit-code 0) stdout)
         ((= exit-code 1) '())
         (else
          (std-process-git-result cmd exit-code result output out info))))

      ((eq? operation 'get)
       (cond
         ((= exit-code 0)
          (if (null? stdout) #f (car stdout)))
         ((= exit-code 1) #f)
         (else
          (std-process-git-result cmd exit-code result output out info))))

      (else
       (std-process-git-result cmd exit-code result output out info)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Command definition macro
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Define and register a public Git command procedure.
; pre    : pre-code and process-result follow the command proxy interfaces.
; post   : cmd-sym is registered in the generic git command table.
; result : Definitions for the public and internal command procedures.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax def-cmd
  (syntax-rules ()
    ((_ cmd cmd* cmd-sym)
     (def-cmd cmd cmd* cmd-sym (λ (args info) 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*)))
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Typical git commands
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Return the complete Git index and worktree status for every reported file.
; pre    : The current directory is inside a Git working tree.
; post   : Git status has been invoked with --porcelain.
; result : A list containing (index-status worktree-status file) for every file.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-status cmd-git-status 'status
  add-porcelain
  (λ (cmd exit-code result output out info)
    (dbg-git (format "~a" output))
    (if (= exit-code 0)
        (map (λ (line)
               (if (< (string-length line) 3)
                   (git-error 'status "Unexpected output" line)
                   (list (status->symbol (substring line 0 1))
                         (status->symbol (substring line 1 2))
                         (substring line 3))))
             (map cadr
                  (filter (λ (entry) (eq? (car entry) 'stdout)) output)))
        (git-error 'status "Exitcode <> 0" (cons (format "~a\n" exit-code) output))
        ))
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Add file contents to the Git index.
; pre    : The supplied arguments are valid for git add.
; post   : Git add has completed successfully or an exception has been raised.
; result : #t after a successful Git command.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-add cmd-git-add 'add)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Create a Git commit.
; pre    : A commit message is supplied or can be requested from the user.
; post   : The commit was created, nothing needed committing, or an exception was raised.
; result : #t after a commit or when the repository has nothing to commit.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-commit cmd-git-commit 'commit
  (λ (args info)
    (with-handlers ([exn:fail? (λ (e)
                                 (let ((msg (string-trim (git-prompt "Commit message:\n>"))))
                                   (if (string=? msg "")
                                       (raise "A commit message is mandatory")
                                       (cons '-m (cons msg args)))))])
      (check-git-args 'commit args '((-m 1 "A commit message is mandatory")))))
  (λ (cmd exit-code result output out info)
    (cond
      ((and (= exit-code 1)
            (nothing-to-commit? out))
       (git-displ out)
       #t)
      (else 
       (std-process-git-result cmd exit-code result output out info))))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Push local changes to a remote repository.
; pre    : The supplied arguments are valid for git push.
; post   : Git push has completed successfully or an exception has been raised.
; result : #t after a successful push.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-push cmd-git-push 'push add-porcelain)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Fetch and integrate changes from a remote repository.
; pre    : The supplied arguments are valid for git pull.
; post   : Git pull has completed successfully or an exception has been raised.
; result : #t after a successful pull.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-pull cmd-git-pull 'pull)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Download refs and objects from a remote repository.
; pre    : The supplied arguments are valid for git fetch.
; post   : Git fetch has completed successfully or an exception has been raised.
; result : #t after a successful fetch.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-fetch cmd-git-fetch 'fetch)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Read or write Git configuration through a Racket-oriented interface.
; pre    : Arguments follow one of the supported get/set! forms.
; post   : Git config has completed or an exception has been raised.
; result : Structured config data, #f for a missing key, or #t after set!.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-config cmd-git-config 'config
  git-config-args
  process-git-config-result)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : List, create or delete branches.
; pre    : The supplied arguments are valid for git branch.
; post   : Git branch has completed successfully or an exception was raised.
; result : A structured branch list with --list/-l, otherwise #t.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-branch cmd-git-branch 'branch
  (λ (args info)
    (let* ((split-id (format "git-cli-branch-split-~a-~a"
                             (random 1000000000)
                             (random 1000000000)))
           (list-output
            (ormap
             (λ (e)
               (let ((o (format "~a" e)))
                 (or (string=? o "--list")
                     (string=? o "-l"))))
             args)))
      (hash-set! info 'scheme-format list-output)
      (hash-set! info 'branch-split-id split-id)
      (if list-output
          (append args
                  (list
                   (format "--format=%(HEAD)~a%(refname)" split-id)))
          args)))
  (λ (cmd exit-code result output out info)
    (if (hash-ref info 'scheme-format #f)
        (if (and (= exit-code 0) result)
            (let ((split-id (hash-ref info 'branch-split-id)))
              (map
               (λ (line)
                 (let* ((parts (string-split line split-id #:trim? #f))
                        (head (car parts))
                        (ref (if (null? (cdr parts)) "" (cadr parts))))
                   (cond
                     ((string-prefix? ref "refs/heads/")
                      (list (if (string=? head "*") 'current 'local)
                            (substring ref (string-length "refs/heads/"))))
                     ((string-prefix? ref "refs/remotes/")
                      (list 'remote
                            (substring ref (string-length "refs/remotes/"))))
                     (else
                      (list 'branch ref)))))
               out))
            (std-process-git-result cmd exit-code result output out info))
        (std-process-git-result cmd exit-code result output out info)))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : List, add, rename or remove remotes.
; pre    : The supplied arguments are valid for git remote.
; post   : Git remote has completed successfully or an exception was raised.
; result : A structured remote list with --list/-l, otherwise #t.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-remote cmd-git-remote 'remote
  (λ (args info)
    (cond
      ((null? args)
       (hash-set! info 'remote-operation 'list)
       args)

      ((and (= (length args) 1)
            (git-argument-member? (car args) '(-v --verbose)))
       (hash-set! info 'remote-operation 'verbose-list)
       args)

      ((git-argument=? (car args) 'get-url)
       (hash-set! info 'remote-operation
                  (if (ormap (λ (arg) (git-argument=? arg '--all)) args)
                      'get-url-all
                      'get-url))
       args)

      (else
       (hash-set! info 'remote-operation 'command)
       args)))

  (λ (cmd exit-code result output out info)
    (let* ((operation (hash-ref info 'remote-operation 'command))
           (stdout (map cadr
                        (filter (λ (entry) (eq? (car entry) 'stdout))
                                output))))
      (cond
        ((eq? operation 'list)
         (if (= exit-code 0)
             stdout
             (std-process-git-result cmd exit-code result output out info)))

        ((eq? operation 'verbose-list)
         (if (= exit-code 0)
             (map
              (λ (line)
                (let ((m (regexp-match
                          #px"^([^\\s]+)\\s+(.+) \\((fetch|push)\\)$"
                          line)))
                  (if m
                      (list (cadr m)
                            (caddr m)
                            (string->symbol (cadddr m)))
                      (list line #f 'unknown))))
              stdout)
             (std-process-git-result cmd exit-code result output out info)))

        ((eq? operation 'get-url)
         (if (= exit-code 0)
             (if (null? stdout) #f (car stdout))
             (std-process-git-result cmd exit-code result output out info)))

        ((eq? operation 'get-url-all)
         (if (= exit-code 0)
             stdout
             (std-process-git-result cmd exit-code result output out info)))

        (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   : Resolve merge conflicts using a graphical Git merge tool.
; pre    : The supplied arguments are valid for git mergetool.
; post   : Git mergetool has completed successfully or an exception was raised.
; result : #t after a successful mergetool command.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-mergetool cmd-git-mergetool 'mergetool
  (λ (args info)
    (let ((tool-specified
           (ormap
            (λ (arg)
              (let ((value (format "~a" arg)))
                (or (string=? value "-t")
                    (regexp-match? #px"^--tool=" value)
                    (string=? value "--tool-help"))))
            args)))
      (if tool-specified
          args
          (let ((tool (find-mergetool)))
            (if tool
                (cons (format "--tool=~a" tool) args)
                args))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Switch branches.
; pre    : The supplied arguments are valid for git switch.
; post   : Git switch has completed successfully or an exception has been raised.
; result : #t after a successful switch.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-switch cmd-git-switch 'switch)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Clone a repository into a new directory.
; pre    : The supplied arguments are valid for git clone.
; post   : The clone exists or an exception was raised.
; result : #t after a successful clone.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-clone cmd-git-clone 'clone)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : List, create, delete or verify tags.
; pre    : The supplied arguments are valid for git tag.
; post   : Git tag has completed successfully or an exception has been raised.
; result : A list of tag names with --list/-l, a list of (tag annotation)
;          items when -n is combined with --list/-l, otherwise #t.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-tag cmd-git-tag 'tag
  (λ (args info)
    (let* ((split-id (format "git-cli-tag-split-~a-~a"
                             (random 1000000000)
                             (random 1000000000)))
           (record-id (format "git-cli-tag-record-~a-~a"
                              (random 1000000000)
                              (random 1000000000)))
           (scheme-format #f)
           (tag-lines #f))
      (for-each
       (λ (e)
         (let* ((o (format "~a" e))
                (m (regexp-match #px"^[-]n([0-9]+)?$" o)))
           (when (or (string=? o "--list")
                     (string=? o "-l"))
             (set! scheme-format #t))
           (when m
             (set! tag-lines
                   (if (cadr m)
                       (string->number (cadr m))
                       1)))))
       args)

      (hash-set! info 'scheme-format scheme-format)
      (hash-set! info 'tag-lines tag-lines)
      (hash-set! info 'tag-split-id split-id)
      (hash-set! info 'tag-record-id record-id)

      (map
       (λ (e)
         (let* ((o (format "~a" e))
                (m (regexp-match #px"^[-]n([0-9]+)?$" o)))
           (if (and scheme-format m)
               (format "--format=%(refname:strip=2)~a~a~a"
                       split-id
                       (if (> tag-lines 1)
                           (format "%(contents:lines=~a)" tag-lines)
                           "%(contents:subject)")
                       record-id)
               e)))
       args)))

  (λ (cmd exit-code result output out info)
    (if (hash-ref info 'scheme-format #f)
        (if (and (= exit-code 0) result)
            (let ((tag-lines (hash-ref info 'tag-lines #f)))
              (if tag-lines
                  (let* ((split-id (hash-ref info 'tag-split-id))
                         (record-id (hash-ref info 'tag-record-id))
                         (text (string-join out "\n"))
                         (records (string-split text record-id #:trim? #f)))
                    (map
                     (λ (record)
                       (string-split (string-trim record) split-id #:trim? #f))
                     (filter (λ (record)
                               (not (string=? (string-trim record) "")))
                             records)))
                  out))
            (std-process-git-result cmd exit-code result output out info))
        (std-process-git-result cmd exit-code result output out info)))
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Display the Git commit log or return it as a Racket list.
; pre    : The supplied arguments are valid for git log; --list and -l are git-cli options.
; post   : Git log has completed successfully or an exception has been raised.
; result : A list of (commit subject) items with --list/-l, otherwise #t.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-log cmd-git-log 'log
  (λ (args info)
    (map (λ (e)
           (let ((o (format "~a" e)))
             (cond
               ((or
                 (string=? o "--list")
                 (string=? o "-l"))
                (begin
                  (hash-set! info 'scheme-format #t)
                  "--oneline"))
               (else e))))
         args))
  (λ (cmd exit-code result output out info)
    (if (hash-ref info 'scheme-format #f)
        (if (and (= exit-code 0) result)
            (let ((re #px"([0-9a-f]+)\\s+(.*)"))
              (map (λ (line)
                     (let ((m (regexp-match re line)))
                       (if m
                           (list (cadr m) (caddr m))
                           (list #f line))))
                   out))
            #f)
        (std-process-git-result cmd exit-code result output out info)))
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : List commit objects reachable from supplied revisions.
; pre    : The supplied arguments are valid for git rev-list.
; post   : Git rev-list has completed successfully or an exception was raised.
; result : #t after successfully displaying the result.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-rev-list cmd-git-rev-list 'rev-list)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Render a Git diff in the default browser.
; pre    : The supplied arguments are valid for git diff or
;          are special cases like --output=-, --output=string.
; post   : A successful diff has been rendered as HTML or
;          to stdout/string.
; result : #t or a string when a diff was rendered, otherwise #f.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-diff cmd-git-diff 'diff
  (λ (args info)
    (hash-set! info 'file-output (has-git-arg? args #px"^[-][-]output[=]"))
    (hash-set! info 'stdout (has-git-arg? args #px"^[-][-]output[=][-]"))
    (hash-set! info 'string (has-git-arg? args #px"^[-][-]output[=]string"))
    (if (or (hash-ref info 'stdout #f) (hash-ref info 'string #f))
        (filter (λ (e) (not (has-git-arg? (list e) #px"^[-][-]output[=]([-]|string)"))) args)
        args))
  (λ (cmd exit-code result output out info)
    (if (and (zero? exit-code)
             result)
        (if (eq? (hash-ref info 'file-output #f) #f)
            (let ((diff (string-join 
                         (filter (λ (line)
                               (not (string-prefix? (string-downcase line) "warning:")))
                                 out)
                         "\n")))
              (diff->html diff)
              #t)
            (if (hash-ref info 'string #f)
                (string-join out "\n")
                (std-process-git-result cmd exit-code result output out info)))
        (std-process-git-result cmd exit-code result output out info))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Show a Git object, render a commit diff as HTML or return structured output.
; pre    : The supplied arguments are valid for git show; --list/-l and
;          --output=html/--output=-/--output=string are git-cli options.
; post   : Git show has completed successfully or an exception has been raised.
; result : Structured Racket data with --list/-l, a string with --output=string,
;          otherwise #t.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-show cmd-git-show 'show
  (λ (args info)
    (let* ((list-output (ormap (λ (e) (member (format "~a" e) '("--list" "-l"))) args))
           (output-html (has-git-arg? args #px"^[-][-]output[=]html$"))
           (output-stdout (has-git-arg? args #px"^[-][-]output[=][-]$"))
           (output-string (has-git-arg? args #px"^[-][-]output[=]string$"))
           (name-only (has-git-arg? args #px"^[-][-]name-only$"))
           (name-status (has-git-arg? args #px"^[-][-]name-status$"))
           (stat (has-git-arg? args #px"^[-][-]stat([=](.*))?$"))
           (no-patch (or (has-git-arg? args #px"^[-][-]no-patch$")
                         (has-git-arg? args "-s")))
           (list-formats (filter (λ (x) x)
                                 (list (if name-only 'name-only #f)
                                       (if name-status 'name-status #f)
                                       (if stat 'stat #f)))))
      
      (when (and list-output (or output-html output-stdout output-string))
        (error 'git-show "--list/-l cannot be combined with --output=..."))
      (when (and list-output (> (length list-formats) 1))
        (error 'git-show "--list/-l accepts only one of --stat, --name-only or --name-status"))

      (hash-set! info 'scheme-format list-output)
      (hash-set! info 'show-list-format (if (null? list-formats) 'stat (car list-formats)))
      (hash-set! info 'show-output
                 (cond (output-html 'html)
                       (output-stdout 'stdout)
                       (output-string 'string)
                       ((or stat name-only name-status no-patch) 'stdout)
                       (else 'html)))

      (let ((nargs (filter (λ (e)
                             (not (member (format "~a" e)
                                          '("--list" "-l"
                                            "--output=html" "--output=-" "--output=string"))))
                           args)))
        (if (and list-output (null? list-formats))
            (cons '--stat nargs)
            nargs))))

  (λ (cmd exit-code result output out info)
    (if (and (zero? exit-code) result)
        (cond
          ((hash-ref info 'scheme-format #f)
           (let ((lines (filter (λ (line) (not (string=? (string-trim line) ""))) out)))
             (case (hash-ref info 'show-list-format 'stat)
               ((name-only) lines)
               ((name-status) (map (λ (line) (string-split line "\t")) lines))
               ((stat)
                (let ((file-re #px"^\\s*(.*?)\\s+[|]\\s+([0-9]+)\\s+([+\\-]+)$")
                      (total-re #px"^([0-9]+) files? changed(, ([0-9]+) insertions?\\(\\+\\))?(, ([0-9]+) deletions?\\(-\\))?$"))
                  (map (λ (line)
                         (let* ((trimmed (string-trim line))
                                (fm (regexp-match file-re line))
                                (tm (regexp-match total-re trimmed)))
                           (cond
                             (fm (list 'file (cadr fm) (string->number (caddr fm)) (cadddr fm)))
                             (tm (list 'total
                                       (string->number (cadr tm))
                                       (if (cadddr tm) (string->number (cadddr tm)) 0)
                                       (if (list-ref tm 5) (string->number (list-ref tm 5)) 0)))
                             (else (list 'info line)))))
                       lines))))))
          ((eq? (hash-ref info 'show-output 'html) 'string)
           (string-join out "\n"))
          ((eq? (hash-ref info 'show-output 'html) 'html)
           (show->html
            (string-join
             (filter (λ (line) (not (string-prefix? (string-downcase line) "warning:"))) out)
             "\n"))
           #t)
          (else (std-process-git-result cmd exit-code result output out info)))
        (std-process-git-result cmd exit-code result output out info))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Search tracked files for a pattern.
; pre    : The supplied arguments are valid for git grep.
; post   : Git grep has completed; exit code one is treated as no matches.
; result : A list containing file, line number, match count and matched text.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-grep cmd-git-grep 'grep
  (λ (args info)
    (let ((matches #f)
          (line-nr #f)
          )
          
      (let ((nargs (map
                    (λ (e)
                      (let ((o (format "~a" e)))
                        (cond
                          ((string=? o "-c") (set! matches #t))
                          ((string=? o "-n") (set! line-nr #t))))
                      e)
                    (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)
        (hash-set! info 'line-nr (if matches #f line-nr))
        nargs)))
  (λ (cmd exit-code result output out info)
    (with-handlers ([exn:fail? (λ (e)
                                 (err-git (string-join (map cadr output) "\n"))
                                 (raise e))])
      (if (and result
               (or (= exit-code 0) (= exit-code 1)))
          (let ((re #px"([^:]+)[:]([^:]+)([:](.*))?"))
            (map (λ (line)
                   (let ((m (regexp-match re line)))
                     (let ((line-nr (if (hash-ref info 'line-nr #f)
                                        (if (eq? m #f)
                                            #f
                                            (string->number (caddr m)))
                                        #f))
                           (matches (if (hash-ref info 'matches #f)
                                        (if (eq? m #f)
                                            #f
                                            (string->number (caddr m)))
                                        #f))
                           )
                       (if m
                           (list (cadr m) line-nr matches (cadddr (cdr m)))
                           (list line #f #f #f)))))
                 out))
          (begin
            (err-git (string-join (map cadr output) "\n"))
            #f))))
  )


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Display help for Git or a Git command.
; pre    : The supplied arguments are valid for git help.
; post   : Git help has completed successfully or an exception was raised.
; result : #t after successfully displaying help.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(def-cmd git-help cmd-git-help 'help)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Racket module versioning
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Return the package version from info.rkt.
; pre    : No arguments are required.
; post   : info.rkt has only been inspected.
; result : A list containing major, minor and patch.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (git-version . args)
  (cmd-git-version args))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Implement the registered version command.
; pre    : args is the command argument list.
; post   : info.rkt has only been inspected.
; result : A list containing major, minor and patch.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (cmd-git-version args)
  (info-version "."))

(hash-set! git-commands 'version cmd-git-version)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Increment the package version in info.rkt.
; pre    : kind is 'maj, 'major, 'min, 'minor or 'patch.
; post   : The version definition in info.rkt has been updated.
; result : The new version as a list containing major, minor and patch.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (git-new-version . args)
  (cmd-git-new-version args))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Implement the registered new-version command.
; pre    : args contains a supported version kind.
; post   : The version definition in info.rkt has been updated.
; result : The new version as a list containing major, minor and patch.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (cmd-git-new-version args)
  (when (null? args)
      (error "git-new-version expects 'maj, 'major, 'min, 'minor or 'patch"))
  (let ((kind (car args)))
    (info-next-version kind ".")
    (git-version)))

(hash-set! git-commands 'new-version cmd-git-new-version)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; goal   : Implement the registered next-version command.
; pre    : args must be empty. 
; post   : The version definition in info.rkt has been updated.
; result : The new patch version.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (git-next-version . args)
  (cmd-git-next-version args))

(define (cmd-git-next-version args)
  (unless (null? args)
    (error "git-next-version expexts no arguments"))
  (let ((kind 'patch))
    (info-next-version kind ".")
    (git-version)))

(hash-set! git-commands 'next-version cmd-git-next-version)