260 lines
9.1 KiB
Racket
260 lines
9.1 KiB
Racket
#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))
|
|
|
|
|
|
;; 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-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 (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))))
|
|
|
|
(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))
|
|
|
|
|
|
(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*)))
|
|
)
|
|
)
|
|
|
|
;; 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)
|
|
(def-cmd git-branch cmd-git-branch 'branch)
|
|
(def-cmd git-clone cmd-git-clone 'clone)
|
|
|
|
;; goal: Display the Git commit log.
|
|
;; pre: The supplied arguments are valid for git log.
|
|
;; post: Git log has completed successfully or an exception has been raised.
|
|
;; result: #t after successfully displaying the log.
|
|
(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)
|
|
|
|
;; 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))
|
|
|
|
(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)))
|
|
|
|
;; 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 (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)
|
|
|
|
|