From ebdfd776f4504c456d383ee8afa59fc6fdfc6756 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 9 Sep 2016 22:43:41 +0200
Subject: gexp: Compilers can now provide an "expander".

* guix/gexp.scm (<gexp-compiler>)[expand]: New field.
(default-expander, lookup-expander): New procedures.
(define-gexp-compiler): Add second pattern to allow for the definition
of both a compiler and an expander.
(gexp->sexp)[reference->sexp]: Call 'lookup-expander' and use its
result.
---
 guix/gexp.scm | 74 +++++++++++++++++++++++++++++++++++++++++------------------
 1 file 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
-- 
cgit 1.4.1