From bcb132876370fc2e51ea9ba137b92932e9e956e4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 15 Mar 2015 23:27:34 +0100 Subject: gexp: Separate "compilers" for origins and packages from the core. * guix/gexp.scm (): 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. --- guix/gexp.scm | 104 ++++++++++++++++++++++++++++++++++++++++++---------------- 1 file changed, 75 insertions(+), 29 deletions(-) (limited to 'guix') diff --git a/guix/gexp.scm b/guix/gexp.scm index 353c46398a..119fe42d52 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -83,6 +83,63 @@ (define (write-gexp gexp port) (set-record-type-printer! write-gexp) + +;;; +;;; Methods. +;;; + +;; Compiler for a type of objects that may be introduced in a gexp. +(define-record-type + (gexp-compiler predicate lower) + gexp-compiler? + (predicate gexp-compiler-predicate) + (lower gexp-compiler-lower)) + +(define %gexp-compilers + ;; List of . + '()) + +(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 + (($ 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. (define-record-type (%gexp-input thing output native?) @@ -116,15 +173,11 @@ (define* (lower-inputs inputs (with-monad %store-monad (sequence %store-monad (map (match-lambda - (((? package? package) sub-drv ...) - (mlet %store-monad - ((drv (if target - (package->cross-derivation package target - system) - (package->derivation package system)))) - (return `(,drv ,@sub-drv)))) - (((? origin? origin) sub-drv ...) - (mlet %store-monad ((drv (origin->derivation origin))) + ((and ((? derivation?) sub-drv ...) input) + (return input)) + ((and ((? struct? thing) sub-drv ...) input) + (mlet* %store-monad ((lower -> (lookup-compiler thing)) + (drv (lower thing system target))) (return `(,drv ,@sub-drv)))) (input (return input))) @@ -152,14 +205,9 @@ (define lower (match-lambda ((? string? output) (return output)) - ((? package? package) - (mlet %store-monad ((drv - (if target - (package->cross-derivation package target - #:system system - #:graft? #f) - (package->derivation package system - #:graft? #f)))) + (thing + (mlet* %store-monad ((lower -> (lookup-compiler thing)) + (drv (lower thing system target))) (return (derivation->output-path drv)))))) (sequence %store-monad (map lower lst)))) @@ -302,16 +350,17 @@ (define (add-reference-inputs ref result) (match ref (($ (? derivation? drv) output) (cons `(,drv ,output) result)) - (($ (? package? pkg) output) - (cons `(,pkg ,output) result)) - (($ (? origin? o)) - (cons `(,o "out") result)) (($ (? gexp? exp)) (append (gexp-inputs exp references) result)) (($ (? string? str)) (if (direct-store-path? str) (cons `(,str) result) result)) + (($ (? struct? thing) output) + (if (lookup-compiler thing) + ;; THING is a derivation, or a package, or an origin, etc. + (cons `(,thing ,output) result) + result)) (($ (lst ...) output native?) (fold-right add-reference-inputs result ;; XXX: For now, automatically convert LST to a list of @@ -364,14 +413,6 @@ (define* (reference->sexp ref #:optional native?) (match ref (($ (? derivation? drv) output) (return (derivation->output-path drv output))) - (($ (? package? p) output n?) - (package-file p - #:output output - #:system system - #:target (if (or n? native?) #f target))) - (($ (? origin? o) output) - (mlet %store-monad ((drv (origin->derivation o))) - (return (derivation->output-path drv output)))) (($ output) ;; Output file names are not known in advance but the daemon defines ;; an environment variable for each of them at build time, so use @@ -391,6 +432,11 @@ (define* (reference->sexp ref #:optional native?) (%gexp-input ref "out" n?)) native?)) refs))) + (($ (? 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))))) (($ x) (return x)) (x -- cgit v1.2.3