diff options
Diffstat (limited to 'guix/gexp.scm')
| -rw-r--r-- | guix/gexp.scm | 184 |
1 files changed, 135 insertions, 49 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm index 2a4b36519c..78b8af6fbc 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -37,6 +37,7 @@ gexp? with-imported-modules with-extensions + let-system gexp-input gexp-input? @@ -195,7 +196,9 @@ returns its output file name of OBJ's OUTPUT." ((? derivation? drv) (derivation->output-path drv output)) ((? string? file) - file))) + file) + ((? self-quoting? obj) + obj))) (define (register-compiler! compiler) "Register COMPILER as a gexp compiler." @@ -226,32 +229,62 @@ procedure to expand it; otherwise return #f." corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true. OBJ must be an object that has an associated gexp compiler, such as a <package>." - (match (lookup-compiler obj) - (#f - (raise (condition (&gexp-input-error (input obj))))) - (lower - ;; Cache in STORE the result of lowering OBJ. - (mlet %store-monad ((target (if (eq? target 'current) - (current-target-system) - (return target))) - (graft? (grafting?))) - (mcached (let ((lower (lookup-compiler obj))) - (lower obj system target)) - obj - system target graft?))))) + (mlet %store-monad ((target (if (eq? target 'current) + (current-target-system) + (return target))) + (graft? (grafting?))) + (let loop ((obj obj)) + (match (lookup-compiler obj) + (#f + (raise (condition (&gexp-input-error (input obj))))) + (lower + ;; Cache in STORE the result of lowering OBJ. + (mcached (mlet %store-monad ((lowered (lower obj system target))) + (if (and (struct? lowered) + (not (derivation? lowered))) + (loop lowered) + (return lowered))) + obj + system target graft?)))))) + +(define* (lower+expand-object obj + #:optional (system (%current-system)) + #:key target (output "out")) + "Return as a value in %STORE-MONAD the output of object OBJ expands to for +SYSTEM and TARGET. Object such as <package>, <file-append>, or <plain-file> +expand to file names, but it's possible to expand to a plain data type." + (let loop ((obj obj) + (expand (and (struct? obj) (lookup-expander obj)))) + (match (lookup-compiler obj) + (#f + (raise (condition (&gexp-input-error (input obj))))) + (lower + (mlet* %store-monad ((graft? (grafting?)) + (lowered (mcached (lower obj system target) + obj + system target graft?))) + ;; LOWER might return something that needs to be further + ;; lowered. + (if (struct? lowered) + ;; If we lack an expander, delegate to that of LOWERED. + (if (not expand) + (loop lowered (lookup-expander lowered)) + (return (expand obj lowered output))) + (return lowered))))))) ;self-quoting (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.) +In the simplest form of the macro, BODY must return (1) a derivation for +a record of the specified type, for SYSTEM and TARGET (the latter of which is +#f except when cross-compiling), (2) another record that can itself be +compiled down to a derivation, or (3) an object of a primitive data type. The more elaborate form allows you to specify an expander: - (define-gexp-compiler something something? + (define-gexp-compiler something-compiler <something> compiler => (lambda (param system target) ...) expander => (lambda (param drv output) ...)) @@ -299,6 +332,52 @@ The expander specifies how an object is converted to its sexp representation." ;;; +;;; System dependencies. +;;; + +;; Binding form for the current system and cross-compilation target. +(define-record-type <system-binding> + (system-binding proc) + system-binding? + (proc system-binding-proc)) + +(define-syntax let-system + (syntax-rules () + "Introduce a system binding in a gexp. The simplest form is: + + (let-system system + (cond ((string=? system \"x86_64-linux\") ...) + (else ...))) + +which binds SYSTEM to the currently targeted system. The second form is +similar, but it also shows the cross-compilation target: + + (let-system (system target) + ...) + +Here TARGET is bound to the cross-compilation triplet or #f." + ((_ (system target) exp0 exp ...) + (system-binding (lambda (system target) + exp0 exp ...))) + ((_ system exp0 exp ...) + (system-binding (lambda (system target) + exp0 exp ...))))) + +(define-gexp-compiler system-binding-compiler <system-binding> + compiler => (lambda (binding system target) + (match binding + (($ <system-binding> proc) + (with-monad %store-monad + ;; PROC is expected to return a lowerable object. + ;; 'lower-object' takes care of residualizing it to a + ;; derivation or similar. + (return (proc system target)))))) + + ;; Delegate to the expander of the object returned by PROC. + expander => #f) + + +;;; ;;; File declarations. ;;; @@ -676,6 +755,15 @@ GEXP) is false, meaning that GEXP is a plain Scheme object, return the empty list." (gexp-attribute gexp gexp-self-extensions)) +(define (self-quoting? x) + (letrec-syntax ((one-of (syntax-rules () + ((_) #f) + ((_ pred rest ...) + (or (pred x) + (one-of rest ...)))))) + (one-of symbol? string? keyword? pair? null? array? + number? boolean? char?))) + (define* (lower-inputs inputs #:key system target) "Turn any object from INPUTS into a derivation input for SYSTEM or a store @@ -684,23 +772,32 @@ When TARGET is true, use it as the cross-compilation target triplet." (define (store-item? obj) (and (string? obj) (store-path? obj))) + (define filterm + (lift1 (cut filter ->bool <>) %store-monad)) + (with-monad %store-monad - (mapm/accumulate-builds - (match-lambda - (((? struct? thing) sub-drv ...) - (mlet %store-monad ((obj (lower-object - thing system #:target target))) - (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)) - (return item))) - inputs))) + (>>= (mapm/accumulate-builds + (match-lambda + (((? struct? thing) sub-drv ...) + (mlet %store-monad ((obj (lower-object + thing system #:target target))) + (return (match obj + ((? derivation? drv) + (let ((outputs (if (null? sub-drv) + '("out") + sub-drv))) + (derivation-input drv outputs))) + ((? store-item? item) + item) + ((? self-quoting?) + ;; Some inputs such as <system-binding> can lower to + ;; a self-quoting object that FILTERM will filter + ;; out. + #f))))) + (((? store-item? item)) + (return item))) + inputs) + filterm))) (define* (lower-reference-graphs graphs #:key system target) "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a @@ -1116,15 +1213,6 @@ references; otherwise, return only non-native references." (target (%current-target-system))) "Return (monadically) the sexp corresponding to EXP for the given OUTPUT, and in the current monad setting (system type, etc.)" - (define (self-quoting? x) - (letrec-syntax ((one-of (syntax-rules () - ((_) #f) - ((_ pred rest ...) - (or (pred x) - (one-of rest ...)))))) - (one-of symbol? string? keyword? pair? null? array? - number? boolean? char?))) - (define* (reference->sexp ref #:optional native?) (with-monad %store-monad (match ref @@ -1148,12 +1236,10 @@ 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)) - (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 (expand thing obj output))))) + (let ((target (if (or n? native?) #f target))) + (lower+expand-object thing system + #:target target + #:output output))) (($ <gexp-input> (? self-quoting? x)) (return x)) (($ <gexp-input> x) |