diff options
| -rw-r--r-- | guix/gexp.scm | 74 |
1 files changed, 52 insertions, 22 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm index b33a3f89db..8d380ec95b 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -126,27 +126,46 @@ ;; 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 lower expand) gexp-compiler? (predicate gexp-compiler-predicate) - (lower gexp-compiler-lower)) + (lower gexp-compiler-lower) + (expand gexp-compiler-expand)) ;#f | DRV -> M sexp (define %gexp-compilers ;; List of <gexp-compiler>. '()) +(define (default-expander thing obj output) + "This is the default expander for \"things\" that appear in gexps. It +returns its output file name of OBJ's OUTPUT." + (match obj + ((? derivation? drv) + (derivation->output-path drv output)) + ((? string? file) + file))) + (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 + "Search for 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 (lookup-expander object) + "Search for an expander for OBJECT. Upon success, return the three argument +procedure to expand it; otherwise return #f." + (or (any (match-lambda + (($ <gexp-compiler> predicate _ expand) + (and (predicate object) expand))) + %gexp-compilers) + default-expander)) + (define* (lower-object obj #:optional (system (%current-system)) #:key target) @@ -157,19 +176,33 @@ OBJ must be an object that has an associated gexp compiler, such as a (let ((lower (lookup-compiler obj))) (lower obj system target))) -(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-syntax define-gexp-compiler + (syntax-rules (=> compiler expander) + "Define NAME as a compiler for objects matching PREDICATE encountered in +gexps. + +In the simplest form of the macro, 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.) + +The more elaborate form allows you to specify an expander: + + (define-gexp-compiler something something? + compiler => (lambda (param system target) ...) + expander => (lambda (param drv output) ...)) + +The expander specifies how an object is converted to its sexp representation." + ((_ (name (param predicate) system target) body ...) + (define-gexp-compiler name predicate + compiler => (lambda (param system target) body ...) + expander => default-expander)) + ((_ name predicate + compiler => compile + expander => expand) + (begin + (define name + (gexp-compiler predicate compile expand)) + (register-compiler! name))))) (define-gexp-compiler (derivation-compiler (drv derivation?) system target) ;; Derivations are the lowest-level representation, so this is the identity @@ -704,15 +737,12 @@ and in the current monad setting (system type, etc.)" (or n? native?))) refs))) (($ <gexp-input> (? struct? thing) output n?) - (let ((target (if (or n? native?) #f target))) + (let ((target (if (or n? native?) #f target)) + (expand (lookup-expander thing))) (mlet %store-monad ((obj (lower-object thing system #:target target))) ;; OBJ must be either a derivation or a store file name. - (return (match obj - ((? derivation? drv) - (derivation->output-path drv output)) - ((? string? file) - file)))))) + (return (expand thing obj output))))) (($ <gexp-input> x) (return x)) (x |