gexp: Compilers can now return lowerable objects.

* guix/gexp.scm (lower-object): Iterate if LOWERED is a struct.
(lower+expand-object): New procedure.
(gexp->sexp): Use it.
(define-gexp-compiler): Adjust docstring.
This commit is contained in:
Ludovic Courtès 2017-11-14 17:10:17 +01:00
parent 8cf7dd24ab
commit d03001a31a
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 51 additions and 23 deletions

View File

@ -226,32 +226,62 @@ procedure to expand it; otherwise return #f."
corresponding to OBJ for SYSTEM, cross-compiling for TARGET if TARGET is true. 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 OBJ must be an object that has an associated gexp compiler, such as a
<package>." <package>."
(match (lookup-compiler obj) (mlet %store-monad ((target (if (eq? target 'current)
(#f (current-target-system)
(raise (condition (&gexp-input-error (input obj))))) (return target)))
(lower (graft? (grafting?)))
;; Cache in STORE the result of lowering OBJ. (let loop ((obj obj))
(mlet %store-monad ((target (if (eq? target 'current) (match (lookup-compiler obj)
(current-target-system) (#f
(return target))) (raise (condition (&gexp-input-error (input obj)))))
(graft? (grafting?))) (lower
(mcached (let ((lower (lookup-compiler obj))) ;; Cache in STORE the result of lowering OBJ.
(lower obj system target)) (mcached (mlet %store-monad ((lowered (lower obj system target)))
obj (if (and (struct? lowered)
system target graft?))))) (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 (define-syntax define-gexp-compiler
(syntax-rules (=> compiler expander) (syntax-rules (=> compiler expander)
"Define NAME as a compiler for objects matching PREDICATE encountered in "Define NAME as a compiler for objects matching PREDICATE encountered in
gexps. gexps.
In the simplest form of the macro, BODY must return a derivation for PARAM, an In the simplest form of the macro, BODY must return (1) a derivation for
object that matches PREDICATE, for SYSTEM and TARGET (the latter of which is a record of the specified type, for SYSTEM and TARGET (the latter of which is
#f except when cross-compiling.) #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: 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) ...) compiler => (lambda (param system target) ...)
expander => (lambda (param drv output) ...)) expander => (lambda (param drv output) ...))
@ -1148,12 +1178,10 @@ and in the current monad setting (system type, etc.)"
(or n? native?))) (or n? native?)))
refs)) refs))
(($ <gexp-input> (? struct? thing) output n?) (($ <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))) (lower+expand-object thing system
(mlet %store-monad ((obj (lower-object thing system #:target target
#:target target))) #:output output)))
;; OBJ must be either a derivation or a store file name.
(return (expand thing obj output)))))
(($ <gexp-input> (? self-quoting? x)) (($ <gexp-input> (? self-quoting? x))
(return x)) (return x))
(($ <gexp-input> x) (($ <gexp-input> x)