ikarus/lab/command-line.sls

320 lines
12 KiB
Scheme

;;; WORK IN PROGRESS, NOT FOR CONSUMPTION
;;; TODO: long options
;;; multiple options in one go, e.g., -XYZ
;;; concat value with option, e.g., -Xxvalue
;;; usage error message [ok?]
;;; -h --help should not be user-defined
;;; check duplicate options
(library (command-line)
(export command-line-interface)
(import (rnrs))
(define (dispatch-opts arguments data* proc*)
(define (print p . args)
(for-each (lambda (x) (display x p)) args))
(define (print-usage detailed?)
(define-record-type f (fields id char type def))
(define (mkf x id)
(make-f id (car x) (cadr x) (cddr x)))
(define (get type ls)
(filter (lambda (x) (eq? (f-type x) type)) ls))
(define (fmt-req p)
(lambda (x)
(print p " -" (f-char x) " <" (f-id x) ">")))
(define (fmt-req-no-value p)
(lambda (x)
(display " -" p)
(display (f-char x) p)))
(define (fmt-z p c)
(lambda (x)
(print p " [-" (f-char x) " <" (f-id x) ">]" c)))
(define (fmt-<> p)
(lambda (x)
(display " <" p)
(display x p)
(display ">" p)))
(define (synopsis f* args args-rest)
(let ([opt* (get 'optional f*)]
[flag* (get 'flag f*)]
[req0* (get 'required0 f*)]
[req1* (get 'required1 f*)]
[z0* (get 'zero-plus f*)]
[z1* (get 'one-plus f*)])
(let-values ([(p e) (open-string-output-port)])
(display (car arguments) p)
(for-each (fmt-req-no-value p) req0*)
(unless (null? flag*)
(display " [-" p)
(apply print p (map f-char flag*))
(display "]" p))
(for-each (fmt-z p "") opt*)
(for-each (fmt-z p "*") z0*)
(for-each (fmt-z p "+") z1*)
(for-each (fmt-req p) req1*)
(for-each (fmt-<> p) args)
(when args-rest
((fmt-<> p) args-rest)
(display " ..." p))
(e))))
(define (print-usage-line help fields field-ids args args-rest dash-rest)
(let ([f* (map mkf fields field-ids)])
(display " ")
(display (synopsis f* args args-rest))
(newline)
(unless (string=? help "")
(display " ")
(display help)
(newline))
(when detailed?
(let ([def* (filter f-def (get 'optional f*))])
(unless (null? def*)
(for-each
(lambda (x)
(print (current-output-port)
" -" (f-char x)
" defaults to " (f-def x)
"\n"))
def*)))
(newline))))
(display "\nUsage:\n")
(for-each (lambda (x) (apply print-usage-line x)) data*)
(print-usage-line "Display this help message"
'([#\h required0 . #f])
'(dummy)
'()
#f
#f)
#f)
(define (arguments-match)
(define-condition-type &help &condition
make-help-condition help-condition?
(extended? help-extended?))
(define-condition-type &unmatched &condition
make-unmatched-condition unmatched-condition?)
(define (help x)
(raise (make-help-condition x)))
(define (unmatched)
(raise (make-unmatched-condition)))
(define (option? x)
(or (equal? x "--help") ;;; hack
(and (string? x)
(>= (string-length x) 2)
(char=? (string-ref x 0) #\-)
(not (char=? (string-ref x 1) #\-)))))
;;;
(define (fill-char-opt c ls fields)
;;; field = [c required0 . _] ; requires 0 args
;;; | [c required1 . _] ; requires 1 arg
;;; | [c flag . default] ; toggles default to #t
;;; | [c zero-plus . reversed-list]
;;; | [c one-plus . reversed-list]
;;; | [c optional . default] ; overridden by value
;;; | [c ok . value] ; already used, not on input
(let f ([fields fields])
(when (null? fields) (unmatched))
(let ([field (car fields)])
(if (char=? c (car field))
(let ([t (cadr field)])
(case t
[(required1 optional)
(when (null? ls) (unmatched))
(let ([val (car ls)] [ls (cdr ls)])
(values (cons (cons* c 'ok val) (cdr fields)) ls))]
[(flag)
(values (cons (cons* c 'ok #t) (cdr fields)) ls)]
[(zero-plus one-plus)
(when (null? ls) (unmatched))
(let ([val (car ls)])
(values
(cons (cons* c 'zero-plus (cons val (cddr field)))
(cdr fields))
(cdr ls)))]
[else (unmatched)]))
(let-values ([(fields ls) (f (cdr fields))])
(values (cons field fields) ls))))))
;;;
(define (fill-option a ls fields)
(when (string=? a "--help") (help #t))
(if (= (string-length a) 2)
(let ([char (string-ref a 1)])
(when (char=? char #\h) (help #f))
(fill-char-opt char ls fields))
(error 'fill-option "not yet")))
;;;
(define (match-fields fields ls)
(if (null? ls)
(values fields ls)
(let ([a (car ls)])
(if (option? a)
(let-values ([(fields ls) (fill-option a (cdr ls) fields)])
(match-fields fields ls))
(values fields ls)))))
;;;
(define (match-args args ls)
(cond
[(null? args) (values '() ls)]
[(null? ls) (unmatched)]
[else
(let ([a (car ls)])
(when (option? a) (unmatched))
(let-values ([(a* ls) (match-args (cdr args) (cdr ls))])
(values (cons a a*) ls)))]))
;;;
(define (match-args-rest a/f ls)
(if a/f
(let-values ([(x ls)
(let f ([ls ls])
(if (null? ls)
(values '() ls)
(let ([a (car ls)])
(if (string=? a "--")
(values '() ls)
(if (option? a)
(unmatched)
(let-values ([(a* ls) (f (cdr ls))])
(values (cons a a*) ls)))))))])
(values (list x) ls))
(if (or (null? ls) (string=? (car ls) "--"))
(values '() ls)
(unmatched))))
;;;
(define (match-dash-rest a/f ls)
(if a/f
(if (null? ls)
'(())
(if (string=? (car ls) "--")
(list (cdr ls))
(unmatched)))
(if (null? ls) '() (unmatched))))
;;;
(define (fix-field x)
(let ([type (cadr x)] [value (cddr x)])
(case type
[(ok flag optional) value]
[(zero-plus) (reverse value)]
[else (unmatched)])))
;;;
(define (match _help fields _field-ids args args-rest dash-rest)
(cons (car arguments)
(let*-values ([(fields ls) (match-fields fields (cdr arguments))]
[(fields) (map fix-field fields)]
[(args ls) (match-args args ls)]
[(args-rest ls) (match-args-rest args-rest ls)]
[(dash-rest) (match-dash-rest dash-rest ls)])
(append fields args args-rest dash-rest))))
;;;
(guard (con
[(help-condition? con)
(print-usage (help-extended? con))])
(let f ([data* data*] [proc* proc*])
(if (null? data*)
(help #f)
(guard (con
[(unmatched-condition? con)
(f (cdr data*) (cdr proc*))])
(apply (car proc*) (apply match (car data*))))))))
(arguments-match))
(define-syntax command-line-interface
(lambda (stx)
(define (parse-format stx)
(define (err str x)
(syntax-violation #f str stx x))
(define (prep-str stx)
(let* ([str (syntax->datum stx)]
[n (string-length str)]
[err (lambda (why) (err why stx))])
(when (< n 2) (err "invalid option string"))
(unless (char=? (string-ref str 0) #\-)
(err "option string must start with a dash: -"))
(cons (string-ref str 1)
(cond
[(= n 2) #'(required1)]
[else
(case (string-ref str 2)
[(#\?) #'(flag . #f)]
[(#\*) #'(zero-plus . ())]
[(#\+) #'(one-plus . ())]
[(#\=)
(cons #'optional (substring str 3 n))]
[else (err "invalid option")])]))))
(define (dots? x)
(and (identifier? x)
(free-identifier=? x #'(... ...))))
(define (id? x)
(and (identifier? x) (not (dots? x))))
;;;
(define (command-line-interface ls)
(define (str? x)
(let ([d (syntax->datum x)])
(and (string? d) (not (string=? d "--")))))
(define (parse-head x)
(syntax-case x ()
[(prog . rest)
(if (id? #'prog)
(values #'prog #'rest)
(err "pattern head is not an identifier" #'prog))]
[_ (err "invalid pattern" x)]))
(define (parse-opts x)
(syntax-case x ()
[(str id . rest)
(and (id? #'id) (str? #'str))
(let-values ([(opt-strs opt-ids rest) (parse-opts #'rest)])
(values (cons (prep-str #'str) opt-strs)
(cons #'id opt-ids) rest))]
[_ (values '() '() x)]))
(define (parse-args x)
(syntax-case x ()
[(id dots . rest)
(and (id? #'id) (dots? #'dots))
(values '() #'id #'rest)]
[(id . rest) (id? #'id)
(let-values ([(args args-rest rest) (parse-args #'rest)])
(values (cons #'id args) args-rest rest))]
[_ (values '() #f x)]))
(define (parse-tail x)
(syntax-case x ()
[("--" id) (id? #'id) #'id]
[() #f]
[_ (err "invalid pattern segment" x)]))
(let-values ([(prog ls) (parse-head ls)])
(let-values ([(opts opt-ids ls) (parse-opts ls)])
(let-values ([(args args-rest ls) (parse-args ls)])
(values prog opts opt-ids args args-rest (parse-tail ls))))))
(define (get-fmls x ls1 ls2 m1 m2)
(define (cons? x ls) (if x (cons x ls) ls))
(define (bound-id-member? x ls)
(and (pair? ls)
(or (bound-identifier=? x (car ls))
(bound-id-member? x (cdr ls)))))
(let ([ls (cons x (append ls1 ls2 (cons? m1 (cons? m2 '()))))])
(let f ([x (car ls)] [ls (cdr ls)])
(unless (null? ls)
(if (bound-id-member? x ls)
(err "duplicate identifier" x)
(f (car ls) (cdr ls)))))
ls))
(let-values ([(prog opt-strs opt-ids args args-rest dash-rest)
(command-line-interface stx)])
(list (get-fmls prog opt-ids args args-rest dash-rest)
opt-strs opt-ids args args-rest dash-rest)))
(define (parse-clause stx)
(syntax-case stx ()
[(format help-str body body* ...)
(string? (syntax->datum #'help-str))
(with-syntax ([((fmls ...) . args)
(parse-format #'format)])
(list #'(lambda (fmls ...) body body* ...)
#'(help-str . args)))]
[(format body body* ...)
(parse-clause #'(format "" body body* ...))]))
(syntax-case stx ()
[(_ expr clause* ...)
(with-syntax ([((proc* data*) ...)
(map parse-clause #'(clause* ...))])
#'(dispatch-opts expr '(data* ...) (list proc* ...)))])))
)