;; ;; 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