Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 8354dd3ab5
Fetching contributors…

Cannot retrieve contributors at this time

executable file 93 lines (86 sloc) 3.618 kb
(module easy-args
((define-arguments process-arguments make-option make-option-parameter)
unmatched-arguments invalid-argument-handler)
(import scheme chicken extras)
(use srfi-13 srfi-37)
;; Return an alist of arguments
;; unhandled by define-arguments.
(define unmatched-arguments (lambda () '()))
;; Handler to be used when an invalid option
;; is encountered. By default, exits the
;; program with a simple error message.
(define invalid-argument-handler
(make-parameter
(lambda (msg k v)
(fprintf (current-error-port)
(format "~a: ~a for option '~a'\n" (program-name) msg k))
(exit 1))))
;; Internal. Creates a parameter
;; for the given value and guard.
(define (make-option-parameter . spec)
(let-optionals spec ((value #f) (guard #f))
(apply make-parameter
value
(if guard
(list guard)
'()))))
;; Internal. Creates a srfi-37 record
;; for the given parameter object,
;; name list & default value.
(define (make-option parameter names . spec)
(let ((r (invalid-argument-handler)))
(let-optionals spec ((value #f) (guard #f))
(option (map (lambda (name)
(if (> (string-length name) 1)
(string-delete #\* name)
(string-ref name 0)))
(map symbol->string names))
(and value) #f
(lambda (o k v rest)
(parameter
(cond ((string? value)
(or v (r "value required" k v)))
((boolean? value)
(or (and (not v) #t)
(r "unexpected value" k v)))
((symbol? value)
(or (and v (string->symbol v))
(r "value required" k v)))
((number? value)
(or (and v (string->number v))
(r "numeric value required" k v)))
(else
(error 'define-arguments
"invalid default value"
k v))))
rest)))))
;; Internal. Process (command-line-arguments)
;; against the given list of options, removing
;; matched arguments and accumulating the rest
;; into the unmatched-arguments procedure.
(define (process-arguments . option-list)
(let ((unmatched '()))
(command-line-arguments
(args-fold
(command-line-arguments)
option-list
(lambda (o k v rest)
(set! unmatched
(cons (cons k (or v #t))
unmatched))
rest)
cons '()))
(let ((lst (reverse unmatched)))
(set! unmatched-arguments
(lambda () lst)))))
(define-syntax define-arguments
(syntax-rules ()
((_ "aux" (((<name> <alias> ...) <value/guard> ...) ...))
(begin (define <name> (make-option-parameter <value/guard> ...)) ...
(void (process-arguments (make-option <name> '(<name> <alias> ...) <value/guard> ...) ...))))
((_ "aux" (acc ...) ((<name> <alias> ...) <value/guard> ...) tail ...)
(define-arguments "aux" (((<name> <alias> ...) <value/guard> ...) acc ...) tail ...))
((_ "aux" (acc ...) (<name> <value/guard> ...) tail ...)
(define-arguments "aux" (((<name>) <value/guard> ...) acc ...) tail ...))
((_ tail ...)
(define-arguments "aux" () tail ...)))))
Jump to Line
Something went wrong with that request. Please try again.