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.

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.~%"))