3
5
Fork 0
mirror of git://git.savannah.gnu.org/guix.git synced 2023-12-14 03:33:07 +01:00
guix/srfi/srfi-37.scm.in
Ludovic Courtès 1959fb04dc build: Provide a replacement (srfi srfi-37) when the user's one is broken.
* srfi/srfi-37.scm.in: New file, taken from Guile 2.0.9.
* m4/guix.m4: New macro.
* configure.ac: Use it.  Define Automake conditional `INSTALL_SRFI_37'.
* Makefile.am (nobase_nodist_guilemodule_DATA)[INSTALL_SRFI_37]: Add
  srfi/srfi-37.scm.
  (GOBJECTS)[INSTALL_SRFI_37]: Add srfi/srfi-37.go.
  (srfi/srfi-37.scm)[INSTALL_SRFI_37]: New target.
  (EXTRA_DIST): Add srfi/srfi-37.scm.in.
2013-07-17 11:05:19 +02:00

233 lines
8.4 KiB
Scheme
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; srfi-37.scm --- args-fold
;; Copyright (C) 2007, 2008, 2013 Free Software Foundation, Inc.
;;
;; This library 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 library 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
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Commentary:
;;
;; To use this module with Guile, use (cdr (program-arguments)) as
;; the ARGS argument to `args-fold'. Here is a short example:
;;
;; (args-fold (cdr (program-arguments))
;; (let ((display-and-exit-proc
;; (lambda (msg)
;; (lambda (opt name arg)
;; (display msg) (quit) (values)))))
;; (list (option '(#\v "version") #f #f
;; (display-and-exit-proc "Foo version 42.0\n"))
;; (option '(#\h "help") #f #f
;; (display-and-exit-proc
;; "Usage: foo scheme-file ..."))))
;; (lambda (opt name arg)
;; (error "Unrecognized option `~A'" name))
;; (lambda (op) (load op) (values)))
;;
;;; Code:
;;;; Module definition & exports
(define-module (srfi srfi-37)
#:use-module (srfi srfi-9)
#:export (option option-names option-required-arg?
option-optional-arg? option-processor
args-fold))
(cond-expand-provide (current-module) '(srfi-37))
;;;; args-fold and periphery procedures
;;; An option as answered by `option'. `names' is a list of
;;; characters and strings, representing associated short-options and
;;; long-options respectively that should use this option's
;;; `processor' in an `args-fold' call.
;;;
;;; `required-arg?' and `optional-arg?' are mutually exclusive
;;; booleans and indicate whether an argument must be or may be
;;; provided. Besides the obvious, this affects semantics of
;;; short-options, as short-options with a required or optional
;;; argument cannot be followed by other short options in the same
;;; program-arguments string, as they will be interpreted collectively
;;; as the option's argument.
;;;
;;; `processor' is called when this option is encountered. It should
;;; accept the containing option, the element of `names' (by `equal?')
;;; encountered, the option's argument (or #f if none), and the seeds
;;; as variadic arguments, answering the new seeds as values.
(define-record-type srfi-37:option
(option names required-arg? optional-arg? processor)
option?
(names option-names)
(required-arg? option-required-arg?)
(optional-arg? option-optional-arg?)
(processor option-processor))
(define (error-duplicate-option option-name)
(scm-error 'program-error "args-fold"
"Duplicate option name `~A~A'"
(list (if (char? option-name) #\- "--")
option-name)
#f))
(define (build-options-lookup options)
"Answer an `equal?' Guile hash-table that maps OPTIONS' names back
to the containing options, signalling an error if a name is
encountered more than once."
(let ((lookup (make-hash-table (* 2 (length options)))))
(for-each
(lambda (opt)
(for-each (lambda (name)
(let ((assoc (hash-create-handle!
lookup name #f)))
(if (cdr assoc)
(error-duplicate-option (car assoc))
(set-cdr! assoc opt))))
(option-names opt)))
options)
lookup))
(define (args-fold args options unrecognized-option-proc
operand-proc . seeds)
"Answer the results of folding SEEDS as multiple values against the
program-arguments in ARGS, as decided by the OPTIONS'
`option-processor's, UNRECOGNIZED-OPTION-PROC, and OPERAND-PROC."
(let ((lookup (build-options-lookup options)))
;; I don't like Guile's `error' here
(define (error msg . args)
(scm-error 'misc-error "args-fold" msg args #f))
(define (mutate-seeds! procedure . params)
(set! seeds (call-with-values
(lambda ()
(apply procedure (append params seeds)))
list)))
;; Clean up the rest of ARGS, assuming they're all operands.
(define (rest-operands)
(for-each (lambda (arg) (mutate-seeds! operand-proc arg))
args)
(set! args '()))
;; Call OPT's processor with OPT, NAME, an argument to be decided,
;; and the seeds. Depending on OPT's *-arg? specification, get
;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks;
;; if no argument is allowed, call NO-ARG-PROC thunk.
(define (invoke-option-processor
opt name req-arg-proc opt-arg-proc no-arg-proc)
(mutate-seeds!
(option-processor opt) opt name
(cond ((option-required-arg? opt) (req-arg-proc))
((option-optional-arg? opt) (opt-arg-proc))
(else (no-arg-proc) #f))))
;; Compute and answer a short option argument, advancing ARGS as
;; necessary, for the short option whose character is at POSITION
;; in the current ARG.
(define (short-option-argument position)
(cond ((< (1+ position) (string-length (car args)))
(let ((result (substring (car args) (1+ position))))
(set! args (cdr args))
result))
((pair? (cdr args))
(let ((result (cadr args)))
(set! args (cddr args))
result))
((pair? args)
(set! args (cdr args))
#f)
(else #f)))
;; Interpret the short-option at index POSITION in (car ARGS),
;; followed by the remaining short options in (car ARGS).
(define (short-option position)
(if (>= position (string-length (car args)))
(begin
(set! args (cdr args))
(next-arg))
(let* ((opt-name (string-ref (car args) position))
(option-here (hash-ref lookup opt-name)))
(cond ((not option-here)
(mutate-seeds! unrecognized-option-proc
(option (list opt-name) #f #f
unrecognized-option-proc)
opt-name #f)
(short-option (1+ position)))
(else
(invoke-option-processor
option-here opt-name
(lambda ()
(or (short-option-argument position)
(error "Missing required argument after `-~A'" opt-name)))
(lambda ()
;; edge case: -xo -zf or -xo -- where opt-name=#\o
;; GNU getopt_long resolves these like I do
(short-option-argument position))
(lambda () #f))
(if (not (or (option-required-arg? option-here)
(option-optional-arg? option-here)))
(short-option (1+ position))))))))
;; Process the long option in (car ARGS). We make the
;; interesting, possibly non-standard assumption that long option
;; names might contain #\=, so keep looking for more #\= in (car
;; ARGS) until we find a named option in lookup.
(define (long-option)
(let ((arg (car args)))
(let place-=-after ((start-pos 2))
(let* ((index (string-index arg #\= start-pos))
(opt-name (substring arg 2 (or index (string-length arg))))
(option-here (hash-ref lookup opt-name)))
(if (not option-here)
;; look for a later #\=, unless there can't be one
(if index
(place-=-after (1+ index))
(mutate-seeds!
unrecognized-option-proc
(option (list opt-name) #f #f unrecognized-option-proc)
opt-name #f))
(invoke-option-processor
option-here opt-name
(lambda ()
(if index
(substring arg (1+ index))
(error "Missing required argument after `--~A'" opt-name)))
(lambda () (and index (substring arg (1+ index))))
(lambda ()
(if index
(error "Extraneous argument after `--~A'" opt-name))))))))
(set! args (cdr args)))
;; Process the remaining in ARGS. Basically like calling
;; `args-fold', but without having to regenerate `lookup' and the
;; funcs above.
(define (next-arg)
(if (null? args)
(apply values seeds)
(let ((arg (car args)))
(cond ((or (not (char=? #\- (string-ref arg 0)))
(= 1 (string-length arg))) ;"-"
(mutate-seeds! operand-proc arg)
(set! args (cdr args)))
((char=? #\- (string-ref arg 1))
(if (= 2 (string-length arg)) ;"--"
(begin (set! args (cdr args)) (rest-operands))
(long-option)))
(else (short-option 1)))
(next-arg))))
(next-arg)))
;;; srfi-37.scm ends here