Browse Source

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

* 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.
gn-latest-20200428
Ludovic Courtès 2 years ago
parent
commit
2ca41030d5
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
2 changed files with 218 additions and 59 deletions
  1. +181
    -59
      guix/gexp.scm
  2. +37
    -0
      tests/gexp.scm

+ 181
- 59
guix/gexp.scm View File

@ -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,130 @@ 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
"*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
#:key
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.
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 +839,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 +856,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 +886,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 +925,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)


+ 37
- 0
tests/gexp.scm View File

@ -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)))


Loading…
Cancel
Save