09/09: guix build: Modularize transformation handling.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 64ec0e291209ea6c0fb98204e7b546479c6ab737
Author: Ludovic Courtès <address@hidden>
Date:   Mon Nov 30 23:07:35 2015 +0200

    guix build: Modularize transformation handling.
    
    * guix/scripts/build.scm (options/resolve-packages): Remove.
    (options->things-to-build, transform-package-source): New procedure.
    (%transformations): New variable.
    (options->transformation): New procedure.
    (options->derivations): Rewrite to use 'options->things-to-build' and
    'options->transformation'.
---
 guix/scripts/build.scm |  207 ++++++++++++++++++++++++++----------------------
 1 files changed, 111 insertions(+), 96 deletions(-)

diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index b415403..192ed5c 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -383,9 +383,40 @@ must be one of 'package', 'all', or 'transitive'~%")
 
          %standard-build-options))
 
+(define (options->things-to-build opts)
+  "Read the arguments from OPTS and return a list of high-level objects to
+build---packages, gexps, derivations, and so on."
+  (define ensure-list
+    (match-lambda
+      ((x ...) x)
+      (x       (list x))))
+
+  (append-map (match-lambda
+                (('argument . (? string? spec))
+                 (cond ((derivation-path? spec)
+                        (list (call-with-input-file spec read-derivation)))
+                       ((store-path? spec)
+                        ;; Nothing to do; maybe for --log-file.
+                        '())
+                       (else
+                        (list (specification->package spec)))))
+                (('file . file)
+                 (ensure-list (load* file (make-user-module '()))))
+                (('expression . str)
+                 (ensure-list (read/eval str)))
+                (('argument . (? derivation? drv))
+                 drv)
+                (('argument . (? derivation-path? drv))
+                 (list ))
+                (_ '()))
+              opts))
+
 (define (options->derivations store opts)
   "Given OPTS, the result of 'args-fold', return a list of derivations to
 build."
+  (define transform
+    (options->transformation opts))
+
   (define package->derivation
     (match (assoc-ref opts 'target)
       (#f package-derivation)
@@ -393,106 +424,90 @@ build."
        (cut package-cross-derivation <> <> triplet <>))))
 
   (define src    (assoc-ref opts 'source))
-  (define sys    (assoc-ref opts 'system))
+  (define system (assoc-ref opts 'system))
   (define graft? (assoc-ref opts 'graft?))
 
   (parameterize ((%graft? graft?))
-    (let ((opts (options/with-source store
-                                     (options/resolve-packages store opts))))
-      (concatenate
-       (filter-map (match-lambda
-                    (('argument . (? package? p))
-                     (match src
-                       (#f
-                        (list (package->derivation store p sys)))
-                       (#t
-                        (let ((s (package-source p)))
-                          (list (package-source-derivation store s))))
-                       (proc
-                        (map (cut package-source-derivation store <>)
-                             (proc p)))))
-                    (('argument . (? derivation? drv))
-                     (list drv))
-                    (('argument . (? derivation-path? drv))
-                     (list (call-with-input-file drv read-derivation)))
-                    (('argument . (? store-path?))
-                     ;; Nothing to do; maybe for --log-file.
-                     #f)
-                    (_ #f))
-                   opts)))))
-
-(define (options/resolve-packages store opts)
-  "Return OPTS with package specification strings replaced by actual
-packages."
-  (define system
-    (or (assoc-ref opts 'system) (%current-system)))
-
-  (define (object->argument obj)
-    (match obj
-      ((? package? p)
-       `(argument . ,p))
-      ((? procedure? proc)
-       (let ((drv (run-with-store store
-                    (mbegin %store-monad
-                      (set-guile-for-build (default-guile))
-                      (proc))
-                    #:system system)))
-         `(argument . ,drv)))
-      ((? gexp? gexp)
-       (let ((drv (run-with-store store
-                    (mbegin %store-monad
-                      (set-guile-for-build (default-guile))
-                      (gexp->derivation "gexp" gexp
-                                        #:system system)))))
-         `(argument . ,drv)))))
-
-  (map (match-lambda
-        (('argument . (? string? spec))
-         (if (store-path? spec)
-             `(argument . ,spec)
-             `(argument . ,(specification->package spec))))
-        (('file . file)
-         (object->argument (load* file (make-user-module '()))))
-        (('expression . str)
-         (object->argument (read/eval str)))
-        (opt opt))
-       opts))
-
-(define (options/with-source store opts)
-  "Process with 'with-source' options in OPTS, replacing the relevant package
-arguments with packages that use the specified source."
+    (append-map (match-lambda
+                  ((? package? p)
+                   (match src
+                     (#f
+                      (list (package->derivation store p system)))
+                     (#t
+                      (let ((s (package-source p)))
+                        (list (package-source-derivation store s))))
+                     (proc
+                      (map (cut package-source-derivation store <>)
+                           (proc p)))))
+                  ((? derivation? drv)
+                   (list drv))
+                  ((? procedure? proc)
+                   (list (run-with-store store
+                           (mbegin %store-monad
+                             (set-guile-for-build (default-guile))
+                             (proc))
+                           #:system system)))
+                  ((? gexp? gexp)
+                   (list (run-with-store store
+                           (mbegin %store-monad
+                             (set-guile-for-build (default-guile))
+                             (gexp->derivation "gexp" gexp
+                                               #:system system))))))
+                (transform store (options->things-to-build opts)))))
+
+(define (transform-package-source sources)
+  "Return a transformation procedure that uses replaces package sources with
+the matching URIs given in SOURCES."
   (define new-sources
-    (filter-map (match-lambda
-                 (('with-source . uri)
-                  (cons (package-name->name+version (basename uri))
-                        uri))
-                 (_ #f))
-                opts))
-
-  (let loop ((opts    opts)
-             (sources new-sources)
-             (result  '()))
-    (match opts
-      (()
-       (unless (null? sources)
-         (warning (_ "sources do not match any package:~{ ~a~}~%")
-                  (match sources
-                    (((name . uri) ...)
-                     uri))))
-       (reverse result))
-      ((('argument . (? package? p)) tail ...)
-       (let ((source (assoc-ref sources (package-name p))))
-         (loop tail
-               (alist-delete (package-name p) sources)
-               (alist-cons 'argument
-                           (if source
-                               (package-with-source store p source)
-                               p)
-                           result))))
-      ((('with-source . _) tail ...)
-       (loop tail sources result))
-      ((head tail ...)
-       (loop tail sources (cons head result))))))
+    (map (lambda (uri)
+           (cons (package-name->name+version (basename uri))
+                 uri))
+         sources))
+
+  (lambda (store packages)
+    (let loop ((packages packages)
+               (sources  new-sources)
+               (result   '()))
+      (match packages
+        (()
+         (unless (null? sources)
+           (warning (_ "sources do not match any package:~{ ~a~}~%")
+                    (match sources
+                      (((name . uri) ...)
+                       uri))))
+         (reverse result))
+        (((? package? p) tail ...)
+         (let ((source (assoc-ref sources (package-name p))))
+           (loop tail
+                 (alist-delete (package-name p) sources)
+                 (cons (if source
+                           (package-with-source store p source)
+                           p)
+                       result))))
+        ((thing tail ...)
+         (loop tail sources result))))))
+
+(define %transformations
+  ;; Transformations that can be applied to things to build.  The car is the
+  ;; key used in the option alist, and the cdr is the transformation
+  ;; procedure; it is called with two arguments: the store, and a list of
+  ;; things to build.
+  `((with-source . ,transform-package-source)))
+
+(define (options->transformation opts)
+  "Return a procedure that, when passed a list of things to build (packages,
+derivations, etc.), applies the transformations specified by OPTS."
+  (apply compose
+         (map (match-lambda
+                ((key . transform)
+                 (let ((args (filter-map (match-lambda
+                                           ((k . arg)
+                                            (and (eq? k key) arg)))
+                                         opts)))
+                   (if (null? args)
+                       (lambda (store things) things)
+                       (transform args)))))
+              %transformations)))
 
 (define (show-build-log store file urls)
   "Show the build log for FILE, falling back to remote logs from URLS if