168 lines
4.3 KiB
Scheme
168 lines
4.3 KiB
Scheme
(library
|
|
(command-line get-opt)
|
|
(export get-opt)
|
|
(import (chezscheme)
|
|
(fmt fmt)
|
|
(only (srfi s1 lists) concatenate!)
|
|
(srfi s8 receive))
|
|
|
|
;;; FIXME: return an error rather than raising a condition
|
|
(define-record-type option (fields name long-forms short-forms arg?))
|
|
(define-record-type getopt-results (fields switches rest))
|
|
|
|
(define (end-of-switches? str)
|
|
(string=? "--" str))
|
|
|
|
(define (long-opt? str)
|
|
(string=? "--" (substring str 0 2)))
|
|
|
|
(define (short-opt? str)
|
|
(and (eq? (string-ref str 0) #\-)
|
|
(> (string-length str) 1)))
|
|
|
|
(define (for-each-form fn opts form-fn)
|
|
(for-each
|
|
(lambda (opt)
|
|
(for-each
|
|
(lambda (elt) (fn opt elt))
|
|
(form-fn opt)))
|
|
opts))
|
|
|
|
(define (build-short-opt-hash opts)
|
|
(let ((ht (make-eq-hashtable)))
|
|
(for-each-form
|
|
(lambda (opt c)
|
|
(hashtable-set! ht c opt))
|
|
opts
|
|
option-short-forms)
|
|
ht))
|
|
|
|
(define (build-long-opt-hash opts)
|
|
(let ((ht (make-hashtable string-hash string=?)))
|
|
(for-each-form
|
|
(lambda (opt str)
|
|
(hashtable-set! ht str opt))
|
|
opts
|
|
option-long-forms)
|
|
ht))
|
|
|
|
(define (make-err str)
|
|
(condition
|
|
(make-error)
|
|
(make-message-condition str)))
|
|
|
|
(define (unknown-option arg)
|
|
(make-err (fmt #f "unknown option: " arg)))
|
|
|
|
(define (missing-arg opt)
|
|
(make-err
|
|
(fmt #f "missing argument for option: " opt)))
|
|
|
|
(define (assert-len opt args len)
|
|
(unless (zero? len)
|
|
(when (null? args)
|
|
(raise (missing-arg opt)))))
|
|
|
|
(define opt-ref
|
|
(let ((sym (gensym)))
|
|
(lambda (ht key)
|
|
(let ((opt (hashtable-ref ht key sym)))
|
|
(if (eq? opt sym)
|
|
(raise (unknown-option key))
|
|
opt)))))
|
|
|
|
(define (extract-long-form str)
|
|
(substring str 2 (string-length str)))
|
|
|
|
(define (extract-short-form str)
|
|
(string-ref str 1))
|
|
|
|
;; f - returns (values elt new-args)
|
|
;; iteration terminates when args is null?
|
|
(define (unfold-args f args)
|
|
(let loop ((args args)
|
|
(acc '()))
|
|
(if (null? args)
|
|
(reverse acc)
|
|
(receive (elt new-args) (f args)
|
|
(loop new-args (cons elt acc))))))
|
|
|
|
;; It's easier if multiple short flags such as '-vft' are expanded to single
|
|
;; switches.
|
|
(define (expand-short-forms args)
|
|
(define (expand args)
|
|
(let ((arg (car args)))
|
|
(cond
|
|
((long-opt? arg)
|
|
(values (list arg) (cdr args)))
|
|
|
|
((short-opt? arg)
|
|
(values (map (lambda (c)
|
|
(fmt #f "-" c))
|
|
(cdr (string->list arg)))
|
|
(cdr args)))
|
|
|
|
(else
|
|
(values (list arg) (cdr args))))))
|
|
|
|
(concatenate!
|
|
(unfold-args expand args)))
|
|
|
|
;; Returns a list of elts of the form:
|
|
;; ('switch <opt>)
|
|
;; ('arg-switch <opt> <arg>)
|
|
;; ('positional <arg>)
|
|
|
|
(define (process-all-opts short-ht long-ht opts)
|
|
(define (match-opt opt args)
|
|
(if (option-arg? opt)
|
|
(begin
|
|
(assert-len opt args 2)
|
|
(values `((arg-switch ,opt ,(cadr args)))
|
|
(cddr args)))
|
|
(values `((switch ,opt))
|
|
(cdr args))))
|
|
|
|
(define (process-one-opt args)
|
|
;; We know args contains at least one entry
|
|
(let ((arg (car args)))
|
|
(cond
|
|
((end-of-switches? arg)
|
|
(values (map (lambda (a)
|
|
`(positional ,a))
|
|
(cdr args))
|
|
'()))
|
|
|
|
((long-opt? arg)
|
|
(let ((opt (opt-ref long-ht (extract-long-form arg))))
|
|
(match-opt opt args)))
|
|
|
|
((short-opt? arg)
|
|
(let ((opt (opt-ref short-ht (extract-short-form arg))))
|
|
(match-opt opt args)))
|
|
|
|
(else
|
|
(values `((positional ,arg))
|
|
(cdr args))))))
|
|
|
|
(concatenate!
|
|
(unfold-args process-one-opt opts)))
|
|
|
|
(define (build-results opts)
|
|
(let ((ht (make-eq-hashtable))
|
|
(positional '()))
|
|
(for-each (lambda (opt)
|
|
(case (car opt)
|
|
((switch) (hashtable-set! ht (cadr opt) #t))
|
|
((arg-switch) (hashtable-set! ht (cadr opt) (caddr opt)))
|
|
((positional) (set! positional (cons (cadr opt) positional)))))
|
|
opts)
|
|
(make-getopt-results ht (reverse positional))))
|
|
|
|
(define (get-opt opts)
|
|
(let ((short-ht (build-short-opt-hash opts))
|
|
(long-ht (build-long-opt-hash opts)))
|
|
(lambda (args)
|
|
(build-results
|
|
(process-all-opts short-ht long-ht (expand-short-forms args))))))
|