Toggle diff (382 lines)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 4f2adba90a..38f64db7f1 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -39,6 +39,9 @@
gexp-input
gexp-input?
+ gexp-input-thing
+ gexp-input-output
+ gexp-input-native?
local-file
local-file?
@@ -78,6 +81,14 @@
load-path-expression
gexp-modules
+ lower-gexp
+ lowered-gexp?
+ lowered-gexp-sexp
+ lowered-gexp-inputs
+ lowered-gexp-guile
+ lowered-gexp-load-path
+ lowered-gexp-load-compiled-path
+
gexp->derivation
gexp->file
gexp->script
@@ -566,15 +577,20 @@ list."
"Turn any package from INPUTS into a derivation for SYSTEM; return the
corresponding input list as a monadic value. When TARGET is true, use it as
the cross-compilation target triplet."
+ (define (store-item? obj)
+ (and (string? obj) (store-path? obj)))
+
(with-monad %store-monad
(mapm %store-monad
(match-lambda
(((? struct? thing) sub-drv ...)
(mlet %store-monad ((drv (lower-object
thing system #:target target)))
- (return `(,drv ,@sub-drv))))
+ (return (apply gexp-input drv sub-drv))))
+ (((? store-item? item))
+ (return (gexp-input item)))
(input
- (return input)))
+ (return (gexp-input input))))
inputs)))
(define* (lower-reference-graphs graphs #:key system target)
@@ -586,7 +602,9 @@ corresponding derivation."
(mlet %store-monad ((inputs (lower-inputs inputs
#:system system
#:target target)))
- (return (map cons file-names inputs))))))
+ (return (map (lambda (file input)
+ (cons file (gexp-input->tuple input)))
+ file-names inputs))))))
(define* (lower-references lst #:key system target)
"Based on LST, a list of output names and packages, return a list of output
@@ -618,6 +636,128 @@ names and file names suitable for the #:allowed-references argument to
(lambda (system)
((force proc) system))))
+;; Representation of a gexp instantiated for a given target and system.
+(define-record-type <lowered-gexp>
+ (lowered-gexp sexp inputs guile load-path load-compiled-path)
+ lowered-gexp?
+ (sexp lowered-gexp-sexp) ;sexp
+ (inputs lowered-gexp-inputs) ;list of <gexp-input>
+ (guile lowered-gexp-guile) ;<derivation> | #f
+ (load-path lowered-gexp-load-path) ;list of store items
+ (load-compiled-path lowered-gexp-load-compiled-path)) ;list of store items
+
+(define* (lower-gexp exp
+ #:key
+ (module-path %load-path)
+ (system (%current-system))
+ (target 'current)
+ (graft? (%graft?))
+ (guile-for-build (%guile-for-build))
+ (effective-version "2.2")
+
+ deprecation-warnings
+ (pre-load-modules? #t)) ;transitional
+ "Lower EXP, a gexp, instantiating it for SYSTEM and TARGET. Return a
+<lowered-gexp> ready to be used.
+
+Lowered gexps are an intermediate representation that's useful for
+applications that deal with gexps outside in a way that is disconnected from
+derivations--e.g., code evaluated for its side effects."
+ (define %modules
+ (delete-duplicates (gexp-modules exp)))
+
+ (define (search-path modules extensions suffix)
+ (append (match modules
+ ((? derivation? drv)
+ (list (derivation->output-path drv)))
+ (#f
+ '())
+ ((? store-path? item)
+ (list item)))
+ (map (lambda (extension)
+ (string-append (match extension
+ ((? derivation? drv)
+ (derivation->output-path drv))
+ ((? store-path? item)
+ item))
+ suffix))
+ extensions)))
+
+ (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)
+ (%current-target-system)
+ target))
+ (guile (if guile-for-build
+ (return guile-for-build)
+ (default-guile-derivation system)))
+ (normals (lower-inputs (gexp-inputs exp)
+ #:system system
+ #:target target))
+ (natives (lower-inputs (gexp-native-inputs exp)
+ #:system system
+ #:target #f))
+ (inputs -> (append normals natives))
+ (sexp (gexp->sexp exp
+ #:system system
+ #:target target))
+ (extensions -> (gexp-extensions exp))
+ (exts (mapm %store-monad
+ (lambda (obj)
+ (lower-object obj system))
+ extensions))
+ (modules (if (pair? %modules)
+ (imported-modules %modules
+ #:system system
+ #:module-path module-path)
+ (return #f)))
+ (compiled (if (pair? %modules)
+ (compiled-modules %modules
+ #:system system
+ #:module-path module-path
+ #:extensions extensions
+ #:guile guile-for-build
+ #:pre-load-modules?
+ pre-load-modules?
+ #:deprecation-warnings
+ deprecation-warnings)
+ (return #f))))
+ (define load-path
+ (search-path modules exts
+ (string-append "/share/guile/site/" effective-version)))
+
+ (define load-compiled-path
+ (search-path compiled exts
+ (string-append "/lib/guile/" effective-version
+ "/site-ccache")))
+
+ (mbegin %store-monad
+ (set-grafting graft?) ;restore the initial setting
+ (return (lowered-gexp sexp
+ `(,@(if modules
+ (list (gexp-input modules))
+ '())
+ ,@(if compiled
+ (list (gexp-input compiled))
+ '())
+ ,@(map gexp-input exts)
+ ,@inputs)
+ guile-for-build
+ load-path
+ load-compiled-path)))))
+
+(define (gexp-input->tuple input)
+ "Given INPUT, a <gexp-input> record, return the corresponding input tuple
+suitable for the 'derivation' procedure."
+ (match (gexp-input-output input)
+ ("out" `(,(gexp-input-thing input)))
+ (output `(,(gexp-input-thing input)
+ ,(gexp-input-output input)))))
+
(define* (gexp->derivation name exp
#:key
system (target 'current)
@@ -682,10 +822,8 @@ DEPRECATION-WARNINGS determines whether to show deprecation warnings while
compiling modules. It can be #f, #t, or 'detailed.
The other arguments are as for 'derivation'."
- (define %modules
- (delete-duplicates
- (append modules (gexp-modules exp))))
(define outputs (gexp-outputs exp))
+ (define requested-graft? graft?)
(define (graphs-file-names graphs)
;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
@@ -699,11 +837,13 @@ The other arguments are as for 'derivation'."
(cons file-name thing)))
graphs))
- (define (extension-flags extension)
- `("-L" ,(string-append (derivation->output-path extension)
- "/share/guile/site/" effective-version)
- "-C" ,(string-append (derivation->output-path extension)
- "/lib/guile/" effective-version "/site-ccache")))
+ (define (add-modules exp modules)
+ (if (null? modules)
+ exp
+ (make-gexp (gexp-references exp)
+ (append modules (gexp-self-modules exp))
+ (gexp-self-extensions exp)
+ (gexp-proc exp))))
(mlet* %store-monad ( ;; The following binding forces '%current-system' and
;; '%current-target-system' to be looked up at >>=
@@ -714,40 +854,21 @@ The other arguments are as for 'derivation'."
(target -> (if (eq? target 'current)
(%current-target-system)
target))
- (normals (lower-inputs (gexp-inputs exp)
- #:system system
- #:target target))
- (natives (lower-inputs (gexp-native-inputs exp)
- #:system system
- #:target #f))
- (inputs -> (append normals natives))
- (sexp (gexp->sexp exp
- #:system system
- #:target target))
- (builder (text-file script-name
- (object->string sexp)))
- (extensions -> (gexp-extensions exp))
- (exts (mapm %store-monad
- (lambda (obj)
- (lower-object obj system))
- extensions))
- (modules (if (pair? %modules)
- (imported-modules %modules
- #:system system
- #:module-path module-path
- #:guile guile-for-build)
- (return #f)))
- (compiled (if (pair? %modules)
- (compiled-modules %modules
- #:system system
- #:module-path module-path
- #:extensions extensions
- #:guile guile-for-build
- #:pre-load-modules?
- pre-load-modules?
- #:deprecation-warnings
- deprecation-warnings)
- (return #f)))
+ (exp -> (add-modules exp modules))
+ (lowered (lower-gexp exp
+ #:module-path module-path
+ #:system system
+ #:target target
+ #:graft? requested-graft?
+ #:guile-for-build
+ guile-for-build
+ #:effective-version
+ effective-version
+ #:deprecation-warnings
+ deprecation-warnings
+ #:pre-load-modules?
+ pre-load-modules?))
+
(graphs (if references-graphs
(lower-reference-graphs references-graphs
#:system system
@@ -763,32 +884,30 @@ The other arguments are as for 'derivation'."
#:system system
#:target target)
(return #f)))
- (guile (if guile-for-build
- (return guile-for-build)
- (default-guile-derivation system))))
+ (guile -> (lowered-gexp-guile lowered))
+ (builder (text-file script-name
+ (object->string
+ (lowered-gexp-sexp lowered)))))
(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" ,(if (derivation? modules)
- (derivation->output-path modules)
- modules)
- "-C" ,(derivation->output-path compiled))
- '())
- ,@(append-map extension-flags exts)
+ ,@(append-map (lambda (directory)
+ `("-L" ,directory))
+ (lowered-gexp-load-path lowered))
+ ,@(append-map (lambda (directory)
+ `("-C" ,directory))
+ (lowered-gexp-load-compiled-path lowered))
,builder)
#:outputs outputs
#:env-vars env-vars
#:system system
#:inputs `((,guile)
(,builder)
- ,@(if modules
- `((,modules) (,compiled) ,@inputs)
- inputs)
- ,@(map list exts)
+ ,@(map gexp-input->tuple
+ (lowered-gexp-inputs lowered))
,@(match graphs
(((_ . inputs) ...) inputs)
(_ '())))
@@ -804,6 +923,7 @@ The other arguments are as for 'derivation'."
(define* (gexp-inputs exp #:key native?)
"Return the input list for EXP. When NATIVE? is true, return only native
references; otherwise, return only non-native references."
+ ;; TODO: Return <gexp-input> records instead of tuples.
(define (add-reference-inputs ref result)
(match ref
(($ <gexp-input> (? gexp? exp) _ #t)
diff --git a/tests/gexp.scm b/tests/gexp.scm
index cee2c96610..23904fce2e 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -832,6 +832,43 @@
(built-derivations (list drv))
(return (equal? '(42 84) (call-with-input-file out read))))))
+(test-assertm "lower-gexp"
+ (mlet* %store-monad
+ ((extension -> %extension-package)
+ (extension-drv (package->derivation %extension-package))
+ (coreutils-drv (package->derivation coreutils))
+ (exp -> (with-extensions (list extension)
+ (with-imported-modules `((guix build utils))
+ #~(begin
+ (use-modules (guix build utils)
+ (hg2g))
+ #$coreutils:debug
+ mkdir-p
+ the-answer))))
+ (lexp (lower-gexp exp
+ #:effective-version "2.0")))
+ (define (matching-input drv output)
+ (lambda (input)
+ (and (eq? (gexp-input-thing input) drv)
+ (string=? (gexp-input-output input) output))))
+
+ (mbegin %store-monad
+ (return (and (find (matching-input extension-drv "out")
+ (lowered-gexp-inputs (pk 'lexp lexp)))
+ (find (matching-input coreutils-drv "debug")
+ (lowered-gexp-inputs lexp))
+ (member (string-append
+ (derivation->output-path extension-drv)
+ "/share/guile/site/2.0")
+ (lowered-gexp-load-path lexp))
+ (= 2 (length (lowered-gexp-load-path lexp)))
+ (member (string-append
+ (derivation->output-path extension-drv)
+ "/lib/guile/2.0/site-ccache")
+ (lowered-gexp-load-compiled-path lexp))
+ (= 2 (length (lowered-gexp-load-compiled-path lexp)))
+ (eq? (lowered-gexp-guile lexp) (%guile-for-build)))))))
+
(test-assertm "gexp->derivation #:references-graphs"
(mlet* %store-monad
((one (text-file "one" (random-text)))
--
2.21.0
