gexp: Implement 'imported-modules' & co. using 'gexp->derivation'.

* guix/derivations.scm (imported-files): Keep private.
  (%imported-modules, %compiled-modules, build-expression->derivation):
  Mark as deprecated.
  (imported-modules, compiled-modules): Remove.
* guix/gexp.scm (%mkdir-p-definition): New variable.
  (imported-files, search-path*, imported-modules, compiled-modules):
  New procedures.
* tests/derivations.scm ("imported-files"): Remove.
* tests/gexp.scm ("imported-files", "gexp->derivation #:modules"): New
  tests.

2 files changed, 161 insertions, 16 deletions

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 678550a39e..e5922365a0 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -96,11 +96,8 @@
 
             build-derivations
             built-derivations
-            imported-modules
-            compiled-modules
 
-            build-expression->derivation
-            imported-files)
+            build-expression->derivation)
 
   ;; Re-export it from here for backward compatibility.
   #:re-export (%guile-for-build))
@@ -942,7 +939,7 @@ recursively."
            (remove (cut string=? <> ".")
                    (string-tokenize (dirname file-name) not-slash))))))
 
-(define* (imported-files store files
+(define* (imported-files store files              ;deprecated
                          #:key (name "file-import")
                          (system (%current-system))
                          (guile (%guile-for-build)))
@@ -982,7 +979,7 @@ system, imported, and appears under FINAL-PATH in the resulting store path."
   ;; up looking for the same files over and over again.
   (memoize search-path))
 
-(define* (%imported-modules store modules
+(define* (%imported-modules store modules         ;deprecated
                             #:key (name "module-import")
                             (system (%current-system))
                             (guile (%guile-for-build))
@@ -1001,7 +998,7 @@ search path."
     (imported-files store files #:name name #:system system
                     #:guile guile)))
 
-(define* (%compiled-modules store modules
+(define* (%compiled-modules store modules         ;deprecated
                             #:key (name "module-import-compiled")
                             (system (%current-system))
                             (guile (%guile-for-build))
@@ -1124,7 +1121,7 @@ applied."
                                      #:outputs output-names
                                      #:local-build? #t)))))
 
-(define* (build-expression->derivation store name exp
+(define* (build-expression->derivation store name exp ;deprecated
                                        #:key
                                        (system (%current-system))
                                        (inputs '())
@@ -1290,9 +1287,3 @@ ALLOWED-REFERENCES, and LOCAL-BUILD?."
 
 (define built-derivations
   (store-lift build-derivations))
-
-(define imported-modules
-  (store-lift %imported-modules))
-
-(define compiled-modules
-  (store-lift %compiled-modules))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index fa712a8b9b..0620683078 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -21,6 +21,7 @@
   #:use-module (guix monads)
   #:use-module (guix derivations)
   #:use-module (guix packages)
+  #:use-module (guix utils)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
@@ -31,7 +32,10 @@
             gexp->derivation
             gexp->file
             gexp->script
-            text-file*))
+            text-file*
+            imported-files
+            imported-modules
+            compiled-modules))
 
 ;;; Commentary:
 ;;;
@@ -502,6 +506,157 @@ package/derivation references."
 
 
 ;;;
+;;; Module handling.
+;;;
+
+(define %mkdir-p-definition
+  ;; The code for 'mkdir-p' is copied from (guix build utils).  We use it in
+  ;; derivations that cannot use the #:modules argument of 'gexp->derivation'
+  ;; precisely because they implement that functionality.
+  (gexp
+   (define (mkdir-p dir)
+     (define absolute?
+       (string-prefix? "/" dir))
+
+     (define not-slash
+       (char-set-complement (char-set #\/)))
+
+     (let loop ((components (string-tokenize dir not-slash))
+                (root       (if absolute? "" ".")))
+       (match components
+         ((head tail ...)
+          (let ((path (string-append root "/" head)))
+            (catch 'system-error
+              (lambda ()
+                (mkdir path)
+                (loop tail path))
+              (lambda args
+                (if (= EEXIST (system-error-errno args))
+                    (loop tail path)
+                    (apply throw args))))))
+         (() #t))))))
+
+(define* (imported-files files
+                         #:key (name "file-import")
+                         (system (%current-system))
+                         (guile (%guile-for-build)))
+  "Return a derivation that imports FILES into STORE.  FILES must be a list
+of (FINAL-PATH . FILE-NAME) pairs; each FILE-NAME is read from the file
+system, imported, and appears under FINAL-PATH in the resulting store path."
+  (define file-pair
+    (match-lambda
+     ((final-path . file-name)
+      (mlet %store-monad ((file (interned-file file-name
+                                               (basename final-path))))
+        (return (list final-path file))))))
+
+  (mlet %store-monad ((files (sequence %store-monad
+                                       (map file-pair files))))
+    (define build
+      (gexp
+       (begin
+         (use-modules (ice-9 match))
+
+         (ungexp %mkdir-p-definition)
+
+         (mkdir (ungexp output)) (chdir (ungexp output))
+         (for-each (match-lambda
+                    ((final-path store-path)
+                     (mkdir-p (dirname final-path))
+                     (symlink store-path final-path)))
+                   '(ungexp files)))))
+
+    ;; TODO: Pass FILES as an environment variable so that BUILD remains
+    ;; exactly the same regardless of FILES: less disk space, and fewer
+    ;; 'add-to-store' RPCs.
+    (gexp->derivation name build
+                      #:system system
+                      #:guile-for-build guile
+                      #:local-build? #t)))
+
+(define search-path*
+  ;; A memoizing version of 'search-path' so 'imported-modules' does not end
+  ;; up looking for the same files over and over again.
+  (memoize search-path))
+
+(define* (imported-modules modules
+                           #:key (name "module-import")
+                           (system (%current-system))
+                           (guile (%guile-for-build))
+                           (module-path %load-path))
+  "Return a derivation that contains the source files of MODULES, a list of
+module names such as `(ice-9 q)'.  All of MODULES must be in the MODULE-PATH
+search path."
+  ;; TODO: Determine the closure of MODULES, build the `.go' files,
+  ;; canonicalize the source files through read/write, etc.
+  (let ((files (map (lambda (m)
+                      (let ((f (string-append
+                                (string-join (map symbol->string m) "/")
+                                ".scm")))
+                        (cons f (search-path* module-path f))))
+                    modules)))
+    (imported-files files #:name name #:system system
+                    #:guile guile)))
+
+(define* (compiled-modules modules
+                           #:key (name "module-import-compiled")
+                           (system (%current-system))
+                           (guile (%guile-for-build))
+                           (module-path %load-path))
+  "Return a derivation that builds a tree containing the `.go' files
+corresponding to MODULES.  All the MODULES are built in a context where
+they can refer to each other."
+  (mlet %store-monad ((modules (imported-modules modules
+                                                 #:system system
+                                                 #:guile guile
+                                                 #:module-path
+                                                 module-path)))
+    (define build
+      (gexp
+       (begin
+         (use-modules (ice-9 ftw)
+                      (ice-9 match)
+                      (srfi srfi-26)
+                      (system base compile))
+
+         (ungexp %mkdir-p-definition)
+
+         (define (regular? file)
+           (not (member file '("." ".."))))
+
+         (define (process-directory directory output)
+           (let ((entries (map (cut string-append directory "/" <>)
+                               (scandir directory regular?))))
+             (for-each (lambda (entry)
+                         (if (file-is-directory? entry)
+                             (let ((output (string-append output "/"
+                                                          (basename entry))))
+                               (mkdir-p output)
+                               (process-directory entry output))
+                             (let* ((base   (string-drop-right
+                                             (basename entry)
+                                             4)) ;.scm
+                                    (output (string-append output "/" base
+                                                           ".go")))
+                               (compile-file entry
+                                             #:output-file output
+                                             #:opts
+                                             %auto-compilation-options))))
+                       entries)))
+
+         (set! %load-path (cons (ungexp modules) %load-path))
+         (mkdir (ungexp output))
+         (chdir (ungexp modules))
+         (process-directory "." (ungexp output)))))
+
+    ;; TODO: Pass MODULES as an environment variable.
+    (gexp->derivation name build
+                      #:system system
+                      #:guile-for-build guile
+                      #:local-build? #t)))
+
+
+;;;
 ;;; Convenience procedures.
 ;;;
 
@@ -562,7 +717,6 @@ and store file names; the resulting store file holds references to all these."
 
   (gexp->derivation name builder))
 
-
 
 ;;;
 ;;; Syntactic sugar.