git-cli/main.rkt

#lang racket/base

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

(provide git
         git-add
         git-status
         git-commit
         git-pull
         git-push
         git-log
         git-grep
         git-new-version
         )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Provided commands
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define git-commands (make-hash))


(define-syntax git
  (syntax-rules ()
    ((_ command b1 ...)
     ((hash-ref git-commands command
                (λ ()
                  (error "Not a supported or recognized git command: " command)))
      (list b1 ...)))
    )
  )

(define (git-prompt p)
  (display p)
  (flush-output)
  (read-line))

(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)))))


(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*)))
    )
  )

(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)
        (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))
        (git-error 'status "Exitcode <> 0" (cons (format "~a\n" exit-code) output))
        ))
  )


(def-cmd git-add cmd-git-add 'add)

(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
      ((= exit-code 1) (git-displ out) #t)
      (else 
       (std-process-git-result cmd exit-code result output out info))))
  )

(def-cmd git-push cmd-git-push 'push add-porcelain)
(def-cmd git-pull cmd-git-pull 'pull)
(def-cmd git-branch cmd-git-branch 'branch)
(def-cmd git-clone cmd-git-clone 'clone)
(def-cmd git-log cmd-git-log 'log)
(def-cmd git-rev-list cmd-git-rev-list 'rev-list)

(define (git-version . args)
  (cmd-git-version args))

(define (cmd-git-version args)
  (info-version "."))

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

(define (git-new-version . args)
  (cmd-git-new-version args))

(define (cmd-git-new-version args)
  (when(null? args)
      (error "git-new-version expects 'maj, 'major, 'min, 'minor or 'patch"))
  (let ((kind (car args)))
    (git-next-version kind ".")
    (git-version)))

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

(def-cmd git-diff cmd-git-diff 'diff
  (λ (args info) args)
  (λ (cmd exit-code result output out info)
    (if (and (zero? exit-code)
             result)
        (let ((diff (string-join 
                     (filter (λ (line)
                               (not (string-prefix? (string-downcase line) "warning:")))
                             out)
                     "\n")))
          (diff->html diff)
          #t)
        #f)))

(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 (eq? 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))))
  )

(def-cmd git-help cmd-git-help 'help)