From aa72d9afdfe2d65e73c426c280667323181ae592 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Feb 2015 17:23:17 +0100 Subject: 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/gexp.scm | 158 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 156 insertions(+), 2 deletions(-) (limited to 'guix/gexp.scm') 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: ;;; @@ -500,6 +504,157 @@ package/derivation references." (lambda #,formals #,sexp))))))) + +;;; +;;; 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. -- cgit v1.2.3 From ce45eb4c385e3b473bc6746a8b58452865f69977 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 13 Feb 2015 23:14:05 +0100 Subject: gexp: Add #:graft? parameter to 'gexp->derivation'. * guix/gexp.scm (gexp->derivation): Add #:graft? parameter and honor it. * tests/gexp.scm ("gexp->derivation vs. grafts"): New test. * doc/guix.texi (G-Expressions): Update 'gexp->derivation' documentation. --- doc/guix.texi | 11 +++++++---- guix/gexp.scm | 62 ++++++++++++++++++++++++++++++++-------------------------- tests/gexp.scm | 17 ++++++++++++++++ 3 files changed, 58 insertions(+), 32 deletions(-) (limited to 'guix/gexp.scm') diff --git a/doc/guix.texi b/doc/guix.texi index 04b9b4aaae..50a7084fec 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2580,7 +2580,7 @@ below allow you to do that (@pxref{The Store Monad}, for more information about monads.) @deffn {Monadic Procedure} gexp->derivation @var{name} @var{exp} @ - [#:system (%current-system)] [#:target #f] [#:inputs '()] @ + [#:system (%current-system)] [#:target #f] [#:graft? #t] @ [#:hash #f] [#:hash-algo #f] @ [#:recursive? #f] [#:env-vars '()] [#:modules '()] @ [#:module-path @var{%load-path}] @ @@ -2591,12 +2591,15 @@ Return a derivation @var{name} that runs @var{exp} (a gexp) with is true, it is used as the cross-compilation target triplet for packages referred to by @var{exp}. -Make @var{modules} available in the evaluation context of @var{EXP}; -@var{MODULES} is a list of names of Guile modules searched in -@var{MODULE-PATH} to be copied in the store, compiled, and made available in +Make @var{modules} available in the evaluation context of @var{exp}; +@var{modules} is a list of names of Guile modules searched in +@var{module-path} to be copied in the store, compiled, and made available in the load path during the execution of @var{exp}---e.g., @code{((guix build utils) (guix build gnu-build-system))}. +@var{graft?} determines whether packages referred to by @var{exp} should be grafted when +applicable. + When @var{references-graphs} is true, it must be a list of tuples of one of the following forms: diff --git a/guix/gexp.scm b/guix/gexp.scm index 0620683078..a8349c7d6e 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -153,6 +153,7 @@ names and file names suitable for the #:allowed-references argument to (modules '()) (module-path %load-path) (guile-for-build (%guile-for-build)) + (graft? (%graft?)) references-graphs allowed-references local-build?) @@ -165,6 +166,9 @@ names of Guile modules searched in MODULE-PATH to be copied in the store, compiled, and made available in the load path during the execution of EXP---e.g., '((guix build utils) (guix build gnu-build-system)). +GRAFT? determines whether packages referred to by EXP should be grafted when +applicable. + When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the following forms: @@ -198,10 +202,10 @@ The other arguments are as for 'derivation'." (cons file-name thing))) graphs)) - (mlet* %store-monad (;; The following binding is here to force - ;; '%current-system' and '%current-target-system' to be - ;; looked up at >>= time. - (unused (return #f)) + (mlet* %store-monad (;; The following binding forces '%current-system' and + ;; '%current-target-system' to be looked up at >>= + ;; time. + (graft? (set-grafting graft?)) (system -> (or system (%current-system))) (target -> (if (eq? target 'current) @@ -245,30 +249,32 @@ The other arguments are as for 'derivation'." (return guile-for-build) (package->derivation (default-guile) system)))) - (raw-derivation name - (string-append (derivation->output-path guile) - "/bin/guile") - `("--no-auto-compile" - ,@(if (pair? %modules) - `("-L" ,(derivation->output-path modules) - "-C" ,(derivation->output-path compiled)) - '()) - ,builder) - #:outputs outputs - #:env-vars env-vars - #:system system - #:inputs `((,guile) - (,builder) - ,@(if modules - `((,modules) (,compiled) ,@inputs) - inputs) - ,@(match graphs - (((_ . inputs) ...) inputs) - (_ '()))) - #:hash hash #:hash-algo hash-algo #:recursive? recursive? - #:references-graphs (and=> graphs graphs-file-names) - #:allowed-references allowed - #:local-build? local-build?))) + (mbegin %store-monad + (set-grafting graft?) ;restore the initial setting + (raw-derivation name + (string-append (derivation->output-path guile) + "/bin/guile") + `("--no-auto-compile" + ,@(if (pair? %modules) + `("-L" ,(derivation->output-path modules) + "-C" ,(derivation->output-path compiled)) + '()) + ,builder) + #:outputs outputs + #:env-vars env-vars + #:system system + #:inputs `((,guile) + (,builder) + ,@(if modules + `((,modules) (,compiled) ,@inputs) + inputs) + ,@(match graphs + (((_ . inputs) ...) inputs) + (_ '()))) + #:hash hash #:hash-algo hash-algo #:recursive? recursive? + #:references-graphs (and=> graphs graphs-file-names) + #:allowed-references allowed + #:local-build? local-build?)))) (define* (gexp-inputs exp #:optional (references gexp-references)) "Return the input list for EXP, using REFERENCES to get its list of diff --git a/tests/gexp.scm b/tests/gexp.scm index 68c470d3b6..0b189b570b 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -249,6 +249,23 @@ (equal? refs (list (dirname (dirname guile)))) (equal? refs2 (list file)))))) +(test-assertm "gexp->derivation vs. grafts" + (mlet* %store-monad ((p0 -> (dummy-package "dummy" + (arguments + '(#:implicit-inputs? #f)))) + (r -> (package (inherit p0) (name "DuMMY"))) + (p1 -> (package (inherit p0) (replacement r))) + (exp0 -> (gexp (frob (ungexp p0) (ungexp output)))) + (exp1 -> (gexp (frob (ungexp p1) (ungexp output)))) + (void (set-guile-for-build %bootstrap-guile)) + (drv0 (gexp->derivation "t" exp0)) + (drv1 (gexp->derivation "t" exp1)) + (drv1* (gexp->derivation "t" exp1 #:graft? #f))) + (return (and (not (string=? (derivation->output-path drv0) + (derivation->output-path drv1))) + (string=? (derivation->output-path drv0) + (derivation->output-path drv1*)))))) + (test-assertm "gexp->derivation, composed gexps" (mlet* %store-monad ((exp0 -> (gexp (begin (mkdir (ungexp output)) -- cgit v1.2.3