summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2017-11-14 17:10:17 +0100
committerLudovic Courtès <ludo@gnu.org>2020-05-16 00:34:40 +0200
commitd03001a31a6d460b712825640dba11e3f1a53a14 (patch)
tree8f4ff9d07becf239af307ce813781ae48ce8f35c
parent8cf7dd24ab035ee6a9d2a4f667ba139f888639e5 (diff)
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.
-rw-r--r--guix/gexp.scm74
1 files changed, 51 insertions, 23 deletions
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 2a4b36519c..5c614f3e12 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -226,32 +226,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) ...))
@@ -1148,12 +1178,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)