gexp: 'imported-files' no longer creates a derivation by default.

* guix/gexp.scm (gexp->derivation): Add #:import-creates-derivation?.
Pass #:derivation? to 'imported-modules' and 'compiled-modules'.  In -L
argument, check whether MODULES is a derivation.
(%not-slash): New variable.
(file-mapping->tree): New procedure.
(imported-files): Rename to...
(imported-files/derivation): ... this.
(imported-files): New procedure.  Rewrite in terms of
'interned-file-tree' when possible; add #:derivation? parameter.
(imported-modules, compiled-modules): Add #:derivation? parameter and
pass it to 'imported-files'.
* guix/packages.scm (patch-and-repack): Pass
 #:import-creates-derivation? to 'gexp->derivation'.
* tests/gexp.scm ("imported-files"): Adjust to no longer expect a
derivation.

3 files changed, 115 insertions, 25 deletions

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 3414b81dc6..19d90f5eee 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -601,6 +601,12 @@ names and file names suitable for the #:allowed-references argument to
                            allowed-references disallowed-references
                            leaked-env-vars
                            local-build? (substitutable? #t)
+
+                           ;; TODO: This parameter is transitional; it's here
+                           ;; to avoid a full rebuild.  Remove it on the next
+                           ;; rebuild cycle.
+                           import-creates-derivation?
+
                            deprecation-warnings
                            (script-name (string-append name "-builder")))
   "Return a derivation NAME that runs EXP (a gexp) with GUILE-FOR-BUILD (a
