(ice-9 getopt-long) w/ restricted `merge-multiple?' range

[Thien-Thi Nguyen]

folks,

please find below an improved version of module (ice-9 getopt-long).

`merge-multiple?' used to result in non-list values when there was only
one usage of a given option.  now the range is restricted: it always
returns either #f or a list (possibly w/ only one element).

from an implementation pov, this version is notable for using simple
vectors instead of records, using less passes, and relief of dependency
on (ice-9 common-list).

from a design pov, (ice-9 getopt-long) is still lacking some kind of
sequence/threading markup, to support things like sed's combination of
-e and -f flags.  probably a simple counter in `eat!' is sufficient for
generating sequence numbers -- the question is, where to put them?

thi

_________________________________
;;; getopt-long.scm

;;      Copyright (C) 1998,2001,02,03,2004 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 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.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Russ McManus (modified by Thien-Thi Nguyen)

;;; Commentary:

;;; This module implements some complex 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 other GNU programs.  `option-ref' is a procedure
;;; that facilitates processing of the `getopt-long' return value.

;;; (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 (PROPERTY VALUE) ...) ...)
;;;
;;; Each OPTION should be a symbol.  `getopt-long' will accept a
;;; command-line option named `--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.
;;;   (value POLICY) --- If POLICY is #t, the option accepts a value; if
;;;             it is #f, it does not; and if it is the symbol `optional',
;;;             the option may appear in ARGS with or without a value.
;;;   (merge-multiple? BOOL) --- If BOOL is #t and the `value' option is not
;;;             #f, all (one or multiple) occurrances are merged into a list
;;;             with order retained.  If #f, each instance of the option
;;;             results in a separate entry in the resulting alist.
;;;   (predicate FUNC) --- If the option accepts a value (i.e. you
;;;             specified `(value #t)' for this option), 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.
;;;
;;; 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 appear as the next element in ARGS,
;;; or it can follow the option name, separated by an `=' character.
;;; Thus, using the same grammar as above, the following argument lists
;;; are equivalent:
;;;   ("--apples" "Braeburn" "--blimps" "Goodyear")
;;;   ("--apples=Braeburn" "--blimps" "Goodyear")
;;;   ("--blimps" "Goodyear" "--apples=Braeburn")
;;;
;;; 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
;;; - 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
;;;
;;; So, for example:
;;;
;;; (define grammar
;;;   `((lockfile-dir (required? #t)
;;;                   (value #t)
;;;                   (single-char #\k)
;;;                   (predicate ,file-is-directory?))
;;;     (verbose (required? #f)
;;;              (single-char #\v)
;;;              (value #f))
;;;     (x-includes (single-char #\x))
;;;     (rnet-server (single-char #\y)
;;;                  (predicate ,string?))))
;;;
;;; (getopt-long '("my-prog" "-vk" "/tmp" "foo1" "--x-includes=/usr/include"
;;;                "--rnet-server=lamprod" "--" "-fred" "foo2" "foo3")
;;;                grammar)
;;; => ((() "foo1" "-fred" "foo2" "foo3")
;;;     (rnet-server . "lamprod")
;;;     (x-includes . "/usr/include")
;;;     (lockfile-dir . "/tmp")
;;;     (verbose . #t))

;;; (option-ref OPTIONS KEY DEFAULT)
;;; Return value in alist OPTIONS using KEY, a symbol; or DEFAULT if not
;;; found.  The value is either a string or `#t'.
;;;
;;; For example, using the `getopt-long' return value from above:
;;;
;;; (option-ref (getopt-long ...) 'x-includes 42) => "/usr/include"
;;; (option-ref (getopt-long ...) 'not-a-key! 31) => 31

;;; Code:

(define-module (ice-9 getopt-long)
  #:export (getopt-long option-ref))

(define option-spec-fields '(name
                             required?
                             single-char
                             predicate
                             value-policy
                             merge-multiple?))

(define field-count (length option-spec-fields))

(define (make-option-spec name)
  (apply vector name (make-list (1- field-count) #f)))

(define (define-one-accessor field position)
  `(define (,(symbol-append 's: field) option-spec-object)
     (vector-ref option-spec-object ,position)))

(define (define-one-modifier field position)
  `(define (,(symbol-append 's: field '!) option-spec-object new-value)
     (vector-set! option-spec-object ,position new-value)))

(defmacro define-all-accessors/modifiers ()
  `(begin
     ,@(map define-one-accessor option-spec-fields (iota field-count))
     ,@(map define-one-modifier option-spec-fields (iota field-count))))

(define-all-accessors/modifiers)

(define (parse-option-spec desc)
  (let* ((name (car desc))
         (spec (make-option-spec name)))
    (for-each (lambda (desc-elem)
                (let ((given (lambda () (cadr desc-elem))))
                  (case (car desc-elem)
                    ((required?)
                     (s:required?! spec (given)))
                    ((value)
                     (s:value-policy! spec (given)))
                    ((single-char)
                     (or (char? (given))
                         (error "`single-char' value must be a char!"))
                     (s:single-char! spec (given)))
                    ((predicate)
                     (s:predicate! spec (given)))
                    ((merge-multiple?)
                     (s:merge-multiple?! spec (given)))
                    (else
                     (error "invalid getopt-long option property:"
                            (car desc-elem))))))
              (cdr desc))
    spec))

(define (split-arg-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 short-opt-rx           (make-regexp "^-([a-zA-Z]+)(.*)"))
(define long-opt-no-value-rx   (make-regexp "^--([^=]+)$"))
(define long-opt-with-value-rx (make-regexp "^--([^=]+)=(.*)"))

(define (msub match which)
  ;; condensed from (ice-9 regex) `match:{substring,start,end}'
  (let ((sel (vector-ref match (1+ which))))
    (substring (vector-ref match 0) (car sel) (cdr sel))))

(define (expand-clumped-singles opt-ls)
  ;; example: ("--xyz" "-abc5d") => ("--xyz" "-a" "-b" "-c" "5d")
  (let loop ((opt-ls opt-ls) (ret-ls '()))
    (cond ((null? opt-ls)
           (reverse ret-ls))                                    ;;; retval
          ((regexp-exec short-opt-rx (car opt-ls))
           => (lambda (match)
                (let ((singles (reverse
                                (map (lambda (c)
                                       (string-append "-" (make-string 1 c)))
                                     (string->list
                                      (msub match 1)))))
                      (extra (msub match 2)))
                  (loop (cdr opt-ls)
                        (append (if (string-null? extra)
                                    singles
                                    (cons extra singles))
                                ret-ls)))))
          (else (loop (cdr opt-ls)
                      (cons (car opt-ls) ret-ls))))))

(define (looks-like-an-option string)
  (define (m? rx)
    (regexp-exec rx string))
  (or (m? short-opt-rx)
      (m? long-opt-with-value-rx)
      (m? long-opt-no-value-rx)))

(define (process-options specs argument-ls)
  ;; Use SPECS to scan ARGUMENT-LS; return (FOUND . ETC).
  ;; FOUND is an unordered list of pairs (NAME . VALUE) for found options,
  ;; while ETC is an order-maintained list of elements in ARGUMENT-LS that
  ;; are neither options nor their values.
  (let ((idx (map (lambda (spec)
                    (cons (s:name spec) spec))
                  specs))
        (sc-idx (let loop ((ls specs) (acc '()))
                  (if (null? ls) acc
                      (loop (cdr ls) (let* ((spec (car ls))
                                            (sc (s:single-char spec)))
                                       (if sc
                                           (acons sc spec acc)
                                           acc)))))))
    (let loop ((arg-ls argument-ls) (found '()) (etc '()))
      (let ((eat! (lambda (spec ls)
                    (let ((val!loop (lambda (val rest)
                                      (let* ((mm? (s:merge-multiple? spec))
                                             (who (s:name spec))
                                             (old (and mm? (assq-ref found 
who)))
                                             (new (and (not old)
                                                       (cons who
                                                             (if mm?
                                                                 (list val)
                                                                 val)))))
                                        (and old (set-cdr! (last-pair old)
                                                           (list val)))
                                        (loop (rest ls)
                                              (if new (cons new found) found)
                                              etc))))
                          (no-following? (lambda ()
                                           (or (null? (cdr ls))
                                               (looks-like-an-option
                                                (cadr ls))))))
                      (case (s:value-policy spec)
                        ((optional)
                         (if (no-following?)
                             (val!loop #t cdr)
                             (val!loop (cadr ls) cddr)))
                        ((#t)
                         (if (no-following?)
                             (error "option must be specified with argument:"
                                    (s:name spec))
                             (val!loop (cadr ls) cddr)))
                        (else
                         (val!loop #t cdr)))))))
        (if (null? arg-ls)
            (cons found (reverse etc))                          ;;; retval
            (let ((ERR:no-such (lambda (x)
                                 (error "no such option:" x)))
                  (check (lambda (two? rx)
                           (and=> (regexp-exec rx (car arg-ls))
                                  (lambda (m)
                                    (let ((one (msub m 1)))
                                      (if two?
                                          (cons one (msub m 2))
                                          one)))))))
              (cond ((check #f short-opt-rx)
                     => (lambda (c)
                          (eat! (or (assq-ref sc-idx (string-ref c 0))
                                    (ERR:no-such c))
                                arg-ls)))
                    ((check #f long-opt-no-value-rx)
                     => (lambda (opt)
                          (eat! (or (assq-ref idx (string->symbol opt))
                                    (ERR:no-such opt))
                                arg-ls)))
                    ((check #t long-opt-with-value-rx)
                     => (lambda (pair)
                          (let* ((opt (car pair))
                                 (spec (or (assq-ref idx (string->symbol opt))
                                           (ERR:no-such opt))))
                            (if (s:value-policy spec)
                                (eat! spec (append
                                            (list 'ignored (cdr pair))
                                            (cdr arg-ls)))
                                (error "option does not support argument:"
                                       opt)))))
                    (else
                     (loop (cdr arg-ls)
                           found
                           (cons (car arg-ls) etc))))))))))

;; Parse the command line given in @var{args} (which must be a list of
;; strings) according to the option specification @var{grammar}.
;;
;; The @var{grammar} argument is expected to be a list of this form:
;;
;; @code{((@var{option} (@var{property} @var{value}) @dots{}) @dots{})}
;;
;; where each @var{option} is a symbol denoting the long option, but
;; without the two leading dashes (e.g. @code{version} if the option is
;; called @code{--version}).
;;
;; For each option, there may be list of arbitrarily many property/value
;; pairs.  The order of the pairs is not important, but every property may
;; only appear once in the property list.  The following table lists the
;; possible properties:
;;
;; @table @asis
;; @item @code{(single-char @var{char})}
;; Accept @address@hidden as a single-character equivalent to
;; @address@hidden  This is how to specify traditional Unix-style
;; flags.
;;
;; @item @code{(required? @var{bool})}
;; If @var{bool} is true, the option is required.  @code{getopt-long} will
;; raise an error if it is not found in @var{args}.
;;
;; @item @code{(value @var{bool})}
;; If @var{bool} is @code{#t}, the option accepts a value; if it is
;; @code{#f}, it does not; and if it is the symbol @code{optional}, the
;; option may appear in @var{args} with or without a value.
;;
;; @item @code{(merge-multiple? @var{bool})}
;; If @var{bool} is @code{#t} and the @code{value} property is not
;; @code{#f}, all (one or multiple) occurrances are merged into a list
;; with order retained.  If @code{#f}, each instance of the option results
;; in a separate entry in the resulting alist.
;;
;; @item @code{(predicate @var{func})}
;; If the option accepts a value (i.e. you specified @code{(value #t)} for
;; this option), then @code{getopt-long} will apply @var{func} to the
;; value, and throw an exception if it returns @code{#f}.  @var{func}
;; should be a procedure which accepts a string and returns a boolean
;; value; you may need to use quasiquotes to get it into @var{grammar}.
;; @end table
;;
(define (getopt-long args grammar)
  (let* ((program-arguments args)
         (option-desc-list grammar)
         (specifications (map parse-option-spec option-desc-list))
         (pair (split-arg-list (cdr program-arguments)))
         (split-ls (expand-clumped-singles (car pair)))
         (non-split-ls (cdr pair))
         (found/etc (process-options specifications split-ls))
         (found (car found/etc))
         (rest-ls (append (cdr found/etc) non-split-ls)))
    (for-each (lambda (spec)
                (let ((name (s:name spec)))
                  (and (s:required? spec)
                       (or (assq name found)
                           (error "option must be specified:" name)))
                  (and=> (and (assq name found) (s:predicate spec))
                         (lambda (pred)
                           (for-each (lambda (val)
                                       (or (pred val)
                                           (error "option predicate failed:"
                                                  name)))
                                     ;; consider all occurances
                                     (if (s:merge-multiple? spec)
                                         (assq-ref found name)
                                         (let loop ((ls found) (acc '()))
                                           (if (null? ls)
                                               acc
                                               (loop (cdr ls)
                                                     (if (eq? (caar ls) name)
                                                         (cons (cdar ls) acc)
                                                         acc))))))))))
              specifications)
    (acons '() rest-ls found)))

;; Search @var{options} for a command line option named @var{key} and
;; return its value, if found.  If the option has no value, but was given,
;; return @code{#t}.  If the option was not given, return @var{default}.
;; @var{options} must be the result of a call to @code{getopt-long}.
;;
(define (option-ref options key default)
  (or (assq-ref options key) default))

;;; getopt-long.scm ends here