85 lines
2.4 KiB
Racket
85 lines
2.4 KiB
Racket
#lang racket/base
|
|
|
|
(require "git-provider.rkt"
|
|
racket/string
|
|
racket/list
|
|
)
|
|
|
|
(provide def-git-cmd-proxy
|
|
check-git-args
|
|
has-git-arg?
|
|
std-process-git-result
|
|
)
|
|
|
|
|
|
(define (has-git-arg? args opt)
|
|
(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
|
|
(λ (opt)
|
|
(let ((flag (car opt))
|
|
(num-args (cadr opt))
|
|
(err-msg (caddr opt)))
|
|
(letrec ((find (λ (l)
|
|
(if (null? l)
|
|
#f
|
|
(if (eq? (car l) flag)
|
|
(if (>= (length (cdr l)) num-args)
|
|
#t
|
|
#f)
|
|
(find (cdr l)))))))
|
|
(let ((found (find args)))
|
|
(unless found
|
|
(error 'git (format "git ~a: ~a" cmd err-msg))))
|
|
)
|
|
))
|
|
flags)
|
|
args)
|
|
|
|
|
|
(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 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* ((args (flatten args*))
|
|
(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 info))))))
|
|
)
|
|
)
|
|
|
|
|
|
|