nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

gexp: <lowered-gexp> separates sources from derivation inputs. 

* guix/gexp.scm (lower-inputs): Return either <derivation-input> records
or store items.
(lower-reference-graphs): Return file/input pairs.
(<lowered-gexp>)[sources]: New field.
(lower-gexp): Adjust accordingly.
(gexp->input-tuple): Remove.
(gexp->derivation)[graphs-file-names]: Handle only the
'derivation-input?' and 'string?' cases.
Pass #:sources to 'raw-derivation'; ensure #:inputs contains only
<derivation-input> records.
* guix/remote.scm (remote-eval): Adjust to the new <lowered-gexp>
interface.
* tests/gexp.scm ("lower-gexp"): Adjust to expect <derivation-input>
records instead of <gexp-input>
This commit is contained in:
Ludovic Courtès 2019-07-09 23:05:01 +02:00
parent 4daf89d619
commit 3868577480
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 60 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
guix/gexp.scm
View File

@ -85,6 +85,7 @@
lowered-gexp? lowered-gexp?
lowered-gexp-sexp lowered-gexp-sexp
lowered-gexp-inputs lowered-gexp-inputs
lowered-gexp-sources
lowered-gexp-guile lowered-gexp-guile
lowered-gexp-load-path lowered-gexp-load-path
lowered-gexp-load-compiled-path lowered-gexp-load-compiled-path
@ -574,9 +575,9 @@ list."
(define* (lower-inputs inputs (define* (lower-inputs inputs
#:key system target) #:key system target)
"Turn any package from INPUTS into a derivation for SYSTEM; return the "Turn any object from INPUTS into a derivation input for SYSTEM or a store
corresponding input list as a monadic value. When TARGET is true, use it as item (a \"source\"); return the corresponding input list as a monadic value.
the cross-compilation target triplet." When TARGET is true, use it as the cross-compilation target triplet."
(define (store-item? obj) (define (store-item? obj)
(and (string? obj) (store-path? obj))) (and (string? obj) (store-path? obj)))
@ -584,27 +585,30 @@ the cross-compilation target triplet."
(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 ((obj (lower-object
thing system #:target target))) thing system #:target target)))
(return (apply gexp-input drv sub-drv)))) (return (match obj
((? derivation? drv)
(let ((outputs (if (null? sub-drv)
'("out")
sub-drv)))
(derivation-input drv outputs)))
((? store-item? item)
item)))))
(((? store-item? item)) (((? store-item? item))
(return (gexp-input item))) (return item)))
(input
(return (gexp-input input))))
inputs))) inputs)))
(define* (lower-reference-graphs graphs #:key system target) (define* (lower-reference-graphs graphs #:key system target)
"Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
#:reference-graphs argument, lower it such that each INPUT is replaced by the #:reference-graphs argument, lower it such that each INPUT is replaced by the
corresponding derivation." corresponding <derivation-input> or store item."
(match graphs (match graphs
(((file-names . inputs) ...) (((file-names . inputs) ...)
(mlet %store-monad ((inputs (lower-inputs inputs (mlet %store-monad ((inputs (lower-inputs inputs
#:system system #:system system
#:target target))) #:target target)))
(return (map (lambda (file input) (return (map cons file-names inputs))))))
(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
@ -637,11 +641,13 @@ names and file names suitable for the #:allowed-references argument to
((force proc) system)))) ((force proc) system))))
;; Representation of a gexp instantiated for a given target and system. ;; Representation of a gexp instantiated for a given target and system.
;; It's an intermediate representation between <gexp> and <derivation>.
(define-record-type <lowered-gexp> (define-record-type <lowered-gexp>
(lowered-gexp sexp inputs guile load-path load-compiled-path) (lowered-gexp sexp inputs sources guile load-path load-compiled-path)
lowered-gexp? lowered-gexp?
(sexp lowered-gexp-sexp) ;sexp (sexp lowered-gexp-sexp) ;sexp
(inputs lowered-gexp-inputs) ;list of <gexp-input> (inputs lowered-gexp-inputs) ;list of <derivation-input>
(sources lowered-gexp-sources) ;list of store items
(guile lowered-gexp-guile) ;<derivation> | #f (guile lowered-gexp-guile) ;<derivation> | #f
(load-path lowered-gexp-load-path) ;list of store items (load-path lowered-gexp-load-path) ;list of store items
(load-compiled-path lowered-gexp-load-compiled-path)) ;list of store items (load-compiled-path lowered-gexp-load-compiled-path)) ;list of store items
@ -740,26 +746,19 @@ derivations--e.g., code evaluated for its side effects."
(mbegin %store-monad (mbegin %store-monad
(set-grafting graft?) ;restore the initial setting (set-grafting graft?) ;restore the initial setting
(return (lowered-gexp sexp (return (lowered-gexp sexp
`(,@(if modules `(,@(if (derivation? modules)
(list (gexp-input modules)) (list (derivation-input modules))
'()) '())
,@(if compiled ,@(if compiled
(list (gexp-input compiled)) (list (derivation-input compiled))
'()) '())
,@(map gexp-input exts) ,@(map derivation-input exts)
,@inputs) ,@(filter derivation-input? inputs))
(filter string? (cons modules inputs))
guile guile
load-path load-path
load-compiled-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)
@ -830,13 +829,10 @@ The other arguments are as for 'derivation'."
(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.
(map (match-lambda (map (match-lambda
;; TODO: Remove 'derivation?' special cases. ((file-name . (? derivation-input? input))
((file-name (? derivation? drv)) (cons file-name (first (derivation-input-output-paths input))))
(cons file-name (derivation->output-path drv))) ((file-name . (? string? item))
((file-name (? derivation? drv) sub-drv) (cons file-name item)))
(cons file-name (derivation->output-path drv sub-drv)))
((file-name thing)
(cons file-name thing)))
graphs)) graphs))
(define (add-modules exp modules) (define (add-modules exp modules)
@ -906,13 +902,23 @@ The other arguments are as for 'derivation'."
#:outputs outputs #:outputs outputs
#:env-vars env-vars #:env-vars env-vars
#:system system #:system system
#:inputs `((,guile) #:inputs `(,(derivation-input guile '("out"))
(,builder) ,@(lowered-gexp-inputs lowered)
,@(map gexp-input->tuple
(lowered-gexp-inputs lowered))
,@(match graphs ,@(match graphs
(((_ . inputs) ...) inputs) (((_ . inputs) ...)
(_ '()))) (filter derivation-input? inputs))
(#f '())))
#:sources `(,builder
,@(if (and (string? modules)
(store-path? modules))
(list modules)
'())
,@(lowered-gexp-sources lowered)
,@(match graphs
(((_ . inputs) ...)
(filter string? inputs))
(#f '())))
#:hash hash #:hash-algo hash-algo #:recursive? recursive? #:hash hash #:hash-algo hash-algo #:recursive? recursive?
#:references-graphs (and=> graphs graphs-file-names) #:references-graphs (and=> graphs graphs-file-names)
#:allowed-references allowed #:allowed-references allowed

36
guix/remote.scm
View File

@ -95,40 +95,26 @@ remote store."
(remote -> (connect-to-remote-daemon session (remote -> (connect-to-remote-daemon session
socket-name))) socket-name)))
(define inputs (define inputs
(cons (gexp-input (lowered-gexp-guile lowered)) (cons (derivation-input (lowered-gexp-guile lowered))
(lowered-gexp-inputs lowered))) (lowered-gexp-inputs lowered)))
(define to-build (define sources
(map (lambda (input) (lowered-gexp-sources lowered))
(if (derivation? (gexp-input-thing input))
(cons (gexp-input-thing input)
(gexp-input-output input))
(gexp-input-thing input)))
inputs))
(if build-locally? (if build-locally?
(let ((to-send (map (lambda (input) (let ((to-send (append (map derivation-input-output-paths inputs)
(match (gexp-input-thing input) sources)))
((? derivation? drv)
(derivation->output-path
drv (gexp-input-output input)))
((? store-path? item)
item)))
inputs)))
(mbegin %store-monad (mbegin %store-monad
(built-derivations to-build) (built-derivations inputs)
((store-lift send-files) to-send remote #:recursive? #t) ((store-lift send-files) to-send remote #:recursive? #t)
(return (close-connection remote)) (return (close-connection remote))
(return (%remote-eval lowered session)))) (return (%remote-eval lowered session))))
(let ((to-send (map (lambda (input) (let ((to-send (append (map (compose derivation-file-name
(match (gexp-input-thing input) derivation-input-derivation)
((? derivation? drv) inputs)
(derivation-file-name drv)) sources)))
((? store-path? item)
item)))
inputs)))
(mbegin %store-monad (mbegin %store-monad
((store-lift send-files) to-send remote #:recursive? #t) ((store-lift send-files) to-send remote #:recursive? #t)
(return (build-derivations remote to-build)) (return (build-derivations remote inputs))
(return (close-connection remote)) (return (close-connection remote))
(return (%remote-eval lowered session))))))) (return (%remote-eval lowered session)))))))

5
tests/gexp.scm
View File

@ -849,8 +849,9 @@
#:effective-version "2.0"))) #:effective-version "2.0")))
(define (matching-input drv output) (define (matching-input drv output)
(lambda (input) (lambda (input)
(and (eq? (gexp-input-thing input) drv) (and (eq? (derivation-input-derivation input) drv)
(string=? (gexp-input-output input) output)))) (equal? (derivation-input-sub-derivations input)
(list output)))))
(mbegin %store-monad (mbegin %store-monad
(return (and (find (matching-input extension-drv "out") (return (and (find (matching-input extension-drv "out")