summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2015-02-25 23:31:51 +0100
committerLudovic Courtès <ludo@gnu.org>2015-02-26 00:04:36 +0100
commitb3f213893b67620840597213b8f46af1ddfb4934 (patch)
treeabfa807e3a38e60c86e2ff1bf79e2dc55a06acd6 /guix
parent72bfebf58d9203c6a09266dd2a20719bed6e27e9 (diff)
ui: Factorize command-line + env. var. option parsing.
* guix/ui.scm (%default-argument-handler, parse-command-line): New procedures. (environment-build-options): Make private. * guix/scripts/archive.scm (guix-archive)[parse-options, parse-options-from]: Remove. Use 'parse-command-line' instead. * guix/scripts/build.scm (guix-build): Likewise. * guix/scripts/environment.scm (guix-environment): Likewise. * guix/scripts/package.scm (guix-package): Likewise. * guix/scripts/system.scm (guix-system): Likewise. * tests/ui.scm (with-environment-variable): New macro. ("parse-command-line"): New test.
Diffstat (limited to 'guix')
-rw-r--r--guix/scripts/archive.scm16
-rw-r--r--guix/scripts/build.scm17
-rw-r--r--guix/scripts/environment.scm18
-rw-r--r--guix/scripts/package.scm24
-rw-r--r--guix/scripts/system.scm34
-rw-r--r--guix/ui.scm28
6 files changed, 54 insertions, 83 deletions
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index b85119a0ff..ea6801a6eb 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -297,20 +297,6 @@ the input port."
(cut write-acl acl <>)))))
(define (guix-archive . args)
- (define (parse-options)
- ;; Return the alist of option values.
- (append (parse-options-from args)
- (parse-options-from (environment-build-options))))
-
- (define (parse-options-from args)
- ;; Actual parsing takes place here.
- (args-fold* args %options
- (lambda (opt name arg result)
- (leave (_ "~A: unrecognized option~%") name))
- (lambda (arg result)
- (alist-cons 'argument arg result))
- %default-options))
-
(define (lines port)
;; Return lines read from PORT.
(let loop ((line (read-line port))
@@ -324,7 +310,7 @@ the input port."
;; Ask for absolute file names so that .drv file names passed from the
;; user to 'read-derivation' are absolute when it returns.
(with-fluids ((%file-port-name-canonicalization 'absolute))
- (let ((opts (parse-options)))
+ (let ((opts (parse-command-line args %options (list %default-options))))
(cond ((assoc-ref opts 'generate-key)
=>
generate-key-pair)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 07ced30484..370c2a37ff 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -405,25 +405,12 @@ arguments with packages that use the specified source."
;;;
(define (guix-build . args)
- (define (parse-options)
- ;; Return the alist of option values.
- (append (parse-options-from args)
- (parse-options-from (environment-build-options))))
-
- (define (parse-options-from args)
- ;; Actual parsing takes place here.
- (args-fold* args %options
- (lambda (opt name arg result)
- (leave (_ "~A: unrecognized option~%") name))
- (lambda (arg result)
- (alist-cons 'argument arg result))
- %default-options))
-
(with-error-handling
;; Ask for absolute file names so that .drv file names passed from the
;; user to 'read-derivation' are absolute when it returns.
(with-fluids ((%file-port-name-canonicalization 'absolute))
- (let* ((opts (parse-options))
+ (let* ((opts (parse-command-line args %options
+ (list %default-options)))
(store (open-connection))
(drv (options->derivations store opts))
(roots (filter-map (match-lambda
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index bb2ce53caf..c96ca351c4 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -217,22 +217,12 @@ packages."
;; Entry point.
(define (guix-environment . args)
- (define (parse-options)
- ;; Return the alist of option values.
- (append (parse-options-from args)
- (parse-options-from (environment-build-options))))
-
- (define (parse-options-from args)
- ;; Actual parsing takes place here.
- (args-fold* args %options
- (lambda (opt name arg result)
- (leave (_ "~A: unrecognized option~%") name))
- (lambda (arg result)
- (alist-cons 'package arg result))
- %default-options))
+ (define (handle-argument arg result)
+ (alist-cons 'package arg result))
(with-store store
- (let* ((opts (parse-options))
+ (let* ((opts (parse-command-line args %options (list %default-options)
+ #:argument-handler handle-argument))
(pure? (assoc-ref opts 'pure))
(command (assoc-ref opts 'exec))
(inputs (packages->transitive-inputs
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index fc116d8f6c..c27207f29a 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -692,22 +692,11 @@ doesn't need it."
;;;
(define (guix-package . args)
- (define (parse-options)
- ;; Return the alist of option values.
- (append (parse-options-from args)
- (parse-options-from (environment-build-options))))
-
- (define (parse-options-from args)
- ;; Actual parsing takes place here.
- (args-fold* args %options
- (lambda (opt name arg result arg-handler)
- (leave (_ "~A: unrecognized option~%") name))
- (lambda (arg result arg-handler)
- (if arg-handler
- (arg-handler arg result)
- (leave (_ "~A: extraneous argument~%") arg)))
- %default-options
- #f))
+ (define (handle-argument arg result arg-handler)
+ ;; Process non-option argument ARG by calling back ARG-HANDLER.
+ (if arg-handler
+ (arg-handler arg result)
+ (leave (_ "~A: extraneous argument~%") arg)))
(define (ensure-default-profile)
;; Ensure the default profile symlink and directory exist and are
@@ -987,7 +976,8 @@ more information.~%"))
(_ #f))))
- (let ((opts (parse-options)))
+ (let ((opts (parse-command-line args %options (list %default-options #f)
+ #:argument-handler handle-argument)))
(with-error-handling
(or (process-query opts)
(parameterize ((%store (open-connection)))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index b15bb8bb0d..1b64e6fb92 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -487,26 +487,15 @@ Build the operating system declared in FILE according to ACTION.\n"))
;;;
(define (guix-system . args)
- (define (parse-options)
- ;; Return the alist of option values.
- (append (parse-options-from args)
- (parse-options-from (environment-build-options))))
-
- (define (parse-options-from args)
- ;; Actual parsing takes place here.
- (args-fold* args %options
- (lambda (opt name arg result)
- (leave (_ "~A: unrecognized option~%") name))
- (lambda (arg result)
- (if (assoc-ref result 'action)
- (alist-cons 'argument arg result)
- (let ((action (string->symbol arg)))
- (case action
- ((build vm vm-image disk-image reconfigure init)
- (alist-cons 'action action result))
- (else (leave (_ "~a: unknown action~%")
- action))))))
- %default-options))
+ (define (parse-sub-command arg result)
+ ;; Parse sub-command ARG and augment RESULT accordingly.
+ (if (assoc-ref result 'action)
+ (alist-cons 'argument arg result)
+ (let ((action (string->symbol arg)))
+ (case action
+ ((build vm vm-image disk-image reconfigure init)
+ (alist-cons 'action action result))
+ (else (leave (_ "~a: unknown action~%") action))))))
(define (match-pair car)
;; Return a procedure that matches a pair with CAR.
@@ -534,7 +523,10 @@ Build the operating system declared in FILE according to ACTION.\n"))
args))
(with-error-handling
- (let* ((opts (parse-options))
+ (let* ((opts (parse-command-line args %options
+ (list %default-options)
+ #:argument-handler
+ parse-sub-command))
(args (option-arguments opts))
(file (first args))
(action (assoc-ref opts 'action))
diff --git a/guix/ui.scm b/guix/ui.scm
index 382b5b1e0d..09cb6f48ff 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -66,7 +66,7 @@
string->generations
string->duration
args-fold*
- environment-build-options
+ parse-command-line
run-guix-command
program-name
guix-warning-port
@@ -754,6 +754,32 @@ reporting."
"Return additional build options passed as environment variables."
(arguments-from-environment-variable "GUIX_BUILD_OPTIONS"))
+(define %default-argument-handler
+ ;; The default handler for non-option command-line arguments.
+ (lambda (arg result)
+ (alist-cons 'argument arg result)))
+
+(define* (parse-command-line args options seeds
+ #:key
+ (argument-handler %default-argument-handler))
+ "Parse the command-line arguments ARGS as well as arguments passed via the
+'GUIX_BUILD_OPTIONS' environment variable according to OPTIONS (a list of
+SRFI-37 options) and return the result, seeded by SEEDS.
+Command-line options take precedence those passed via 'GUIX_BUILD_OPTIONS'.
+
+ARGUMENT-HANDLER is called for non-option arguments, like the 'operand-proc'
+parameter of 'args-fold'."
+ (define (parse-options-from args)
+ ;; Actual parsing takes place here.
+ (apply args-fold* args options
+ (lambda (opt name arg . rest)
+ (leave (_ "~A: unrecognized option~%") name))
+ argument-handler
+ seeds))
+
+ (append (parse-options-from args)
+ (parse-options-from (environment-build-options))))
+
(define (show-guix-usage)
(format (current-error-port)
(_ "Try `guix --help' for more information.~%"))