@@ -695,6 +701,8 @@ The other arguments are as for 'derivation'."
                                        extensions))
                        (modules  (if (pair? %modules)
                                      (imported-modules %modules
+                                                       #:derivation?
+                                                       import-creates-derivation?
                                                        #:system system
                                                        #:module-path module-path
                                                        #:guile guile-for-build
@@ -703,6 +711,8 @@ The other arguments are as for 'derivation'."
                                      (return #f)))
                        (compiled (if (pair? %modules)
                                      (compiled-modules %modules
+                                                       #:derivation?
+                                                       import-creates-derivation?
                                                        #:system system
                                                        #:module-path module-path
                                                        #:extensions extensions
@@ -735,7 +745,9 @@ The other arguments are as for 'derivation'."
                                      "/bin/guile")
                       `("--no-auto-compile"
                         ,@(if (pair? %modules)
-                              `("-L" ,(derivation->output-path modules)
+                              `("-L" ,(if (derivation? modules)
+                                          (derivation->output-path modules)
+                                          modules)
                                 "-C" ,(derivation->output-path compiled))
                               '())
                         ,@(append-map extension-flags exts)
@@ -1013,6 +1025,49 @@ execution environment."
 ;;; Module handling.
 ;;;
 
+(define %not-slash
+  (char-set-complement (char-set #\/)))
+
+(define (file-mapping->tree mapping)
+  "Convert MAPPING, an alist like:
+
+  ((\"guix/build/utils.scm\" . \"…/utils.scm\"))
+
+to a tree suitable for 'interned-file-tree'."
+  (let ((mapping (map (match-lambda
+                        ((destination . source)
+                         (cons (string-tokenize destination
+                                                %not-slash)
+                               source)))
+                      mapping)))
+    (fold (lambda (pair result)
+            (match pair
+              ((destination . source)
+               (let loop ((destination destination)
+                          (result result))
+                 (match destination
+                   ((file)
+                    (let* ((mode (stat:mode (stat source)))
+                           (type (if (zero? (logand mode #o100))
+                                     'regular
+                                     'executable)))
+                      (alist-cons file
+                                  `(,type (file ,source))
+                                  result)))
+                   ((file rest ...)
+                    (let ((directory (assoc-ref result file)))
+                      (alist-cons file
+                                  `(directory
+                                    ,@(loop rest
+                                            (match directory
+                                              (('directory . entries) entries)
+                                              (#f '()))))
+                                  (if directory
+                                      (alist-delete file result)
+                                      result)))))))))
+          '()
+          mapping)))
+
 (define %utils-module
   ;; This file provides 'mkdir-p', needed to implement 'imported-files' and
   ;; other primitives below.  Note: We give the file name relative to this
@@ -1021,18 +1076,18 @@ execution environment."
   (local-file "build/utils.scm"
               "build-utils.scm"))
 
-(define* (imported-files files
-                         #:key (name "file-import")
-                         (system (%current-system))
-                         (guile (%guile-for-build))
-
-                         ;; XXX: The only reason we have
-                         ;; #:deprecation-warnings is because (guix build
-                         ;; utils), which we use here, relies on _IO*, which
-                         ;; is deprecated in 2.2.  On the next full-rebuild
-                         ;; cycle, we should disable such warnings
-                         ;; unconditionally.
-                         (deprecation-warnings #f))
+(define* (imported-files/derivation files
+                                    #:key (name "file-import")
+                                    (system (%current-system))
+                                    (guile (%guile-for-build))
+
+                                    ;; XXX: The only reason we have
+                                    ;; #:deprecation-warnings is because (guix
+                                    ;; build utils), which we use here, relies
+                                    ;; on _IO*, which is deprecated in 2.2.  On
+                                    ;; the next full-rebuild cycle, we should
+                                    ;; disable such warnings unconditionally.
+                                    (deprecation-warnings #f))
   "Return a derivation that imports FILES into STORE.  FILES must be a list
 of (FINAL-PATH . FILE) pairs.  Each FILE is mapped to FINAL-PATH in the
 resulting store path.  FILE can be either a file name, or a file-like object,
@@ -1081,8 +1136,38 @@ as returned by 'local-file' for example."
                         (else
                          '())))))
 
+(define* (imported-files files
+                         #:key (name "file-import")
+
+                         ;; TODO: Remove this parameter on the next rebuild
+                         ;; cycle.
+                         (derivation? #f)
+
+                         ;; The following parameters make sense when creating
+                         ;; an actual derivation.
+                         (system (%current-system))
+                         (guile (%guile-for-build))
+                         (deprecation-warnings #f))
+  "Import FILES into the store and return the resulting derivation or store
+file name (a derivation is created if and only if some elements of FILES are
+file-like objects and not local file names.)  FILES must be a list
+of (FINAL-PATH . FILE) pairs.  Each FILE is mapped to FINAL-PATH in the
+resulting store path.  FILE can be either a file name, or a file-like object,
+as returned by 'local-file' for example."
+  (if (or derivation?
+          (any (match-lambda
+                 ((_ . (? struct? source)) #t)
+                 (_ #f))
+               files))
+      (imported-files/derivation files #:name name
+                                 #:system system #:guile guile
+                                 #:deprecation-warnings deprecation-warnings)
+      (interned-file-tree `(,name directory
+                                  ,@(file-mapping->tree files)))))
+
 (define* (imported-modules modules
                            #:key (name "module-import")
+                           (derivation? #f)      ;TODO: remove on next rebuild
                            (system (%current-system))
                            (guile (%guile-for-build))
                            (module-path %load-path)
@@ -1106,12 +1191,15 @@ last one is created from the given <scheme-file> object."
                        (let ((f (module->source-file-name module)))
                          (cons f (search-path* module-path f)))))
                     modules)))
-    (imported-files files #:name name #:system system
+    (imported-files files #:name name
+                    #:derivation? derivation?
+                    #:system system
                     #:guile guile
                     #:deprecation-warnings deprecation-warnings)))
 
 (define* (compiled-modules modules
                            #:key (name "module-import-compiled")
+                           (derivation? #f)      ;TODO: remove on next rebuild
                            (system (%current-system))
                            (guile (%guile-for-build))
                            (module-path %load-path)
@@ -1131,6 +1219,7 @@ they can refer to each other."
          (not (equal? module-path %load-path))))
 
   (mlet %store-monad ((modules (imported-modules modules
+                                                 #:derivation? derivation?
                                                  #:system system
                                                  #:guile guile
                                                  #:module-path
diff --git a/guix/packages.scm b/guix/packages.scm
index c762fa7c39..a220b9c476 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -646,6 +646,9 @@ specifies modules in scope when evaluating SNIPPET."
 
     (let ((name (tarxz-name original-file-name)))
       (gexp->derivation name build
+                        ;; TODO: Remove this on the next rebuild cycle.
+                        #:import-creates-derivation? #t
+
                         #:graft? #f
                         #:system system
                         #:deprecation-warnings #t ;to avoid a rebuild
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 391a0f8be5..c89d0c4855 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -635,18 +635,16 @@
                                             "guix/derivations.scm"))
                    ("p/q"   . ,(search-path %load-path "guix.scm"))
                    ("p/z"   . ,(search-path %load-path "guix/store.scm"))))
-       (drv (imported-files files)))
+       (dir (imported-files files)))
     (mbegin %store-monad
-      (built-derivations (list drv))
-      (let ((dir (derivation->output-path drv)))
-        (return
-         (every (match-lambda
-                 ((path . source)
-                  (equal? (call-with-input-file (string-append dir "/" path)
-                            get-bytevector-all)
-                          (call-with-input-file source
-                            get-bytevector-all))))
-                files))))))
+      (return
+       (every (match-lambda
+                ((path . source)
+                 (equal? (call-with-input-file (string-append dir "/" path)
+                           get-bytevector-all)
+                         (call-with-input-file source
+                           get-bytevector-all))))
+              files)))))
 
 (test-assertm "imported-files with file-like objects"
   (mlet* %store-monad ((plain -> (plain-file "foo" "bar!"))