diff options
Diffstat (limited to 'guix/gexp.scm')
| -rw-r--r-- | guix/gexp.scm | 131 |
1 files changed, 92 insertions, 39 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm index 302879fb42..05178a5ecc 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -63,6 +63,11 @@ scheme-file-name scheme-file-gexp + file-append + file-append? + file-append-base + file-append-suffix + gexp->derivation gexp->file gexp->script @@ -126,26 +131,41 @@ ;; Compiler for a type of objects that may be introduced in a gexp. (define-record-type <gexp-compiler> - (gexp-compiler predicate lower) + (gexp-compiler type lower expand) gexp-compiler? - (predicate gexp-compiler-predicate) - (lower gexp-compiler-lower)) + (type gexp-compiler-type) ;record type descriptor + (lower gexp-compiler-lower) + (expand gexp-compiler-expand)) ;#f | DRV -> sexp (define %gexp-compilers - ;; List of <gexp-compiler>. - '()) + ;; 'eq?' mapping of record type descriptor to <gexp-compiler>. + (make-hash-table 20)) + +(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))) + (hashq-set! %gexp-compilers + (gexp-compiler-type compiler) compiler)) (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)) + (and=> (hashq-ref %gexp-compilers (struct-vtable object)) + gexp-compiler-lower)) + +(define (lookup-expander object) + "Search for an expander for OBJECT. Upon success, return the three argument +procedure to expand it; otherwise return #f." + (and=> (hashq-ref %gexp-compilers (struct-vtable object)) + gexp-compiler-expand)) (define* (lower-object obj #:optional (system (%current-system)) @@ -157,21 +177,35 @@ 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-gexp-compiler (derivation-compiler (drv derivation?) system target) +(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 record-type) system target) body ...) + (define-gexp-compiler name record-type + compiler => (lambda (param system target) body ...) + expander => default-expander)) + ((_ name record-type + compiler => compile + expander => expand) + (begin + (define name + (gexp-compiler record-type 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 ;; compiler. (with-monad %store-monad @@ -237,7 +271,7 @@ This is the declarative counterpart of the 'interned-file' monadic procedure." 'system-error' exception is raised if FILE could not be found." (force (%local-file-absolute-file-name file))) -(define-gexp-compiler (local-file-compiler (file local-file?) system target) +(define-gexp-compiler (local-file-compiler (file <local-file>) system target) ;; "Compile" FILE by adding it to the store. (match file (($ <local-file> file (= force absolute) name recursive? select?) @@ -264,7 +298,7 @@ This is the declarative counterpart of 'text-file'." ;; them in a declarative context. (%plain-file name content '())) -(define-gexp-compiler (plain-file-compiler (file plain-file?) system target) +(define-gexp-compiler (plain-file-compiler (file <plain-file>) system target) ;; "Compile" FILE by adding it to the store. (match file (($ <plain-file> name content references) @@ -286,7 +320,7 @@ to 'gexp->derivation'. This is the declarative counterpart of 'gexp->derivation'." (%computed-file name gexp options)) -(define-gexp-compiler (computed-file-compiler (file computed-file?) +(define-gexp-compiler (computed-file-compiler (file <computed-file>) system target) ;; Compile FILE by returning a derivation whose build expression is its ;; gexp. @@ -308,7 +342,7 @@ GEXP. GUILE is the Guile package used to execute that script. This is the declarative counterpart of 'gexp->script'." (%program-file name gexp guile)) -(define-gexp-compiler (program-file-compiler (file program-file?) +(define-gexp-compiler (program-file-compiler (file <program-file>) system target) ;; Compile FILE by returning a derivation that builds the script. (match file @@ -328,13 +362,37 @@ This is the declarative counterpart of 'gexp->script'." This is the declarative counterpart of 'gexp->file'." (%scheme-file name gexp)) -(define-gexp-compiler (scheme-file-compiler (file scheme-file?) +(define-gexp-compiler (scheme-file-compiler (file <scheme-file>) system target) ;; Compile FILE by returning a derivation that builds the file. (match file (($ <scheme-file> name gexp) (gexp->file name gexp)))) +;; Appending SUFFIX to BASE's output file name. +(define-record-type <file-append> + (%file-append base suffix) + file-append? + (base file-append-base) ;<package> | <derivation> | ... + (suffix file-append-suffix)) ;list of strings + +(define (file-append base . suffix) + "Return a <file-append> object that expands to the concatenation of BASE and +SUFFIX." + (%file-append base suffix)) + +(define-gexp-compiler file-append-compiler <file-append> + compiler => (lambda (obj system target) + (match obj + (($ <file-append> base _) + (lower-object base system #:target target)))) + expander => (lambda (obj lowered output) + (match obj + (($ <file-append> base suffix) + (let* ((expand (lookup-expander base)) + (base (expand base lowered output))) + (string-append base (string-concatenate suffix))))))) + ;;; ;;; Inputs & outputs. @@ -429,8 +487,6 @@ corresponding derivation." "Based on LST, a list of output names and packages, return a list of output names and file names suitable for the #:allowed-references argument to 'derivation'." - ;; XXX: Currently outputs other than "out" are not supported, and things - ;; other than packages aren't either. (with-monad %store-monad (define lower (match-lambda @@ -706,15 +762,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 |