build-system: Rewrite using gexps.

* guix/packages.scm (expand-input): Remove 'store', 'system', and
  'cross-system' parameters; add #:native?.  Rewrite to return
  name/gexp-input tuples.
  (bag->derivation): Adjust accordingly.  Lower (bag-build bag).
  (bag->cross-derivation): Ditto.  Instead of #:native-drvs and
  #:target-drvs, pass #:build-inputs, #:host-inputs, and #:target-inputs.
  (%derivation-cache): Remove.
* gnu/packages/bootstrap.scm (raw-build): Turn into a monadic procedure.
* gnu/packages/commencement.scm (glibc-final)[arguments]: Use
  'gexp-input' for the #:allowed-references argument.
* guix/build-system/cmake.scm (cmake-build): Remove 'store' parameter.
  Switch to the use of gexps and 'gexp->derivation'.
  (lower): Remove #:source from 'private-keywords'.
* guix/build-system/glib-or-gtk.scm (glib-or-gtk-build, lower):
  Likewise.
* guix/build-system/font.scm (font-build): Likewise.
* guix/build-system/gnu.scm (gnu-build): Likewise, and remove
  'canonicalize-reference'.
  (gnu-cross-build): Likewise, and expect #:build-inputs, #:host-inputs,
  and #:target-inputs instead of #:native-drvs and #:target-drvs.
  (lower): Likewise.
* guix/build-system/perl.scm (perl-build, lower): Likewise.
* guix/build-system/python.scm (python-build, lower): Likewise.
* guix/build-system/ruby.scm (ruby-build, lower): Likewise.
* guix/build-system/waf.scm (waf-build, lower): Likewise.
* guix/build-system/trivial.scm (guile-for-build): Remove.
  (trivial-build): Remove 'store' parameter, change to gexps.
  (trivial-cross-build): Ditto, and change to #:build-inputs & co.
* guix/build-system/cargo.scm (cargo-build): Change to 'gexp->derivation'.
* guix/build-system/copy.scm (copy-build): Likewise.
* guix/build-system/dune.scm (dune-build): Likewise.
* guix/build-system/guile.scm (guile-build, guile-cross-build):
  Likewise.
* guix/build-system/meson.scm (meson-build): Likewise.
* guix/build-system/ocaml.scm (ocaml-build): Likewise.
* guix/build-system/scons.scm (scons-build): Likewise.
* guix/build-system/texlive.scm (texlive-build): Likewise.
* guix/build-system/android-ndk.scm (android-ndk-build): Likewise.
* guix/build-system/ant.scm (ant-build): Likewise.
* guix/build-system/asdf.scm (asdf-build/source, asdf-build): Likewise.
* guix/build-system/chicken.scm (chicken-build): Likewise.
* guix/build-system/clojure.scm (clojure-build): Likewise.
(source->output-path, maybe-guile->guile): Remove.
* guix/build-system/dub.scm (dub-build): Likewise.
* guix/build-system/emacs.scm (emacs-build): Likewise.
* guix/build-system/go.scm (go-build): Likewise.
* guix/build-system/haskell.scm (haskell-build): Likewise.
* guix/build-system/julia.scm (julia-build): Likewise.
* guix/build-system/linux-module.scm (linux-module-build)
(linux-module-build-cross): Likewise.
* guix/build-system/maven.scm (maven-build): Likewise.
* guix/build-system/minify.scm (minify-build): Likewise.
* guix/build-system/node.scm (node-build): Likewise.
* guix/build-system/qt.scm (qt-build, qt-cross-build): Likewise.
* guix/build-system/r.scm (r-build): Likewise.
* guix/build-system/rakudo.scm (rakudo-build): Likewise.
* guix/build-system/renpy.scm (renpy-build): Likewise.
* tests/builders.scm ("gnu-build"): Call 'store-lower' on 'gnu-build'.
  Pass #:source parameter.
* tests/packages.scm ("search paths"): Use 'abort-to-prompt' instead of
  a normal return from the 'build' method.
  ("package->bag, sensitivity to %current-target-system"): Change 'build'
  to match the new build system signature.

squash! build-system: Rewrite using gexps.

squash! build-system: Rewrite using gexps.

1 files changed, 29 insertions, 48 deletions

diff --git a/guix/packages.scm b/guix/packages.scm
index 56173e1204..6dc652fe7a 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1174,10 +1174,6 @@ matching package and returns a replacement for that package."
 ;;; Package derivations.
 ;;;
 
-(define %derivation-cache
-  ;; Package to derivation-path mapping.
-  (make-weak-key-hash-table 100))
-
 (define (cache! cache package system thunk)
   "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on
 SYSTEM."
@@ -1209,48 +1205,29 @@ Return the cached result when available."
     ((_ package system body ...)
      (cached (=> %derivation-cache) package system body ...))))
 
