Added git-grep and git-diff

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)
 

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)
+(define (add-porcelain args info . f)
-  (if (has-git-arg? args '--porcelain)
+  (let ((m (has-git-arg? args #px"^[-][-]porcelain([=](.*))?"))
-      (if (null? f) args ((car f) args))
+        (g (if (null? f) (λ (x) x) (car f)))
-      (if (null? f) (cons '--porcelain args)
+        )
-          ((car f) (cons '--porcelain args)))))
+    (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)
+  add-porcelain
-                args
+  (λ (cmd exit-code result output out info)
-                (cons '-s args)))
+    (dbg-git (format "~a" output))
-  (λ (cmd exit-code result output out)
     (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)
+
+

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

private/git-commands.rkt

@@ -12,19 +12,20 @@
 
 
 (define (has-git-arg? args opt)
-  (if (list? args)
+  (let ((cmp (cond ((symbol? opt) (λ (x) (eq? x opt)))
-      (if (null? args)
+                   ((string? opt) (λ (x) (string=? (format "~a" x) opt)))
-          #f
+                   ((regexp? opt) (λ (x) (regexp-match opt (format "~a" x))))
-          (if (symbol? opt)
+                   (else (error "opt must be a string, symbol or regular expression")))))
-              (if (or (eq? (car args) opt)
+    (letrec ((f (λ (args)
-                      (and (string? (car args))
+                  (if (null? args)
-                           (string=? (car args) (symbol->string opt))))
+                      #f
-                  #t
+                      (let ((m (cmp (car args))))
-                  (has-git-arg? (cdr args) opt))
+                        (if m
-              (error 'has-git-arg? "opt must be of type symbol?")))
+                            m
-      (error 'has-git-arg? "args must be a list of arguments")
+                            (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)
+(define (std-process-git-result cmd exit-code result output out info)
-  (git-displ out)
+  (if (= exit-code 0)
-  (if result
+      (if result
-      (if (= exit-code 0)
+          (begin
-          #t
+            (git-displ out)
-          #f)
+            #t)
-      (git-error cmd "Error" out)))
+          (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))))))
     )
   )
 

private/git-provider.rkt

@@ -80,11 +80,8 @@
                        #f
                        #f
                        (git-exe)
-                       (map (lambda (arg)
+                       (map (λ (arg) (format "~a" arg)) args)
-                              (if (symbol? arg)
+                       )))
-                                  (symbol->string arg)
-                                  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)))))