Editors and Mergetools with drracket

2026-08-14 11:30:56 +02:00
parent 7d8a5cd599
commit e33ffb906a
7 changed files with 578 additions and 63 deletions
@@ -5,6 +5,8 @@
         racket/contract
         racket/system
         "config.rkt"
+         "find-editor.rkt"
+         "find-mergetool.rkt"
         )

 (provide git-exe
@@ -95,46 +97,74 @@
 ; result : The exit code and ordered (source line) output items.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 (define (run-git args #:input (input #f))
-  (putenv "GIT_TERMINAL_PROMPT" "0")
-  (let-values (((process stdout stdin stderr)
-                (apply subprocess
-                       #f
-                       #f
-                       #f
-                       (git-exe)
-                       (map (λ (arg) (format "~a" arg)) args)
-                       )))
-    (when input
-      (display input stdin)
-      (flush-output stdin))
-    (close-output-port stdin)
-    (let ((output-channel (make-channel)))
-        (define (read-output source port)
-          (thread
-           (lambda ()
-             (let loop ()
-               (let ((line (read-line port)))
-                 (channel-put output-channel (list source line))
-                 (if (eof-object? line)
-                     (close-input-port port)
-                     (loop)))))))
+  (let* ((env (environment-variables-copy
+               (current-environment-variables)))
+         (editor (find-editor))
+         (mergetool-path (find-mergetool-path)))
+    (environment-variables-set! env
+                                #"GIT_TERMINAL_PROMPT"
+                                #"0")
+    (when editor
+      (let ((editor-bytes (string->bytes/utf-8 editor)))
+        (environment-variables-set! env
+                                    #"GIT_EDITOR"
+                                    editor-bytes)
+        (environment-variables-set! env
+                                    #"GIT_SEQUENCE_EDITOR"
+                                    editor-bytes)))
+    (when mergetool-path
+      (let* ((directory (path-only mergetool-path))
+             (old-path (environment-variables-ref env #"PATH"))
+             (separator (if (eq? (system-type 'os) 'windows) ";" ":"))
+             (new-path
+              (if old-path
+                  (string-append (path->string directory)
+                                 separator
+                                 (bytes->string/utf-8 old-path))
+                  (path->string directory))))
+        (environment-variables-set! env
+                                    #"PATH"
+                                    (string->bytes/utf-8 new-path))))
+    (parameterize ((current-environment-variables env))
+      (let-values (((process stdout stdin stderr)
+                    (apply subprocess
+                           #f
+                           #f
+                           #f
+                           (git-exe)
+                           (map (λ (arg) (format "~a" arg)) args)
+                           )))
+        (when input
+          (display input stdin)
+          (flush-output stdin))
+        (close-output-port stdin)
+        (let ((output-channel (make-channel)))
+          (define (read-output source port)
+            (thread
+             (λ ()
+               (let loop ()
+                 (let ((line (read-line port)))
+                   (channel-put output-channel (list source line))
+                   (if (eof-object? line)
+                       (close-input-port port)
+                       (loop)))))))

-        (read-output 'stdout stdout)
-        (read-output 'stderr stderr)
+          (read-output 'stdout stdout)
+          (read-output 'stderr stderr)

-        (let loop ((open-ports 2)
-                   (result '()))
-          (if (= open-ports 0)
-              (begin
-                (subprocess-wait process)
-                (values (subprocess-status process)
-                        (reverse result)))
-              (let* ((output (channel-get output-channel))
-                     (line (cadr output)))
-                (if (eof-object? line)
-                    (loop (- open-ports 1) result)
-                    (loop open-ports
-                          (cons output result)))))))))
+          (let loop ((open-ports 2)
+                     (result '()))
+            (if (= open-ports 0)
+                (begin
+                  (subprocess-wait process)
+                  (values (subprocess-status process)
+                          (reverse result)))
+                (let* ((output (channel-get output-channel))
+                       (line (cadr output)))
+                  (if (eof-object? line)
+                      (loop (- open-ports 1) result)
+                      (loop open-ports
+                            (cons output result)))))))))))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Provided utility functions