me/guix
Archived
1
0
Fork 0
Code Activity

gexp: Add 'lower-gexp' and express 'gexp->derivation' in terms of it.

Browse source 
* guix/gexp.scm (gexp-input-thing, gexp-input-output)
(gexp-input-native?): Export.
(lower-inputs): Return <gexp-input> records instead of tuples.
(lower-reference-graphs): Adjust accordingly.
(<lowered-gexp>): New record type.
(lower-gexp, gexp-input->tuple): New procedure.
(gexp->derivation)[%modules]: Remove.
[requested-graft?]: New variable.
[add-modules]: New procedure.
Rewrite in terms of 'lower-gexp'.
(gexp-inputs): Add TODO comment.
* tests/gexp.scm ("lower-gexp"): New test.
This commit is contained in:
Ludovic Courtès 2019-06-10 14:34:36 +02:00
parent fc3f14927f
commit 2ca41030d5
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
2 changed files with 218 additions and 59 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

240
guix/gexp.scm
View file

@ -39,6 +39,9 @@
gexp-input gexp-input
gexp-input? gexp-input?
gexp-input-thing
gexp-input-output
gexp-input-native?
local-file local-file
local-file? local-file?
@ -78,6 +81,14 @@
load-path-expression load-path-expression
gexp-modules 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->derivation
gexp->file gexp->file
gexp->script gexp->script
@ -566,15 +577,20 @@ list."
"Turn any package from INPUTS into a derivation for SYSTEM; return the "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 corresponding input list as a monadic value. When TARGET is true, use it as
the cross-compilation target triplet." the cross-compilation target triplet."
(define (store-item? obj)
(and (string? obj) (store-path? obj)))
(with-monad %store-monad (with-monad %store-monad
(mapm %store-monad (mapm %store-monad
(match-lambda (match-lambda
(((? struct? thing) sub-drv ...) (((? struct? thing) sub-drv ...)
(mlet %store-monad ((drv (lower-object (mlet %store-monad ((drv (lower-object
thing system #:target target))) thing system #:target target)))
(return `(,drv ,@sub-drv)))) (return (apply gexp-input drv sub-drv))))
(((? store-item? item))
(return (gexp-input item)))
(input (input
(return input))) (return (gexp-input input))))
inputs))) inputs)))
(define* (lower-reference-graphs graphs #:key system target) (define* (lower-reference-graphs graphs #:key system target)
@ -586,7 +602,9 @@ corresponding derivation."
(mlet %store-monad ((inputs (lower-inputs inputs (mlet %store-monad ((inputs (lower-inputs inputs
#:system system #:system system
#:target target))) #: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) (define* (lower-references lst #:key system target)
"Based on LST, a list of output names and packages, return a list of output "Based on LST, a list of output names and packages, return a list of output
@ -618,6 +636,130 @@ names and file names suitable for the #:allowed-references argument to
(lambda (system) (lambda (system)
((force proc) 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
"*Note: This API is subject to change; use at your own risk!*
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
#: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
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 (define* (gexp->derivation name exp
#:key #:key
system (target 'current) system (target 'current)
@ -682,10 +824,8 @@ DEPRECATION-WARNINGS determines whether to show deprecation warnings while
compiling modules. It can be #f, #t, or 'detailed. compiling modules. It can be #f, #t, or 'detailed.
The other arguments are as for 'derivation'." The other arguments are as for 'derivation'."
(define %modules
(delete-duplicates
(append modules (gexp-modules exp))))
(define outputs (gexp-outputs exp)) (define outputs (gexp-outputs exp))
(define requested-graft? graft?)
(define (graphs-file-names graphs) (define (graphs-file-names graphs)
;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS. ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
@ -699,11 +839,13 @@ The other arguments are as for 'derivation'."
(cons file-name thing))) (cons file-name thing)))
graphs)) graphs))
(define (extension-flags extension) (define (add-modules exp modules)
`("-L" ,(string-append (derivation->output-path extension) (if (null? modules)
"/share/guile/site/" effective-version) exp
"-C" ,(string-append (derivation->output-path extension) (make-gexp (gexp-references exp)
"/lib/guile/" effective-version "/site-ccache"))) (append modules (gexp-self-modules exp))
(gexp-self-extensions exp)
(gexp-proc exp))))
(mlet* %store-monad ( ;; The following binding forces '%current-system' and (mlet* %store-monad ( ;; The following binding forces '%current-system' and
;; '%current-target-system' to be looked up at >>= ;; '%current-target-system' to be looked up at >>=
@ -714,40 +856,21 @@ The other arguments are as for 'derivation'."
(target -> (if (eq? target 'current) (target -> (if (eq? target 'current)
(%current-target-system) (%current-target-system)
target)) target))
(normals (lower-inputs (gexp-inputs exp) (exp -> (add-modules exp modules))
#:system system (lowered (lower-gexp exp
#:target target)) #:module-path module-path
(natives (lower-inputs (gexp-native-inputs exp) #:system system
#:system system #:target target
#:target #f)) #:graft? requested-graft?
(inputs -> (append normals natives)) #:guile-for-build
(sexp (gexp->sexp exp guile-for-build
#:system system #:effective-version
#:target target)) effective-version
(builder (text-file script-name #:deprecation-warnings
(object->string sexp))) deprecation-warnings
(extensions -> (gexp-extensions exp)) #:pre-load-modules?
(exts (mapm %store-monad pre-load-modules?))
(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)))
(graphs (if references-graphs (graphs (if references-graphs
(lower-reference-graphs references-graphs (lower-reference-graphs references-graphs
#:system system #:system system
@ -763,32 +886,30 @@ The other arguments are as for 'derivation'."
#:system system #:system system
#:target target) #:target target)
(return #f))) (return #f)))
(guile (if guile-for-build (guile -> (lowered-gexp-guile lowered))
(return guile-for-build) (builder (text-file script-name
(default-guile-derivation system)))) (object->string
(lowered-gexp-sexp lowered)))))
(mbegin %store-monad (mbegin %store-monad
(set-grafting graft?) ;restore the initial setting (set-grafting graft?) ;restore the initial setting
(raw-derivation name (raw-derivation name
(string-append (derivation->output-path guile) (string-append (derivation->output-path guile)
"/bin/guile") "/bin/guile")
`("--no-auto-compile" `("--no-auto-compile"
,@(if (pair? %modules) ,@(append-map (lambda (directory)
`("-L" ,(if (derivation? modules) `("-L" ,directory))
(derivation->output-path modules) (lowered-gexp-load-path lowered))
modules) ,@(append-map (lambda (directory)
"-C" ,(derivation->output-path compiled)) `("-C" ,directory))
'()) (lowered-gexp-load-compiled-path lowered))
,@(append-map extension-flags exts)
,builder) ,builder)
#:outputs outputs #:outputs outputs
#:env-vars env-vars #:env-vars env-vars
#:system system #:system system
#:inputs `((,guile) #:inputs `((,guile)
(,builder) (,builder)
,@(if modules ,@(map gexp-input->tuple
`((,modules) (,compiled) ,@inputs) (lowered-gexp-inputs lowered))
inputs)
,@(map list exts)
,@(match graphs ,@(match graphs
(((_ . inputs) ...) inputs) (((_ . inputs) ...) inputs)
(_ '()))) (_ '())))
@ -804,6 +925,7 @@ The other arguments are as for 'derivation'."
(define* (gexp-inputs exp #:key native?) (define* (gexp-inputs exp #:key native?)
"Return the input list for EXP. When NATIVE? is true, return only native "Return the input list for EXP. When NATIVE? is true, return only native
references; otherwise, return only non-native references." references; otherwise, return only non-native references."
;; TODO: Return <gexp-input> records instead of tuples.
(define (add-reference-inputs ref result) (define (add-reference-inputs ref result)
(match ref (match ref
(($ <gexp-input> (? gexp? exp) _ #t) (($ <gexp-input> (? gexp? exp) _ #t)

37
tests/gexp.scm
View file

@ -832,6 +832,43 @@
(built-derivations (list drv)) (built-derivations (list drv))
(return (equal? '(42 84) (call-with-input-file out read)))))) (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" (test-assertm "gexp->derivation #:references-graphs"
(mlet* %store-monad (mlet* %store-monad
((one (text-file "one" (random-text))) ((one (text-file "one" (random-text)))