;;
;; getopt-style command-line parser
;;
;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)
;;
;; Ported to Chicken Scheme and extensively modified by Ivan Raikov.
;;
;; Copyright 2009-2012 Ivan Raikov.
;;
;; Portions copyright (C) 1998, 2001, 2006 Free Software Foundation,
;; Inc.
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License
;; as published by the Free Software Foundation, either version 3 of
;; the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;;
;; A full copy of the Lesser GPL license can be found at
;; .
;;
;;; Commentary:
;;; This module implements command line option parsing, in the spirit
;;; of the GNU C library function `getopt_long'. Both long and short
;;; options are supported.
;;;
;;; The theory is that people should be able to constrain the set of
;;; options they want to process using a grammar, rather than some
;;; arbitrary structure. The grammar makes the option descriptions
;;; easy to read.
;;;
;;; `getopt-long' is a procedure for parsing command-line arguments in
;;; a manner consistent with GNU programs.
;;;
;;; `usage' is a procedure that prints help strings about the
;;; command-line arguments defined in a grammar.
;;; (getopt-long ARGS GRAMMAR) Parse the arguments ARGS according to
;;; the argument list grammar GRAMMAR.
;;;
;;; ARGS should be a list of strings. Its first element should be the
;;; name of the program; subsequent elements should be the arguments
;;; that were passed to the program on the command line. The
;;; `program-arguments' procedure returns a list of this form.
;;;
;;; GRAMMAR is a list of the form:
;;; ((OPTION-NAME [DOCSTRING]
;;; (PROPERTY VALUE) ...) ...)
;;;
;;; Each OPTION-NAME should be a symbol. `getopt-long' will accept a
;;; command-line option named `--OPTION-NAME'.
;;;
;; If DOCSTRING is provided, it must be a either string a string
;; containing a brief description of the option.
;;;
;;; Each option can have the following (PROPERTY VALUE) pairs:
;;;
;;; (single-char CHAR) --- Accept `-CHAR' as a single-character
;;; equivalent to `--OPTION'. This is how to specify traditional
;;; Unix-style flags.
;;;
;;; (required BOOL) --- If BOOL is true, the option is required.
;;; getopt-long will raise an error if it is not found in ARGS.
;;;
;;; (multiple BOOL) --- If BOOL is true, this option can be specified
;; multiple times. The default is false.
;;;
;;; (value FLAG [(PROPERTY VALUE) ...])
;;; --- If FLAG is #t, the option requires a value; if
;;; it is #f, it does not;
;;; if it is of the form (REQUIRED name) then the option requires
;;; and the name is used by the usage procedure
;;; if it is of the form (OPTIONAL name) the option may
;;; appear with or without a (named) value.
;;;
;;; In addition, the following properties can be defined
;;; for a value:
;;;
;;; (predicate FUNC) ---
;;;
;;; If the option accepts a value, then getopt will
;;; apply FUNC to the value, and throw an exception
;;; if it returns #f. FUNC should be a procedure
;;; which accepts a string and returns a boolean
;;; value; you may need to use quasiquotes to get it
;;; into GRAMMAR.
;;;
;;; (transformer FUNC) ---
;;;
;;; If the option accepts a value, then getopt will
;;; apply FUNC to the string provided on the command
;;; line, and put the resulting value in the list of
;;; parsed options returned by getopt-long.
;;;
;;; The (PROPERTY VALUE) pairs may occur in any order, but each
;;; property may occur only once. By default, options do not have
;;; single-character equivalents, are not required, and do not take
;;; values.
;;;
;;; In ARGS, single-character options may be combined, in the usual
;;; Unix fashion: ("-x" "-y") is equivalent to ("-xy"). If an option
;;; accepts values, then it must be the last option in the
;;; combination; the value is the next argument. So, for example, using
;;; the following grammar:
;;;
;;; ((apples (single-char #\a))
;;; (blimps (single-char #\b) (value #t))
;;; (catalexis (single-char #\c) (value #t)))
;;;
;;; the following argument lists would be acceptable:
;;;
;;; ("-a" "-b" "bang" "-c" "couth") ("bang" and "couth" are the values
;;; for "blimps" and "catalexis")
;;; ("-ab" "bang" "-c" "couth") (same)
;;; ("-ac" "couth" "-b" "bang") (same)
;;; ("-abc" "couth" "bang") (an error, since `-b' is not the
;;; last option in its combination)
;;;
;;; If an option's value is optional, then `getopt-long' decides
;;; whether it has a value by looking at what follows it in ARGS. If
;;; the next element is does not appear to be an option itself, then
;;; that element is the option's value.
;;;
;;; The value of a long option can only follow the option name,
;;; separated by an `=' character.
;;;
;;; If the option "--" appears in ARGS, argument parsing stops there;
;;; subsequent arguments are returned as ordinary arguments, even if
;;; they resemble options. So, in the argument list:
;;;
;;; ("--apples" "Granny Smith" "--" "--blimp" "Goodyear")
;;;
;;; `getopt-long' will recognize the `apples' option as having the
;;; value "Granny Smith", but it will not recognize the `blimp'
;;; option; it will return the strings "--blimp" and "Goodyear" as
;;; ordinary argument strings.
;;;
;;; The `getopt-long' function returns the parsed argument list as an
;;; assocation list, mapping option names --- the symbols from GRAMMAR
;;; --- onto their values, or #t if the option does not accept a value.
;;; Unused options do not appear in the alist.
;;;
;;; All arguments that are not the value of any option are returned
;;; as a list, associated with the empty list.
;;;
;;; `getopt-long' throws an exception if:
;;; - it finds an unrecognized property in GRAMMAR
;;; - the value of the `single-char' property is not a character,
;;; or a single-character string/symbol
;;; - it finds an unrecognized option in ARGS
;;; - a required option is omitted
;;; - an option that requires an argument doesn't get one
;;; - an option that doesn't accept an argument does get one (this can
;;; only happen using the long option `--opt=value' syntax)
;;; - an option predicate fails
;;;
;;; For an example, see file tests/run.scm.
(module getopt-long
(getopt-long width separator indent usage make-option-dispatch)
(import scheme chicken)
(require-extension data-structures srfi-1 srfi-13 srfi-14 matchable )
(define (fetch-value kv)
(match kv ((k v) v) (else (cdr kv))))
(define (lookup-def k lst . rest)
(let-optionals rest ((default #f))
(let ((kv (assoc k lst)))
(if (not kv) default
(fetch-value kv)))))
(define-record-type unknown-option
(make-unknown-option name )
unknown-option?
(name unknown-option-name)
)
(define-record-type value-policy
(make-value-policy name predicate transformer optional? default )
value-policy?
(name value-policy-name)
(predicate value-policy-predicate)
(transformer value-policy-transformer)
(optional? value-policy-optional?)
(default value-policy-default))
(define-record-type option-spec
(make-option-spec name value required? single-char docstring multiple? )
option-spec?
(name option-spec-name)
(value option-spec-value)
(required? option-spec-required?)
(single-char option-spec-single-char)
(docstring option-spec-docstring)
(multiple? option-spec-multiple?))
;;
;; We don't auto-format the left column (the option keys) based on the
;; length of the longest option, but you can override it manually.
;;
(define width (make-parameter 25))
;; The separator used between options. Default: ", "
(define separator (make-parameter ", "))
(define indent (make-parameter 1))
(define (spaces n)
(let loop ((ls '()) (n n))
(if (<= n 0)
(list->string ls)
(loop (cons #\space ls)
(- n 1)))))
;; Join together option names in spec with commas, and append the
;; argument type and name
(define-record-printer (option-spec x out)
(let* ((name (option-spec-name x))
(value-policy (option-spec-value x))
(required? (option-spec-required? x))
(single-char (option-spec-single-char x))
(docstring (option-spec-docstring x))
(multiple? (option-spec-multiple? x))
(long-option (and (not (make-single-char name))
(string-append "--" (->string name))))
(short-option (or (and single-char
(list->string (list #\- single-char)))
(make-single-char name)))
(option-lst (cond ((and short-option long-option)
(list long-option (separator) short-option))
(long-option
(list long-option))
(else (list short-option))))
(option-lst
(cond
(value-policy
(if (value-policy-optional? value-policy)
(cons* "]" (->string (value-policy-name value-policy) )
"[" "=" option-lst)
(cons* (->string (value-policy-name value-policy))
"="
option-lst)))
(else option-lst)))
(option-string (string-concatenate (reverse option-lst))))
(display
(string-append (spaces (indent))
(string-pad-right option-string (width))
docstring
"\n")
out)))
;; Generate a formatted list of options from OPTION-LIST, and return a
;; string suitable for embedding into help text. The single string
;; consists of multiple lines, with a newline at the end of each line.
;; Thus, a typical use would be (print (usage opts)).
(define (usage opts)
(let ((specs (map parse-option-spec opts)))
(apply string-append (map ->string specs))))
(define update-option-spec
(lambda (x . key/values)
(apply
(lambda (#!key
(name (option-spec-name x))
(required? (option-spec-required? x))
(single-char (option-spec-single-char x))
(value (option-spec-value x))
(docstring (option-spec-docstring x))
(multiple? (option-spec-multiple? x))
)
(make-option-spec
name
value
required?
single-char
docstring
multiple?
))
key/values)))
(define (make-predicate pred)
(lambda (name val)
(or (not val)
(pred val)
(error "option predicate failed" name))))
(define (make-single-char x)
(let ((lst (string->list (->string x))))
(and (null? (cdr lst))
(car lst))))
(define (parse-option-spec desc)
(let* ((name (car desc))
(single-char (make-single-char name))
(spec
(make-option-spec
name
#f
#f
single-char
""
#f
)))
(fold
(lambda (desc-elem spec)
(cond ((string? desc-elem)
(update-option-spec spec docstring: desc-elem))
(else
(let ((given (lambda () (cdr desc-elem))))
(case (car desc-elem)
((multiple)
(update-option-spec spec multiple?: (car (given))))
((required)
(update-option-spec spec required?: (car (given))))
((value)
(let ((value-policy
(match (given)
((((and flag (or 'required 'optional))
(and name (or (? symbol?) (? string?)))) . rst)
(let ((predicate
(cond ((lookup-def 'predicate rst) =>
make-predicate)
(else
(lambda x (identity x)))))
(transformer
(or (lookup-def 'transformer rst)
identity))
(default (lookup-def 'default rst))
)
(make-value-policy
name
predicate
transformer
(equal? flag 'optional)
(and default (->string default))
)))
((#t) (make-value-policy
'ARG
(lambda x (identity x))
identity
#f
#f))
((#f) #f)
(else (error "invalid value specification "
(given)))
)))
(update-option-spec spec value: value-policy)))
((single-char)
(cond
((make-single-char (car (given))) =>
(lambda (c)
(update-option-spec spec single-char: c)))
(else
(error "`single-char' value must be a single character, string, or symbol"))))
(else
(error "invalid getopt-long option property"
(car desc-elem))))))))
spec (cdr desc))
))
(define (split-argument-list argument-list)
;; Scan ARGUMENT-LIST for "--" and return (BEFORE-LS . AFTER-LS).
;; Discard the "--". If no "--" is found, AFTER-LS is empty.
(let loop ((yes '()) (no argument-list))
(cond ((null? no) (cons (reverse yes) no))
((string=? "--" (car no)) (cons (reverse yes) (cdr no)))
(else (loop (cons (car no) yes) (cdr no))))))
(define (check-long-option str)
(and (> (string-length str) 1)
(string=? (substring str 0 2) "--")))
(define (check-short-option str)
(and (positive? (string-length str))
(string=? (substring str 0 1) "-")))
(define long-option-name-cs
(char-set-union char-set:letter
(char-set #\-)))
(define (long-option-name lst)
(let loop ((lst lst) (ax (list)))
(cond ((null? lst) (list (list->string (reverse ax)) lst))
((and (char? (car lst))
(char-set-contains? long-option-name-cs
(car lst))
(car lst) )
=> (lambda (c) (loop (cdr lst) (cons c ax))))
((char=? (car lst) #\=)
(list (list->string (reverse ax)) (cdr lst)))
(else (error 'long-option-name
"invalid list" lst)))))
(define long-option-value-cs
(char-set-union char-set:letter+digit
char-set:punctuation
(char-set #\_ #\^ #\$ #\=)))
(define (long-option-value lst)
(if (null? lst) (list #f lst)
(let loop ((lst lst) (ax (list)))
(cond ((null? lst)
(list (list->string (reverse ax)) lst))
((and (char? (car lst)) (car lst)) =>
(lambda (c)
(cond ((char=? c #\")
(let quote-loop ((lst (cdr lst)) (ax ax))
(if (null? lst) (error 'long-option-value
"unclosed option value quotation")
(if (char=? (car lst) #\")
(loop (cdr lst) ax)
(quote-loop (cdr lst) (cons (car lst) ax))))))
((char-set-contains? char-set:blank c)
(list (list->string (reverse ax)) (cdr lst)))
((char-set-contains? long-option-value-cs c)
(loop (cdr lst) (cons c ax)))
(else (error 'long-option-value
"invalid option character" c)))))
(else (error 'long-option-value
"invalid list" lst))))))
(define (long-option? specs a next)
(let ((l (string->list a)))
(match l
((#\- #\- . rst)
(match-let* (((n nrst) (long-option-name rst))
((v _) (let ((lv (long-option-value nrst)))
lv))
((next v)
(begin
(or (and v (list next v))
(list next #f)))))
(cond ((alist-ref (string->symbol n) (car specs)) =>
(lambda (spec)
(cond
((and v (option-spec-value spec)) =>
(lambda (value-policy)
(or
(and ((or (value-policy-predicate value-policy)
(lambda x (identity x))) n v)
(let ((transformer
(or (value-policy-transformer value-policy)
identity)))
(list next (cons (option-spec-name spec) (transformer v)))))
(error 'long-option?
"predicate error on option value" n))))
((and v (not (option-spec-value spec)))
(error 'long-option?
"superfluous argument given to option" n))
((and (not v) (option-spec-value spec)
(value-policy-optional?
(option-spec-value spec)))
(let* ((vp (option-spec-value spec))
(dflt (value-policy-default vp))
(transformer (or (value-policy-transformer vp)
identity))
(v (and dflt (transformer dflt))))
(list next (cons (option-spec-name spec) (or v #t)))))
((and (not v) (option-spec-value spec))
(error 'long-option? "option requires value" n))
(else
(list next (cons (option-spec-name spec) #t)))
)))
(else
(list next (make-unknown-option n))))))
(else #f))))
(define short-option-name-cs
char-set:letter)
(define (short-option-names lst)
(if (null? lst) (list #f lst)
(let loop ((lst lst) (ax (list)))
(cond ((null? lst) (list ax lst))
((and (char? (car lst))
(char-set-contains? short-option-name-cs (car lst))
(car lst)) =>
(lambda (c) (loop (cdr lst) (cons c ax))))
(else (list ax lst))))))
(define (short-options? specs a next)
(let ((l (string->list a)))
(match l
((#\- . rst)
(match-let ((((n1 . ns) _) (short-option-names rst)))
(match-let
;; special case: check if the last single-letter option
;; has an argument
(((next opt1)
(cond
((alist-ref n1 (cadr specs) ) =>
(lambda (spec)
(let ((name (option-spec-name spec)))
(cond
((option-spec-value spec) =>
(lambda (value-policy)
(let ((v (and (pair? next)
(not (check-long-option (car next) ))
(not (check-short-option (car next) ))
(car next))))
(if (and (not v) (not (value-policy-optional? value-policy)))
(error 'short-options? "option requires value" name))
(if (not v)
(list next (cons name (or (value-policy-default value-policy) #t)))
(or (and ((or (value-policy-predicate value-policy)
(lambda x (identity x))) name v)
(let ((transformer
(or (value-policy-transformer value-policy)
identity)))
(list (cdr next) (cons name (transformer v)))))
(error 'short-options?
"predicate error on option value"
name))))))
(else
(list next (cons name #t)))))))
(else
(list next (make-unknown-option (->string n1)))))))
(list next
(cons opt1
(map (lambda (n)
(cond
((alist-ref n (cadr specs) ) =>
(lambda (spec)
(cond
((option-spec-value spec)
(error 'short-options?
"option requires value" n))
(else
(cons (option-spec-name spec) #t)))))
(else
(make-unknown-option (->string n)))))
ns)))))
)
(else #f))))
(define (process-options specs argument-ls)
;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
;; FOUND is an unordered list of option specs for found options, while ETC
;; is an order-maintained list of elements in ARGUMENT-LS that are neither
;; options nor their values.
(let loop ((ls argument-ls) (found (list)) (etc (list)) (unknown (list)))
(if (null? ls)
(list found (reverse etc) (reverse unknown))
(let ((arg (car ls)) (rest (cdr ls)))
(cond ((long-option? specs arg rest) =>
(lambda (next.val)
(let ((optval (cadr next.val)))
(if (unknown-option? optval)
(loop (car next.val) found etc (cons optval unknown))
(loop (car next.val) (cons optval found) etc unknown)))))
((short-options? specs arg rest) =>
(lambda (next.vals)
(let-values (((unknowns optvals) (partition unknown-option? (cadr next.vals))))
(loop (car next.vals) (append optvals found) etc (append unknowns unknown)))))
(else
(loop (cdr ls) found (cons (car ls) etc) unknown)))))))
(define (getopt-long program-arguments option-desc-list
#!key (unknown-option-handler (lambda (x) (error 'getopt-long "unknown options" x))))
;;
;; Process options, handling both long and short options, similar to
;; the glibc function 'getopt_long'. PROGRAM-ARGUMENTS should be a
;; value similar to what (program-arguments) returns.
;;
;; OPTION-DESC-LIST is a list of option descriptions. Each option
;; description must satisfy the following grammar:
;;
;; :: ( . )
;; :: ( . )
;; | ()
;; ::
;; |
;; |
;; |
;; :: (required? )
;; :: (single-char )
;; :: (value #t)
;; (value #f)
;; (value (required ))
;; (value (optional ))
;; (
;; )
;; :: (predicate <1-ary-function>)
;;
;; The procedure returns an alist of option names and values.
;; Each option name is a symbol. The option value will be '#t' if no
;; value was specified. There is a special item in the returned alist
;; with a key @: the list of arguments that are not options or option
;; values.
;;
;; By default, options are not required, and option values are not
;; required. By default, single character equivalents are not
;; supported; if you want to allow the user to use single character
;; options, you need to add a `single-char' clause to the option
;; description.
(let* ((specifications (map parse-option-spec option-desc-list))
(spec-long (map (lambda (spec)
(cons (option-spec-name spec) spec))
specifications))
(spec-short (filter-map
(lambda (spec)
(and (option-spec-single-char spec)
(cons (option-spec-single-char spec)
spec)))
specifications))
(pair (split-argument-list program-arguments))
(split-ls (car pair))
(non-split-ls (cdr pair)))
(match-let (((found etc unknown)
(process-options (list spec-long spec-short) split-ls)))
(let ((rest-ls (append etc non-split-ls)))
(for-each (lambda (spec)
(let ((name (option-spec-name spec)))
(and (option-spec-required? spec)
(or (assoc name found )
(error "option must be specified" name)))
(and (assoc name found)
(and (option-spec-value spec)
(not (value-policy-optional?
(option-spec-value spec))))
(or (cdr (assoc name found))
(error "option must be specified with argument"
name)))))
specifications)
(values
(cons (cons '@ rest-ls) found)
(or (and (not (null? unknown))
(unknown-option-handler (map unknown-option-name unknown)))
'()))
))
))
(define (make-option-dispatch opts options-desc-list)
(let* ((specifications (map parse-option-spec options-desc-list))
(defaults
(filter-map
(lambda (spec)
(let* ((name (option-spec-name spec))
(value-policy (option-spec-value spec))
(default (and value-policy
(value-policy-default value-policy)))
)
(cond ((and value-policy
(value-policy-predicate value-policy)) =>
(lambda (pred)
(or (pred name default)
(error 'make-option-dispatch
"predicate error in default value"
default)))))
(let ((transformer
(or (and value-policy
(value-policy-transformer value-policy))
identity)))
(and default (list name (transformer default))))
))
specifications)))
(lambda (name)
(case name
((@) (alist-ref '@ opts))
(else
(let* ((spec (find (lambda (x) (eq? (option-spec-name x) name)) specifications))
(v (filter-map (lambda (x) (and (eq? (car x) name) (fetch-value x))) (cdr opts))))
(if (option-spec-multiple? spec) v (and (pair? v) (car v)))))
))
))
)
;;; getopt-long.scm ends here