-(define* (expand-input store package input system #:optional cross-system)
-  "Expand INPUT, an input tuple, such that it contains only references to
-derivation paths or store paths.  PACKAGE is only used to provide contextual
-information in exceptions."
-  (define (intern file)
-    ;; Add FILE to the store.  Set the `recursive?' bit to #t, so that
-    ;; file permissions are preserved.
-    (add-to-store store (basename file) #t "sha256" file))
-
-  (define derivation
-    (if cross-system
-        (cut package-cross-derivation store <> cross-system system
-             #:graft? #f)
-        (cut package-derivation store <> system #:graft? #f)))
+(define* (expand-input package input #:key native?)
+  "Expand INPUT, an input tuple, to a name/<gexp-input> tuple.  PACKAGE is
+only used to provide contextual information in exceptions."
+  (define (valid? x)
+    (or (package? x) (origin? x) (derivation? x)))
 
   (match input
-    (((? string? name) (? package? package))
-     (list name (derivation package)))
-    (((? string? name) (? package? package)
-      (? string? sub-drv))
-     (list name (derivation package)
-           sub-drv))
-    (((? string? name)
-      (and (? string?) (? derivation-path?) drv))
-     (list name drv))
+    (((? string? name) (? valid? thing))
+     (list name (gexp-input thing #:native? native?)))
+    (((? string? name) (? valid? thing) (? string? output))
+     (list name (gexp-input thing output #:native? native?)))
     (((? string? name)
       (and (? string?) (? file-exists? file)))
      ;; Add FILE to the store.  When FILE is in the sub-directory of a
      ;; store path, it needs to be added anyway, so it can be used as a
      ;; source.
-     (list name (intern file)))
+     (list name (gexp-input (local-file file #:recursive? #t)
+                            #:native? native?)))
     (((? string? name) (? struct? source))
      ;; 'package-source-derivation' calls 'lower-object', which can throw
      ;; '&gexp-input-error'.  However '&gexp-input-error' lacks source
-     ;; location info, so we catch and rethrow here (XXX: not optimal
-     ;; performance-wise).
-     (guard (c ((gexp-input-error? c)
-                (raise (condition
-                        (&package-input-error
-                         (package package)
-                         (input   (gexp-error-invalid-input c)))))))
-       (list name (package-source-derivation store source system))))
+     ;; location info, so we used to catch and rethrow here (FIXME!).
+     (list name (gexp-input source)))
     (x
      (raise (condition (&package-input-error
                         (package package)
@@ -1434,12 +1411,14 @@ TARGET."
 (define (input=? input1 input2)
   "Return true if INPUT1 and INPUT2 are equivalent."
   (match input1
-    ((label1 drv1 . outputs1)
+    ((label1 obj1 . outputs1)
      (match input2
-       ((label2 drv2 . outputs2)
+       ((label2 obj2 . outputs2)
         (and (string=? label1 label2)
              (equal? outputs1 outputs2)
-             (derivation=? drv1 drv2)))))))
+             (or (and (derivation? obj1) (derivation? obj2)
+                      (derivation=? obj1 obj2))
+                 (equal? obj1 obj2))))))))
 
 (define* (bag->derivation store bag
                           #:optional context)
@@ -1450,7 +1429,7 @@ error reporting."
       (bag->cross-derivation store bag)
       (let* ((system     (bag-system bag))
              (inputs     (bag-transitive-inputs bag))
-             (input-drvs (map (cut expand-input store context <> system)
+             (input-drvs (map (cut expand-input context <> #:native? #t)
                               inputs))
              (paths      (delete-duplicates
                           (append-map (match-lambda
@@ -1462,7 +1441,8 @@ error reporting."
         ;; It's possible that INPUTS contains packages that are not 'eq?' but
         ;; that lead to the same derivation.  Delete those duplicates to avoid
         ;; issues down the road, such as duplicate entries in '%build-inputs'.
-        (apply (bag-build bag)
+        ;; TODO: Change to monadic style.
+        (apply (store-lower (bag-build bag))
                store (bag-name bag)
                (delete-duplicates input-drvs input=?)
                #:search-paths paths
@@ -1477,13 +1457,13 @@ This is an internal procedure."
   (let* ((system      (bag-system bag))
          (target      (bag-target bag))
          (host        (bag-transitive-host-inputs bag))
-         (host-drvs   (map (cut expand-input store context <> system target)
+         (host-drvs   (map (cut expand-input context <> #:native? #f)
                            host))
          (target*     (bag-transitive-target-inputs bag))
-         (target-drvs (map (cut expand-input store context <> system)
+         (target-drvs (map (cut expand-input context <> #:native? #t)
                            target*))
          (build       (bag-transitive-build-inputs bag))
-         (build-drvs  (map (cut expand-input store context <> system)
+         (build-drvs  (map (cut expand-input context <> #:native? #t)
                            build))
          (all         (append build target* host))
          (paths       (delete-duplicates
@@ -1500,11 +1480,12 @@ This is an internal procedure."
                                     (_ '()))
                                    all))))
 
-    (apply (bag-build bag)
+    ;; TODO: Change to monadic style.
+    (apply (store-lower (bag-build bag))
            store (bag-name bag)
-           #:native-drvs (delete-duplicates build-drvs input=?)
-           #:target-drvs (delete-duplicates (append host-drvs target-drvs)
-                                            input=?)
+           #:build-inputs (delete-duplicates build-drvs input=?)
+           #:host-inputs (delete-duplicates host-drvs input=?)
+           #:target-inputs (delete-duplicates target-drvs input=?)
            #:search-paths paths
            #:native-search-paths npaths
            #:outputs (bag-outputs bag)