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

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit aa72d9afdfe2d65e73c426c280667323181ae592
Author: Ludovic Courtès <address@hidden>
Date:   Fri Feb 13 17:23:17 2015 +0100

    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.
---
 guix/derivations.scm  |   19 ++----
 guix/gexp.scm         |  158 ++++++++++++++++++++++++++++++++++++++++++++++++-
 tests/derivations.scm |   17 -----
 tests/gexp.scm        |   34 +++++++++++
 4 files changed, 195 insertions(+), 33 deletions(-)

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 678550a..e592236 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 fa712a8..0620683 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.
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 80aabad..e23bdee 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -670,23 +670,6 @@
          (let ((p (derivation->output-path drv)))
            (string-contains (call-with-input-file p read-line) "GNU")))))
 
-(test-assert "imported-files"
-  (let* ((files    `(("x"     . ,(search-path %load-path "ice-9/q.scm"))
-                     ("a/b/c" . ,(search-path %load-path
-                                              "guix/derivations.scm"))
-                     ("p/q"   . ,(search-path %load-path "guix.scm"))
-                     ("p/z"   . ,(search-path %load-path "guix/store.scm"))))
-         (drv      (imported-files %store files)))
-    (and (build-derivations %store (list drv))
-         (let ((dir (derivation->output-path drv)))
-           (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-assert "build-expression->derivation with modules"
   (let* ((builder  `(begin
                       (use-modules (guix build utils))
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 03722e4..68c470d 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -360,6 +360,40 @@
                      (string=? (readlink (string-append out "/" two "/one"))
                                one)))))))
 
+(test-assertm "imported-files"
+  (mlet* %store-monad
+      ((files -> `(("x"     . ,(search-path %load-path "ice-9/q.scm"))
+                   ("a/b/c" . ,(search-path %load-path
+                                            "guix/derivations.scm"))
+                   ("p/q"   . ,(search-path %load-path "guix.scm"))
+                   ("p/z"   . ,(search-path %load-path "guix/store.scm"))))
+       (drv (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))))))
+
+(test-assertm "gexp->derivation #:modules"
+  (mlet* %store-monad
+      ((build ->  #~(begin
+                      (use-modules (guix build utils))
+                      (mkdir-p (string-append #$output "/guile/guix/nix"))
+                      #t))
+       (drv       (gexp->derivation "test-with-modules" build
+                                    #:modules '((guix build utils)))))
+    (mbegin %store-monad
+      (built-derivations (list drv))
+      (let* ((p (derivation->output-path drv))
+             (s (stat (string-append p "/guile/guix/nix"))))
+        (return (eq? (stat:type s) 'directory))))))
+
 (test-assertm "gexp->derivation #:references-graphs"
   (mlet* %store-monad
       ((one (text-file "one" "hello, world"))