diff options
| -rw-r--r-- | Makefile.am | 15 | ||||
| -rw-r--r-- | configure.ac | 4 | ||||
| -rw-r--r-- | m4/guix.m4 | 19 | ||||
| -rw-r--r-- | srfi/srfi-37.scm.in | 233 |
4 files changed, 270 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am index ecda21c77f..ed3607300f 100644 --- a/Makefile.am +++ b/Makefile.am @@ -74,12 +74,24 @@ MODULES = \ # first to avoid errors on systems where (gnutls) is unavailable. guix/scripts/download.go: guix/build/download.go + GOBJECTS = $(MODULES:%.scm=%.go) guix/config.go nobase_dist_guilemodule_DATA = $(MODULES) +nobase_nodist_guilemodule_DATA = $(GOBJECTS) guix/config.scm +# Do we need to provide our own non-broken (srfi srfi-37) module? +if INSTALL_SRFI_37 + +nobase_nodist_guilemodule_DATA += srfi/srfi-37.scm +GOBJECTS += srfi/srfi-37.go + +srfi/srfi-37.scm: srfi/srfi-37.scm.in + $(MKDIR_P) srfi + cp "$<" "$@" + +endif INSTALL_SRFI_37 -nobase_nodist_guilemodule_DATA = $(GOBJECTS) guix/config.scm SCM_TESTS = \ tests/base32.scm \ @@ -133,6 +145,7 @@ EXTRA_DIST = \ build-aux/download.scm \ build-aux/list-packages.scm \ build-aux/sync-synopses.scm \ + srfi/srfi-37.scm.in \ srfi/srfi-64.scm \ srfi/srfi-64.upstream.scm \ tests/test.drv \ diff --git a/configure.ac b/configure.ac index 80d35a4272..2700bb65ea 100644 --- a/configure.ac +++ b/configure.ac @@ -51,6 +51,10 @@ fi dnl Make sure we have a full-fledged Guile. GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads]) +dnl Check whether (srfi srfi-37) works, and provide our own if it doesn't. +GUIX_CHECK_SRFI_37 +AM_CONDITIONAL([INSTALL_SRFI_37], [test "x$ac_cv_guix_srfi_37_broken" = xyes]) + AC_ARG_WITH([nix-prefix], [AS_HELP_STRING([--with-nix-prefix=DIR], [search for Nix in DIR])], [case "$withval" in diff --git a/m4/guix.m4 b/m4/guix.m4 index 477b0e4eb3..63fa00be2f 100644 --- a/m4/guix.m4 +++ b/m4/guix.m4 @@ -115,3 +115,22 @@ AC_DEFUN([GUIX_ASSERT_GUILE_FEATURES], [ fi done ]) + +dnl GUIX_CHECK_SRFI_37 +dnl +dnl Check whether SRFI-37 suffers from <http://bugs.gnu.org/13176>. +dnl This bug was fixed in Guile 2.0.9. +AC_DEFUN([GUIX_CHECK_SRFI_37], [ + AC_CACHE_CHECK([whether (srfi srfi-37) is affected by http://bugs.gnu.org/13176], + [ac_cv_guix_srfi_37_broken], + [if "$GUILE" -c "(use-modules (srfi srfi-37)) \ + (sigaction SIGALRM (lambda _ (primitive-exit 1))) \ + (alarm 1) \ + (define opts (list (option '(#\I) #f #t (lambda _ #t)))) \ + (args-fold '(\"-I\") opts (lambda _ (error)) (lambda _ #f) '())" + then + ac_cv_guix_srfi_37_broken=no + else + ac_cv_guix_srfi_37_broken=yes + fi]) +]) diff --git a/srfi/srfi-37.scm.in b/srfi/srfi-37.scm.in new file mode 100644 index 0000000000..3f654af2ce --- /dev/null +++ b/srfi/srfi-37.scm.in @@ -0,0 +1,233 @@ +;;; 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 |