Editors and Mergetools with drracket
This commit is contained in:
@@ -0,0 +1,177 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/path
|
||||
"config.rkt")
|
||||
|
||||
(provide find-editor
|
||||
configured-editor
|
||||
set-editor!)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Quote an executable path for use as a Git editor command.
|
||||
; pre : p is a path to an executable.
|
||||
; post : p has only been converted to a string.
|
||||
; result : A quoted command path.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (quote-command-path p)
|
||||
(format "\"~a\"" (path->string p)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return an existing executable from a list of candidate paths.
|
||||
; pre : candidates contains paths or #f values.
|
||||
; post : The filesystem has only been inspected.
|
||||
; result : The first existing path, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (first-existing candidates)
|
||||
(cond
|
||||
((null? candidates) #f)
|
||||
((and (car candidates)
|
||||
(file-exists? (car candidates)))
|
||||
(car candidates))
|
||||
(else
|
||||
(first-existing (cdr candidates)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Build a path below an environment variable when it is defined.
|
||||
; pre : variable is an environment variable name.
|
||||
; post : The environment has only been inspected.
|
||||
; result : The constructed path, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (environment-path variable . parts)
|
||||
(let ((base (getenv variable)))
|
||||
(if base
|
||||
(apply build-path base parts)
|
||||
#f)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find an editor executable on PATH and append its wait arguments.
|
||||
; pre : executable is a pathless executable name.
|
||||
; post : PATH has only been inspected.
|
||||
; result : An editor command string, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (editor-on-path executable arguments)
|
||||
(let ((p (find-executable-path executable)))
|
||||
(if p
|
||||
(string-append (quote-command-path p) arguments)
|
||||
#f)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Make an editor command from an existing well-known path.
|
||||
; pre : p is a path or #f; arguments contains the editor wait arguments.
|
||||
; post : p has only been inspected.
|
||||
; result : An editor command string, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (editor-at p arguments)
|
||||
(if (and p (file-exists? p))
|
||||
(string-append (quote-command-path p) arguments)
|
||||
#f))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find a well-known GUI editor on Windows.
|
||||
; pre : The current platform is Windows.
|
||||
; post : PATH and standard Windows installation locations were inspected.
|
||||
; result : A Git editor command string, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-windows-editor)
|
||||
(or (editor-on-path "code.cmd" " --wait")
|
||||
(editor-on-path "code.exe" " --wait")
|
||||
(editor-at
|
||||
(first-existing
|
||||
(list
|
||||
(environment-path "LOCALAPPDATA" "Programs" "Microsoft VS Code" "bin" "code.cmd")
|
||||
(environment-path "ProgramFiles" "Microsoft VS Code" "bin" "code.cmd")
|
||||
(environment-path "ProgramFiles(x86)" "Microsoft VS Code" "bin" "code.cmd")))
|
||||
" --wait")
|
||||
(editor-at
|
||||
(first-existing
|
||||
(list
|
||||
(environment-path "LOCALAPPDATA" "Programs" "Microsoft VS Code" "Code.exe")
|
||||
(environment-path "ProgramFiles" "Microsoft VS Code" "Code.exe")
|
||||
(environment-path "ProgramFiles(x86)" "Microsoft VS Code" "Code.exe")))
|
||||
" --wait")
|
||||
(editor-on-path "notepad.exe" "")
|
||||
(editor-at
|
||||
(environment-path "SystemRoot" "System32" "notepad.exe")
|
||||
"")
|
||||
#f))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find a well-known GUI editor on macOS.
|
||||
; pre : The current platform is macOS.
|
||||
; post : PATH and standard application locations were inspected.
|
||||
; result : A Git editor command string, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-macos-editor)
|
||||
(or (editor-on-path "code" " --wait")
|
||||
(editor-at
|
||||
(string->path
|
||||
"/Applications/Visual Studio Code.app/Contents/Resources/app/bin/code")
|
||||
" --wait")
|
||||
(let ((open
|
||||
(or (find-executable-path "open")
|
||||
(let ((p (string->path "/usr/bin/open")))
|
||||
(if (file-exists? p) p #f)))))
|
||||
(if open
|
||||
(format "~a -W -a TextEdit" (quote-command-path open))
|
||||
#f))
|
||||
#f))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find a well-known GUI editor on Unix/Linux.
|
||||
; pre : The current platform is Unix.
|
||||
; post : PATH and common Linux installation locations were inspected.
|
||||
; result : A Git editor command string, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-unix-editor)
|
||||
(or (editor-on-path "code" " --wait")
|
||||
(editor-on-path "kate" " --block")
|
||||
(editor-on-path "gedit" " --wait")
|
||||
(editor-on-path "xed" " --wait")
|
||||
(editor-at (string->path "/snap/bin/code") " --wait")
|
||||
(editor-at (string->path "/usr/local/bin/code") " --wait")
|
||||
(editor-at (string->path "/usr/bin/code") " --wait")
|
||||
(editor-at (string->path "/usr/local/bin/kate") " --block")
|
||||
(editor-at (string->path "/usr/bin/kate") " --block")
|
||||
(editor-at (string->path "/usr/bin/gedit") " --wait")
|
||||
(editor-at (string->path "/usr/bin/xed") " --wait")
|
||||
#f))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provided functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Read the editor explicitly configured for git-cli.
|
||||
; pre : The git-cli configuration is readable.
|
||||
; post : The configuration has not been changed.
|
||||
; result : The configured editor command, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (configured-editor)
|
||||
(cfg-get 'git 'editor #f))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Store the editor command used by git-cli.
|
||||
; pre : command is a command string suitable for GIT_EDITOR.
|
||||
; post : The command has been stored in the git-cli configuration.
|
||||
; result : The result returned by the configuration layer.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (set-editor! command)
|
||||
(cfg-set! 'git 'editor command))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find the GUI editor that git-cli should offer to Git.
|
||||
; pre : The platform and git-cli configuration are available.
|
||||
; post : No editor has been started.
|
||||
; result : A configured or well-known GUI editor command, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-editor)
|
||||
(or (configured-editor)
|
||||
(case (system-type 'os)
|
||||
((windows) (find-windows-editor))
|
||||
((macosx) (find-macos-editor))
|
||||
((unix) (find-unix-editor))
|
||||
(else #f))))
|
||||
@@ -0,0 +1,201 @@
|
||||
#lang racket/base
|
||||
|
||||
(require racket/path
|
||||
"config.rkt")
|
||||
|
||||
(provide find-mergetool
|
||||
find-mergetool-path
|
||||
configured-mergetool
|
||||
set-mergetool!)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Supporting functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Build a path below an environment variable when it is defined.
|
||||
; pre : variable is an environment variable name.
|
||||
; post : The environment has only been inspected.
|
||||
; result : The constructed path, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (environment-path variable . parts)
|
||||
(let ((base (getenv variable)))
|
||||
(if base
|
||||
(apply build-path base parts)
|
||||
#f)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find one merge tool candidate on PATH or at a well-known path.
|
||||
; pre : candidate contains tool name, executable name and zero or more paths.
|
||||
; post : PATH and the filesystem have only been inspected.
|
||||
; result : A list containing tool name and executable path, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-candidate candidate)
|
||||
(let* ((tool (car candidate))
|
||||
(executable (cadr candidate))
|
||||
(path-executable (find-executable-path executable)))
|
||||
(cond
|
||||
(path-executable
|
||||
(list tool path-executable))
|
||||
(else
|
||||
(let loop ((paths (cddr candidate)))
|
||||
(cond
|
||||
((null? paths) #f)
|
||||
((and (car paths)
|
||||
(file-exists? (car paths)))
|
||||
(list tool (car paths)))
|
||||
(else
|
||||
(loop (cdr paths)))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find the first usable merge tool candidate.
|
||||
; pre : candidates contains merge tool candidate descriptions.
|
||||
; post : PATH and the filesystem have only been inspected.
|
||||
; result : A list containing tool name and executable path, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-candidates candidates)
|
||||
(cond
|
||||
((null? candidates) #f)
|
||||
(else
|
||||
(let ((candidate (find-candidate (car candidates))))
|
||||
(if candidate
|
||||
candidate
|
||||
(find-candidates (cdr candidates)))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return well-known graphical merge tool candidates for Windows.
|
||||
; pre : Windows environment variables may or may not be defined.
|
||||
; post : The environment has only been inspected.
|
||||
; result : Merge tool candidate descriptions in preference order.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (windows-mergetool-candidates)
|
||||
(list
|
||||
(list "winmerge" "WinMergeU.exe"
|
||||
(environment-path "ProgramFiles" "WinMerge" "WinMergeU.exe")
|
||||
(environment-path "ProgramFiles(x86)" "WinMerge" "WinMergeU.exe"))
|
||||
(list "vscode" "code.cmd"
|
||||
(environment-path "LOCALAPPDATA" "Programs" "Microsoft VS Code" "bin" "code.cmd")
|
||||
(environment-path "ProgramFiles" "Microsoft VS Code" "bin" "code.cmd")
|
||||
(environment-path "ProgramFiles(x86)" "Microsoft VS Code" "bin" "code.cmd"))
|
||||
(list "vscode" "code.exe"
|
||||
(environment-path "LOCALAPPDATA" "Programs" "Microsoft VS Code" "Code.exe")
|
||||
(environment-path "ProgramFiles" "Microsoft VS Code" "Code.exe")
|
||||
(environment-path "ProgramFiles(x86)" "Microsoft VS Code" "Code.exe"))
|
||||
(list "kdiff3" "kdiff3.exe"
|
||||
(environment-path "ProgramFiles" "KDiff3" "kdiff3.exe")
|
||||
(environment-path "ProgramFiles(x86)" "KDiff3" "kdiff3.exe"))
|
||||
(list "meld" "meld.exe"
|
||||
(environment-path "LOCALAPPDATA" "Programs" "Meld" "Meld.exe")
|
||||
(environment-path "ProgramFiles" "Meld" "Meld.exe")
|
||||
(environment-path "ProgramFiles(x86)" "Meld" "Meld.exe"))
|
||||
(list "tortoisemerge" "TortoiseMerge.exe"
|
||||
(environment-path "ProgramFiles" "TortoiseSVN" "bin" "TortoiseMerge.exe")
|
||||
(environment-path "ProgramFiles(x86)" "TortoiseSVN" "bin" "TortoiseMerge.exe"))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return well-known graphical merge tool candidates for macOS.
|
||||
; pre : The current platform is macOS.
|
||||
; post : No program has been started.
|
||||
; result : Merge tool candidate descriptions in preference order.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (macos-mergetool-candidates)
|
||||
(list
|
||||
(list "opendiff" "opendiff"
|
||||
(string->path "/usr/bin/opendiff"))
|
||||
(list "vscode" "code"
|
||||
(string->path
|
||||
"/Applications/Visual Studio Code.app/Contents/Resources/app/bin/code"))
|
||||
(list "kdiff3" "kdiff3"
|
||||
(string->path "/Applications/kdiff3.app/Contents/MacOS/kdiff3"))
|
||||
(list "meld" "meld")))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return well-known graphical merge tool candidates for Unix/Linux.
|
||||
; pre : The current platform is Unix.
|
||||
; post : No program has been started.
|
||||
; result : Merge tool candidate descriptions in preference order.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (unix-mergetool-candidates)
|
||||
(list
|
||||
(list "meld" "meld"
|
||||
(string->path "/usr/bin/meld")
|
||||
(string->path "/usr/local/bin/meld"))
|
||||
(list "kdiff3" "kdiff3"
|
||||
(string->path "/usr/bin/kdiff3")
|
||||
(string->path "/usr/local/bin/kdiff3"))
|
||||
(list "vscode" "code"
|
||||
(string->path "/snap/bin/code")
|
||||
(string->path "/usr/bin/code")
|
||||
(string->path "/usr/local/bin/code"))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Return merge tool candidates for the current platform.
|
||||
; pre : The current platform is supported by Racket.
|
||||
; post : No program has been started.
|
||||
; result : Merge tool candidate descriptions.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (mergetool-candidates)
|
||||
(case (system-type 'os)
|
||||
((windows) (windows-mergetool-candidates))
|
||||
((macosx) (macos-mergetool-candidates))
|
||||
((unix) (unix-mergetool-candidates))
|
||||
(else '())))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find the automatically detected merge tool and executable path.
|
||||
; pre : Platform paths are accessible.
|
||||
; post : No merge tool has been started.
|
||||
; result : A list containing tool name and path, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (detected-mergetool)
|
||||
(find-candidates (mergetool-candidates)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Provided functions
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Read the merge tool explicitly configured for git-cli.
|
||||
; pre : The git-cli configuration is readable.
|
||||
; post : The configuration has not been changed.
|
||||
; result : The configured Git merge tool name, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (configured-mergetool)
|
||||
(cfg-get 'git 'mergetool #f))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Store the Git merge tool name used by git-cli.
|
||||
; pre : tool is a Git mergetool name such as "winmerge" or "meld".
|
||||
; post : The tool name has been stored in the git-cli configuration.
|
||||
; result : The result returned by the configuration layer.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (set-mergetool! tool)
|
||||
(cfg-set! 'git 'mergetool tool))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find the graphical merge tool that git-cli should prefer.
|
||||
; pre : The platform and git-cli configuration are available.
|
||||
; post : No merge tool has been started.
|
||||
; result : A configured or detected Git merge tool name, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-mergetool)
|
||||
(or (configured-mergetool)
|
||||
(let ((detected (detected-mergetool)))
|
||||
(if detected
|
||||
(car detected)
|
||||
#f))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
; goal : Find the executable path belonging to the automatically detected merge tool.
|
||||
; pre : Platform paths are accessible.
|
||||
; post : No merge tool has been started.
|
||||
; result : The executable path, or #f.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define (find-mergetool-path)
|
||||
(let ((configured (configured-mergetool))
|
||||
(detected (detected-mergetool)))
|
||||
(if configured
|
||||
#f
|
||||
(if detected
|
||||
(cadr detected)
|
||||
#f))))
|
||||
+68
-38
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user