From aebd420c3cfe5d6993fc2f4e8ce179ec9b3c8b70 Mon Sep 17 00:00:00 2001 From: Hans Dijkema Date: Wed, 12 Aug 2026 22:28:27 +0200 Subject: [PATCH] Added git-grep and git-diff --- info.rkt | 2 +- main.rkt | 98 ++++++++++++++++++++++++++++++++++++---- private/diff.rkt | 55 ++++++++++++++++++++++ private/git-commands.rkt | 52 +++++++++++---------- private/git-provider.rkt | 12 ++--- 5 files changed, 179 insertions(+), 40 deletions(-) create mode 100644 private/diff.rkt diff --git a/info.rkt b/info.rkt index 2af6405..29f6434 100644 --- a/info.rkt +++ b/info.rkt @@ -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) diff --git a/main.rkt b/main.rkt index ea2e4a0..4c3dd59 100644 --- a/main.rkt +++ b/main.rkt @@ -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) + + diff --git a/private/diff.rkt b/private/diff.rkt new file mode 100644 index 0000000..d680a32 --- /dev/null +++ b/private/diff.rkt @@ -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))))) + + + diff --git a/private/git-commands.rkt b/private/git-commands.rkt index 63a5f86..a387183 100644 --- a/private/git-commands.rkt +++ b/private/git-commands.rkt @@ -12,19 +12,20 @@ (define (has-git-arg? args opt) - (if (list? 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 ((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 + (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 - (if (= exit-code 0) - #t - #f) - (git-error cmd "Error" out))) +(define (std-process-git-result cmd exit-code result output out info) + (if (= exit-code 0) + (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)))))) ) ) diff --git a/private/git-provider.rkt b/private/git-provider.rkt index a7ef28a..fde9f9c 100644 --- a/private/git-provider.rkt +++ b/private/git-provider.rkt @@ -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)))))