module/srfi/srfi-37.scm

   1 ;;; srfi-37.scm --- args-fold
   2
   3 ;;      Copyright (C) 2007, 2008, 2013 Free Software Foundation, Inc.
   4 ;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 \f
  20 ;;; Commentary:
  21 ;;
  22 ;; To use this module with Guile, use (cdr (program-arguments)) as
  23 ;; the ARGS argument to `args-fold'.  Here is a short example:
  24 ;;
  25 ;;  (args-fold (cdr (program-arguments))
  26 ;;          (let ((display-and-exit-proc
  27 ;;                 (lambda (msg)
  28 ;;                   (lambda (opt name arg)
  29 ;;                     (display msg) (quit) (values)))))
  30 ;;            (list (option '(#\v "version") #f #f
  31 ;;                          (display-and-exit-proc "Foo version 42.0\n"))
  32 ;;                  (option '(#\h "help") #f #f
  33 ;;                          (display-and-exit-proc
  34 ;;                           "Usage: foo scheme-file ..."))))
  35 ;;          (lambda (opt name arg)
  36 ;;            (error "Unrecognized option `~A'" name))
  37 ;;          (lambda (op) (load op) (values)))
  38 ;;
  39 ;;; Code:
  40
  41 \f
  42 ;;;; Module definition & exports
  43 (define-module (srfi srfi-37)
  44   #:use-module (srfi srfi-9)
  45   #:export (option option-names option-required-arg?
  46             option-optional-arg? option-processor
  47             args-fold))
  48
  49 (cond-expand-provide (current-module) '(srfi-37))
  50 \f
  51 ;;;; args-fold and periphery procedures
  52
  53 ;;; An option as answered by `option'.  `names' is a list of
  54 ;;; characters and strings, representing associated short-options and
  55 ;;; long-options respectively that should use this option's
  56 ;;; `processor' in an `args-fold' call.
  57 ;;;
  58 ;;; `required-arg?' and `optional-arg?' are mutually exclusive
  59 ;;; booleans and indicate whether an argument must be or may be
  60 ;;; provided.  Besides the obvious, this affects semantics of
  61 ;;; short-options, as short-options with a required or optional
  62 ;;; argument cannot be followed by other short options in the same
  63 ;;; program-arguments string, as they will be interpreted collectively
  64 ;;; as the option's argument.
  65 ;;;
  66 ;;; `processor' is called when this option is encountered.  It should
  67 ;;; accept the containing option, the element of `names' (by `equal?')
  68 ;;; encountered, the option's argument (or #f if none), and the seeds
  69 ;;; as variadic arguments, answering the new seeds as values.
  70 (define-record-type srfi-37:option
  71   (option names required-arg? optional-arg? processor)
  72   option?
  73   (names option-names)
  74   (required-arg? option-required-arg?)
  75   (optional-arg? option-optional-arg?)
  76   (processor option-processor))
  77
  78 (define (error-duplicate-option option-name)
  79   (scm-error 'program-error "args-fold"
  80              "Duplicate option name `~A~A'"
  81              (list (if (char? option-name) #\- "--")
  82                    option-name)
  83              #f))
  84
  85 (define (build-options-lookup options)
  86   "Answer an `equal?' Guile hash-table that maps OPTIONS' names back
  87 to the containing options, signalling an error if a name is
  88 encountered more than once."
  89   (let ((lookup (make-hash-table (* 2 (length options)))))
  90     (for-each
  91      (lambda (opt)
  92        (for-each (lambda (name)
  93                    (let ((assoc (hash-create-handle!
  94                                  lookup name #f)))
  95                      (if (cdr assoc)
  96                          (error-duplicate-option (car assoc))
  97                          (set-cdr! assoc opt))))
  98                  (option-names opt)))
  99      options)
 100     lookup))
 101
 102 (define (args-fold args options unrecognized-option-proc
 103                    operand-proc . seeds)
 104   "Answer the results of folding SEEDS as multiple values against the
 105 program-arguments in ARGS, as decided by the OPTIONS'
 106 `option-processor's, UNRECOGNIZED-OPTION-PROC, and OPERAND-PROC."
 107   (let ((lookup (build-options-lookup options)))
 108     ;; I don't like Guile's `error' here
 109     (define (error msg . args)
 110       (scm-error 'misc-error "args-fold" msg args #f))
 111
 112     (define (mutate-seeds! procedure . params)
 113       (set! seeds (call-with-values
 114                       (lambda ()
 115                         (apply procedure (append params seeds)))
 116                     list)))
 117
 118     ;; Clean up the rest of ARGS, assuming they're all operands.
 119     (define (rest-operands)
 120       (for-each (lambda (arg) (mutate-seeds! operand-proc arg))
 121                 args)
 122       (set! args '()))
 123
 124     ;; Call OPT's processor with OPT, NAME, an argument to be decided,
 125     ;; and the seeds.  Depending on OPT's *-arg? specification, get
 126     ;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks;
 127     ;; if no argument is allowed, call NO-ARG-PROC thunk.
 128     (define (invoke-option-processor
 129              opt name req-arg-proc opt-arg-proc no-arg-proc)
 130       (mutate-seeds!
 131        (option-processor opt) opt name
 132        (cond ((option-required-arg? opt) (req-arg-proc))
 133              ((option-optional-arg? opt) (opt-arg-proc))
 134              (else (no-arg-proc) #f))))
 135
 136     ;; Compute and answer a short option argument, advancing ARGS as
 137     ;; necessary, for the short option whose character is at POSITION
 138     ;; in the current ARG.
 139     (define (short-option-argument position)
 140       (cond ((< (1+ position) (string-length (car args)))
 141              (let ((result (substring (car args) (1+ position))))
 142                (set! args (cdr args))
 143                result))
 144             ((pair? (cdr args))
 145              (let ((result (cadr args)))
 146                (set! args (cddr args))
 147                result))
 148             ((pair? args)
 149              (set! args (cdr args))
 150              #f)
 151             (else #f)))
 152
 153     ;; Interpret the short-option at index POSITION in (car ARGS),
 154     ;; followed by the remaining short options in (car ARGS).
 155     (define (short-option position)
 156       (if (>= position (string-length (car args)))
 157           (begin
 158             (set! args (cdr args))
 159             (next-arg))
 160           (let* ((opt-name (string-ref (car args) position))
 161                  (option-here (hash-ref lookup opt-name)))
 162             (cond ((not option-here)
 163                    (mutate-seeds! unrecognized-option-proc
 164                                   (option (list opt-name) #f #f
 165                                           unrecognized-option-proc)
 166                                   opt-name #f)
 167                    (short-option (1+ position)))
 168                   (else
 169                    (invoke-option-processor
 170                     option-here opt-name
 171                     (lambda ()
 172                       (or (short-option-argument position)
 173                           (error "Missing required argument after `-~A'" opt-name)))
 174                     (lambda ()
 175                       ;; edge case: -xo -zf or -xo -- where opt-name=#\o
 176                       ;; GNU getopt_long resolves these like I do
 177                       (short-option-argument position))
 178                     (lambda () #f))
 179                    (if (not (or (option-required-arg? option-here)
 180                                 (option-optional-arg? option-here)))
 181                        (short-option (1+ position))))))))
 182
 183     ;; Process the long option in (car ARGS).  We make the
 184     ;; interesting, possibly non-standard assumption that long option
 185     ;; names might contain #\=, so keep looking for more #\= in (car
 186     ;; ARGS) until we find a named option in lookup.
 187     (define (long-option)
 188       (let ((arg (car args)))
 189         (let place-=-after ((start-pos 2))
 190           (let* ((index (string-index arg #\= start-pos))
 191                  (opt-name (substring arg 2 (or index (string-length arg))))
 192                  (option-here (hash-ref lookup opt-name)))
 193             (if (not option-here)
 194                 ;; look for a later #\=, unless there can't be one
 195                 (if index
 196                     (place-=-after (1+ index))
 197                     (mutate-seeds!
 198                      unrecognized-option-proc
 199                      (option (list opt-name) #f #f unrecognized-option-proc)
 200                      opt-name #f))
 201                 (invoke-option-processor
 202                  option-here opt-name
 203                  (lambda ()
 204                    (if index
 205                        (substring arg (1+ index))
 206                        (error "Missing required argument after `--~A'" opt-name)))
 207                  (lambda () (and index (substring arg (1+ index))))
 208                  (lambda ()
 209                    (if index
 210                        (error "Extraneous argument after `--~A'" opt-name))))))))
 211       (set! args (cdr args)))
 212
 213     ;; Process the remaining in ARGS.  Basically like calling
 214     ;; `args-fold', but without having to regenerate `lookup' and the
 215     ;; funcs above.
 216     (define (next-arg)
 217       (if (null? args)
 218           (apply values seeds)
 219           (let ((arg (car args)))
 220             (cond ((or (not (char=? #\- (string-ref arg 0)))
 221                        (= 1 (string-length arg))) ;"-"
 222                    (mutate-seeds! operand-proc arg)
 223                    (set! args (cdr args)))
 224                   ((char=? #\- (string-ref arg 1))
 225                    (if (= 2 (string-length arg)) ;"--"
 226                        (begin (set! args (cdr args)) (rest-operands))
 227                        (long-option)))
 228                   (else (short-option 1)))
 229             (next-arg))))
 230
 231     (next-arg)))
 232
 233 ;;; srfi-37.scm ends here