Added git-grep and git-diff
This commit is contained in:
@@ -2,7 +2,7 @@
|
||||
|
||||
(define collection "git-cli")
|
||||
(define pkg-desc "Command-line-like Git operations for Racket, interface to the git cli command")
|
||||
(define version "0.3.6")
|
||||
(define version "0.3.7")
|
||||
(define pkg-authors '("Hans Dijkema"))
|
||||
(define license 'MIT)
|
||||
|
||||
|
||||
@@ -3,8 +3,10 @@
|
||||
(require "private/git-provider.rkt"
|
||||
"private/git-commands.rkt"
|
||||
"private/config.rkt"
|
||||
"private/diff.rkt"
|
||||
simple-log
|
||||
racket/string
|
||||
net/sendurl
|
||||
)
|
||||
|
||||
(provide git
|
||||
@@ -31,16 +33,18 @@
|
||||
)
|
||||
)
|
||||
|
||||
(define (add-porcelain args . f)
|
||||
(if (has-git-arg? args '--porcelain)
|
||||
(if (null? f) args ((car f) args))
|
||||
(if (null? f) (cons '--porcelain args)
|
||||
((car f) (cons '--porcelain args)))))
|
||||
(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=v1 args)))))
|
||||
|
||||
(define-syntax def-cmd
|
||||
(syntax-rules ()
|
||||
((_ cmd cmd* cmd-sym)
|
||||
(def-cmd cmd cmd* cmd-sym (λ (args) args) std-process-git-result))
|
||||
(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)
|
||||
@@ -54,10 +58,9 @@
|
||||
)
|
||||
|
||||
(def-cmd git-status cmd-git-status 'status
|
||||
(λ (args) (if (has-git-arg? args '-s)
|
||||
args
|
||||
(cons '-s args)))
|
||||
(λ (cmd exit-code result output out)
|
||||
add-porcelain
|
||||
(λ (cmd exit-code result output out info)
|
||||
(dbg-git (format "~a" output))
|
||||
(if (= exit-code 0)
|
||||
(if result
|
||||
(map (λ (line)
|
||||
@@ -84,9 +87,84 @@
|
||||
|
||||
|
||||
(def-cmd git-add cmd-git-add 'add)
|
||||
|
||||
(def-cmd git-commit cmd-git-commit 'commit
|
||||
(λ (args) (check-git-args 'commit args '((-m 1 "A commit message is mandatory"))))
|
||||
(λ (cmd exit-code result output out)
|
||||
(cond
|
||||
((= exit-code 1) (git-displ out) #t)
|
||||
(std-process-git-result cmd exit-code result output out)))
|
||||
)
|
||||
|
||||
(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)
|
||||
|
||||
(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)
|
||||
|
||||
|
||||
|
||||
@@ -0,0 +1,55 @@
|
||||
#lang racket/base
|
||||
|
||||
(require net/sendurl
|
||||
json
|
||||
xml
|
||||
racket/string
|
||||
)
|
||||
|
||||
(provide diff->html)
|
||||
|
||||
(define (make-js . args)
|
||||
(string-join args "\n"))
|
||||
|
||||
(define (diff->html diff)
|
||||
(let ((highlight-css "https://cdnjs.cloudflare.com/ajax/libs/highlight.js/11.8.0/styles/github.min.css")
|
||||
(diff2html-min-css "https://cdn.jsdelivr.net/npm/diff2html/bundles/css/diff2html.min.css")
|
||||
(diff2html-ui-min-js "https://cdn.jsdelivr.net/npm/diff2html/bundles/js/diff2html-ui.min.js"))
|
||||
(let ((html `(html
|
||||
(head
|
||||
(meta ((charset "utf-8")))
|
||||
(link ((rel "stylesheet") (href ,highlight-css)))
|
||||
(link ((rel "stylesheet") (href ,diff2html-min-css)))
|
||||
(script ((src ,diff2html-ui-min-js)) "")
|
||||
(script ,(format
|
||||
(make-js
|
||||
"window.do_diff = function() {"
|
||||
"const diff = ~a;"
|
||||
"const ui = new Diff2HtmlUI("
|
||||
" document.getElementById('diff'),"
|
||||
" diff,"
|
||||
" {"
|
||||
" drawFileList: true,"
|
||||
" matching: 'lines',"
|
||||
" outputFormat: 'side-by-side',"
|
||||
" });"
|
||||
"ui.draw();"
|
||||
"ui.highlightCode();"
|
||||
"};"
|
||||
)
|
||||
(jsexpr->string diff))
|
||||
)
|
||||
)
|
||||
(body
|
||||
(div ((id "diff")))
|
||||
(script ((type "text/javascript"))
|
||||
"window.do_diff();")
|
||||
))))
|
||||
(let ((tmp-file (build-path (find-system-path 'temp-dir) "racket-git-diff.html")))
|
||||
(call-with-output-file tmp-file #:exists 'truncate
|
||||
(λ (out)
|
||||
(display (xexpr->string html) out)))
|
||||
(send-url/file tmp-file)))))
|
||||
|
||||
|
||||
|
||||
+26
-20
@@ -12,19 +12,20 @@
|
||||
|
||||
|
||||
(define (has-git-arg? args opt)
|
||||
(if (list? args)
|
||||
(let ((cmp (cond ((symbol? opt) (λ (x) (eq? x opt)))
|
||||
((string? opt) (λ (x) (string=? (format "~a" x) opt)))
|
||||
((regexp? opt) (λ (x) (regexp-match opt (format "~a" x))))
|
||||
(else (error "opt must be a string, symbol or regular expression")))))
|
||||
(letrec ((f (λ (args)
|
||||
(if (null? args)
|
||||
#f
|
||||
(if (symbol? opt)
|
||||
(if (or (eq? (car args) opt)
|
||||
(and (string? (car args))
|
||||
(string=? (car args) (symbol->string opt))))
|
||||
#t
|
||||
(has-git-arg? (cdr args) opt))
|
||||
(error 'has-git-arg? "opt must be of type symbol?")))
|
||||
(error 'has-git-arg? "args must be a list of arguments")
|
||||
)
|
||||
)
|
||||
(let ((m (cmp (car args))))
|
||||
(if m
|
||||
m
|
||||
(f (cdr args))))))))
|
||||
(if (list? args)
|
||||
(f args)
|
||||
(error 'has-git-arg? "args must be a list of arguments")))))
|
||||
|
||||
(define (check-git-args cmd args flags)
|
||||
(for-each
|
||||
@@ -49,26 +50,31 @@
|
||||
args)
|
||||
|
||||
|
||||
(define (std-process-git-result cmd exit-code result output out)
|
||||
(git-displ out)
|
||||
(if result
|
||||
(define (std-process-git-result cmd exit-code result output out info)
|
||||
(if (= exit-code 0)
|
||||
#t
|
||||
#f)
|
||||
(git-error cmd "Error" out)))
|
||||
(if result
|
||||
(begin
|
||||
(git-displ out)
|
||||
#t)
|
||||
(git-error cmd "Error" out))
|
||||
(git-error cmd (format "Exitcode <> 0: ~a" exit-code) out)
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
(define-syntax def-git-cmd-proxy
|
||||
(syntax-rules ()
|
||||
((_ f cmd)
|
||||
(def-proxy-cmd f cmd (λ args t) standard-result))
|
||||
(def-proxy-cmd f cmd (λ (args info) args) standard-result))
|
||||
((_ f cmd pre-code)
|
||||
(def-proxy-cmd f cmd pre-code standard-result))
|
||||
((_ f cmd pre-code process-result)
|
||||
(define (f args)
|
||||
(let ((nargs (pre-code args)))
|
||||
(let* ((info (make-hash))
|
||||
(nargs (pre-code args info)))
|
||||
(let-values (((exit-code output) (run-git (cons cmd nargs))))
|
||||
(let-values (((result out) (git-out cmd output)))
|
||||
(process-result cmd exit-code result output out))))))
|
||||
(process-result cmd exit-code result output out info))))))
|
||||
)
|
||||
)
|
||||
|
||||
|
||||
@@ -80,11 +80,8 @@
|
||||
#f
|
||||
#f
|
||||
(git-exe)
|
||||
(map (lambda (arg)
|
||||
(if (symbol? arg)
|
||||
(symbol->string arg)
|
||||
arg))
|
||||
args))))
|
||||
(map (λ (arg) (format "~a" arg)) args)
|
||||
)))
|
||||
(close-output-port stdin)
|
||||
(let ((output-channel (make-channel)))
|
||||
(define (read-output source port)
|
||||
@@ -154,9 +151,12 @@
|
||||
)
|
||||
)
|
||||
|
||||
(define re-a #px"~+")
|
||||
|
||||
(define (git-displ out)
|
||||
(let ((str (if (string? out) out (string-join out "\n"))))
|
||||
(unless (string=? (string-trim str) "")
|
||||
(info-git str)
|
||||
(let ((s (regexp-replace* re-a str "~~")))
|
||||
(info-git s))
|
||||
(when (cfg-get 'git 'display-output #t)
|
||||
(displayln str)))))
|
||||
|
||||
Reference in New Issue
Block a user