gexp: Separate "compilers" for origins and packages from the core.
* guix/gexp.scm (<gexp-compiler>): New record type. (%gexp-compilers): New variable. (register-compiler!, lookup-compiler): New procedures. (define-gexp-compiler): New macro. (origin-compiler, package-compiler): New compilers. (lower-inputs): Remove clauses for 'origin?' and 'package?'. Add clause with 'lookup-compiler' instead. (lower-references): Likewise. (gexp-inputs)[add-reference-inputs]: Likewise. (gexp->sexp)[reference->sexp]: Likewise.
This commit is contained in:
parent
a482cfdcae
commit
bcb1328763
104
guix/gexp.scm
104
guix/gexp.scm
|
@ -83,6 +83,63 @@
|
||||||
|
|
||||||
(set-record-type-printer! <gexp> write-gexp)
|
(set-record-type-printer! <gexp> write-gexp)
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Methods.
|
||||||
|
;;;
|
||||||
|
|
||||||
|
;; Compiler for a type of objects that may be introduced in a gexp.
|
||||||
|
(define-record-type <gexp-compiler>
|
||||||
|
(gexp-compiler predicate lower)
|
||||||
|
gexp-compiler?
|
||||||
|
(predicate gexp-compiler-predicate)
|
||||||
|
(lower gexp-compiler-lower))
|
||||||
|
|
||||||
|
(define %gexp-compilers
|
||||||
|
;; List of <gexp-compiler>.
|
||||||
|
'())
|
||||||
|
|
||||||
|
(define (register-compiler! compiler)
|
||||||
|
"Register COMPILER as a gexp compiler."
|
||||||
|
(set! %gexp-compilers (cons compiler %gexp-compilers)))
|
||||||
|
|
||||||
|
(define (lookup-compiler object)
|
||||||
|
"Search a compiler for OBJECT. Upon success, return the three argument
|
||||||
|
procedure to lower it; otherwise return #f."
|
||||||
|
(any (match-lambda
|
||||||
|
(($ <gexp-compiler> predicate lower)
|
||||||
|
(and (predicate object) lower)))
|
||||||
|
%gexp-compilers))
|
||||||
|
|
||||||
|
(define-syntax-rule (define-gexp-compiler (name (param predicate)
|
||||||
|
system target)
|
||||||
|
body ...)
|
||||||
|
"Define NAME as a compiler for objects matching PREDICATE encountered in
|
||||||
|
gexps. BODY must return a derivation for PARAM, an object that matches
|
||||||
|
PREDICATE, for SYSTEM and TARGET (the latter of which is #f except when
|
||||||
|
cross-compiling.)"
|
||||||
|
(begin
|
||||||
|
(define name
|
||||||
|
(gexp-compiler predicate
|
||||||
|
(lambda (param system target)
|
||||||
|
body ...)))
|
||||||
|
(register-compiler! name)))
|
||||||
|
|
||||||
|
(define-gexp-compiler (origin-compiler (origin origin?) system target)
|
||||||
|
;; Compiler for origins.
|
||||||
|
(origin->derivation origin system))
|
||||||
|
|
||||||
|
(define-gexp-compiler (package-compiler (package package?) system target)
|
||||||
|
;; Compiler for packages.
|
||||||
|
(if target
|
||||||
|
(package->cross-derivation package target system)
|
||||||
|
(package->derivation package system)))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Inputs & outputs.
|
||||||
|
;;;
|
||||||
|
|
||||||
;; The input of a gexp.
|
;; The input of a gexp.
|
||||||
(define-record-type <gexp-input>
|
(define-record-type <gexp-input>
|
||||||
(%gexp-input thing output native?)
|
(%gexp-input thing output native?)
|
||||||
|
@ -116,15 +173,11 @@ the cross-compilation target triplet."
|
||||||
(with-monad %store-monad
|
(with-monad %store-monad
|
||||||
(sequence %store-monad
|
(sequence %store-monad
|
||||||
(map (match-lambda
|
(map (match-lambda
|
||||||
(((? package? package) sub-drv ...)
|
((and ((? derivation?) sub-drv ...) input)
|
||||||
(mlet %store-monad
|
(return input))
|
||||||
((drv (if target
|
((and ((? struct? thing) sub-drv ...) input)
|
||||||
(package->cross-derivation package target
|
(mlet* %store-monad ((lower -> (lookup-compiler thing))
|
||||||
system)
|
(drv (lower thing system target)))
|
||||||
(package->derivation package system))))
|
|
||||||
(return `(,drv ,@sub-drv))))
|
|
||||||
(((? origin? origin) sub-drv ...)
|
|
||||||
(mlet %store-monad ((drv (origin->derivation origin)))
|
|
||||||
(return `(,drv ,@sub-drv))))
|
(return `(,drv ,@sub-drv))))
|
||||||
(input
|
(input
|
||||||
(return input)))
|
(return input)))
|
||||||
|
@ -152,14 +205,9 @@ names and file names suitable for the #:allowed-references argument to
|
||||||
(match-lambda
|
(match-lambda
|
||||||
((? string? output)
|
((? string? output)
|
||||||
(return output))
|
(return output))
|
||||||
((? package? package)
|
(thing
|
||||||
(mlet %store-monad ((drv
|
(mlet* %store-monad ((lower -> (lookup-compiler thing))
|
||||||
(if target
|
(drv (lower thing system target)))
|
||||||
(package->cross-derivation package target
|
|
||||||
#:system system
|
|
||||||
#:graft? #f)
|
|
||||||
(package->derivation package system
|
|
||||||
#:graft? #f))))
|
|
||||||
(return (derivation->output-path drv))))))
|
(return (derivation->output-path drv))))))
|
||||||
|
|
||||||
(sequence %store-monad (map lower lst))))
|
(sequence %store-monad (map lower lst))))
|
||||||
|
@ -302,16 +350,17 @@ references."
|
||||||
(match ref
|
(match ref
|
||||||
(($ <gexp-input> (? derivation? drv) output)
|
(($ <gexp-input> (? derivation? drv) output)
|
||||||
(cons `(,drv ,output) result))
|
(cons `(,drv ,output) result))
|
||||||
(($ <gexp-input> (? package? pkg) output)
|
|
||||||
(cons `(,pkg ,output) result))
|
|
||||||
(($ <gexp-input> (? origin? o))
|
|
||||||
(cons `(,o "out") result))
|
|
||||||
(($ <gexp-input> (? gexp? exp))
|
(($ <gexp-input> (? gexp? exp))
|
||||||
(append (gexp-inputs exp references) result))
|
(append (gexp-inputs exp references) result))
|
||||||
(($ <gexp-input> (? string? str))
|
(($ <gexp-input> (? string? str))
|
||||||
(if (direct-store-path? str)
|
(if (direct-store-path? str)
|
||||||
(cons `(,str) result)
|
(cons `(,str) result)
|
||||||
result))
|
result))
|
||||||
|
(($ <gexp-input> (? struct? thing) output)
|
||||||
|
(if (lookup-compiler thing)
|
||||||
|
;; THING is a derivation, or a package, or an origin, etc.
|
||||||
|
(cons `(,thing ,output) result)
|
||||||
|
result))
|
||||||
(($ <gexp-input> (lst ...) output native?)
|
(($ <gexp-input> (lst ...) output native?)
|
||||||
(fold-right add-reference-inputs result
|
(fold-right add-reference-inputs result
|
||||||
;; XXX: For now, automatically convert LST to a list of
|
;; XXX: For now, automatically convert LST to a list of
|
||||||
|
@ -364,14 +413,6 @@ and in the current monad setting (system type, etc.)"
|
||||||
(match ref
|
(match ref
|
||||||
(($ <gexp-input> (? derivation? drv) output)
|
(($ <gexp-input> (? derivation? drv) output)
|
||||||
(return (derivation->output-path drv output)))
|
(return (derivation->output-path drv output)))
|
||||||
(($ <gexp-input> (? package? p) output n?)
|
|
||||||
(package-file p
|
|
||||||
#:output output
|
|
||||||
#:system system
|
|
||||||
#:target (if (or n? native?) #f target)))
|
|
||||||
(($ <gexp-input> (? origin? o) output)
|
|
||||||
(mlet %store-monad ((drv (origin->derivation o)))
|
|
||||||
(return (derivation->output-path drv output))))
|
|
||||||
(($ <gexp-output> output)
|
(($ <gexp-output> output)
|
||||||
;; Output file names are not known in advance but the daemon defines
|
;; Output file names are not known in advance but the daemon defines
|
||||||
;; an environment variable for each of them at build time, so use
|
;; an environment variable for each of them at build time, so use
|
||||||
|
@ -391,6 +432,11 @@ and in the current monad setting (system type, etc.)"
|
||||||
(%gexp-input ref "out" n?))
|
(%gexp-input ref "out" n?))
|
||||||
native?))
|
native?))
|
||||||
refs)))
|
refs)))
|
||||||
|
(($ <gexp-input> (? struct? thing) output n?)
|
||||||
|
(let ((lower (lookup-compiler thing))
|
||||||
|
(target (if (or n? native?) #f target)))
|
||||||
|
(mlet %store-monad ((drv (lower thing system target)))
|
||||||
|
(return (derivation->output-path drv output)))))
|
||||||
(($ <gexp-input> x)
|
(($ <gexp-input> x)
|
||||||
(return x))
|
(return x))
|
||||||
(x
|
(x
|
||||||
|
|
Loading…
Reference in New Issue