module/srfi/srfi-37.scm

   1 ;;; srfi-37.scm --- args-fold
   2
   3 ;;      Copyright (C) 2007, 2008 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 2.1 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             (else #f)))
 149
 150     ;; Interpret the short-option at index POSITION in (car ARGS),
 151     ;; followed by the remaining short options in (car ARGS).
 152     (define (short-option position)
 153       (if (>= position (string-length (car args)))
 154           (begin
 155             (set! args (cdr args))
 156             (next-arg))
 157           (let* ((opt-name (string-ref (car args) position))
 158                  (option-here (hash-ref lookup opt-name)))
 159             (cond ((not option-here)
 160                    (mutate-seeds! unrecognized-option-proc
 161                                   (option (list opt-name) #f #f
 162                                           unrecognized-option-proc)
 163                                   opt-name #f)
 164                    (short-option (1+ position)))
 165                   (else
 166                    (invoke-option-processor
 167                     option-here opt-name
 168                     (lambda ()
 169                       (or (short-option-argument position)
 170                           (error "Missing required argument after `-~A'" opt-name)))
 171                     (lambda ()
 172                       ;; edge case: -xo -zf or -xo -- where opt-name=#\o
 173                       ;; GNU getopt_long resolves these like I do
 174                       (short-option-argument position))
 175                     (lambda () #f))
 176                    (if (not (or (option-required-arg? option-here)
 177                                 (option-optional-arg? option-here)))
 178                        (short-option (1+ position))))))))
 179
 180     ;; Process the long option in (car ARGS).  We make the
 181     ;; interesting, possibly non-standard assumption that long option
 182     ;; names might contain #\=, so keep looking for more #\= in (car
 183     ;; ARGS) until we find a named option in lookup.
 184     (define (long-option)
 185       (let ((arg (car args)))
 186         (let place-=-after ((start-pos 2))
 187           (let* ((index (string-index arg #\= start-pos))
 188                  (opt-name (substring arg 2 (or index (string-length arg))))
 189                  (option-here (hash-ref lookup opt-name)))
 190             (if (not option-here)
 191                 ;; look for a later #\=, unless there can't be one
 192                 (if index
 193                     (place-=-after (1+ index))
 194                     (mutate-seeds!
 195                      unrecognized-option-proc
 196                      (option (list opt-name) #f #f unrecognized-option-proc)
 197                      opt-name #f))
 198                 (invoke-option-processor
 199                  option-here opt-name
 200                  (lambda ()
 201                    (if index
 202                        (substring arg (1+ index))
 203                        (error "Missing required argument after `--~A'" opt-name)))
 204                  (lambda () (and index (substring arg (1+ index))))
 205                  (lambda ()
 206                    (if index
 207                        (error "Extraneous argument after `--~A'" opt-name))))))))
 208       (set! args (cdr args)))
 209
 210     ;; Process the remaining in ARGS.  Basically like calling
 211     ;; `args-fold', but without having to regenerate `lookup' and the
 212     ;; funcs above.
 213     (define (next-arg)
 214       (if (null? args)
 215           (apply values seeds)
 216           (let ((arg (car args)))
 217             (cond ((or (not (char=? #\- (string-ref arg 0)))
 218                        (= 1 (string-length arg))) ;"-"
 219                    (mutate-seeds! operand-proc arg)
 220                    (set! args (cdr args)))
 221                   ((char=? #\- (string-ref arg 1))
 222                    (if (= 2 (string-length arg)) ;"--"
 223                        (begin (set! args (cdr args)) (rest-operands))
 224                        (long-option)))
 225                   (else (short-option 1)))
 226             (next-arg))))
 227
 228     (next-arg)))
 229
 230 ;;; srfi-37.scm ends here