06/06: gexp: Separate "expanders" for origins and packages from the core.

[Ludovic Courtès]

civodul pushed a commit to branch wip-extensible-gexps
in repository guix.

commit 78f7c26f19473f71ef2021b57f8bc46fa3ca9be3
Author: Ludovic Courtès <address@hidden>
Date:   Sun Mar 15 23:27:34 2015 +0100

    gexp: Separate "expanders" for origins and packages from the core.
    
    * guix/gexp.scm (<gexp-expander>): New record type.
      (%gexp-expanders): New variable.
      (register-expander!, lookup-expander): New procedures.
      (define-gexp-expander): New macro.
      (origin-expander, package-expander): New expanders.
      (lower-inputs): Remove clauses for 'origin?' and 'package?'.  Add
      clause with 'lookup-expander' instead.
      (lower-references): Likewise.
      (gexp-inputs)[add-reference-inputs]: Likewise.
      (gexp->sexp)[reference->sexp]: Likewise.
---
 guix/gexp.scm |  104 +++++++++++++++++++++++++++++++++++++++++----------------
 1 files changed, 75 insertions(+), 29 deletions(-)

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 3e5b74a..0dcd235 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -83,6 +83,63 @@
 
 (set-record-type-printer! <gexp> write-gexp)
 
+
+;;;
+;;; Methods.
+;;;
+
+;; Expander for a type of objects that may be introduced in a gexp.
+(define-record-type <gexp-expander>
+  (gexp-expander predicate lower)
+  gexp-expander?
+  (predicate  gexp-expander-predicate)
+  (lower      gexp-expander-lower))
+
+(define %gexp-expanders
+  ;; List of <gexp-expander>.
+  '())
+
+(define (register-expander! expander)
+  "Register EXPANDER as a gexp expander."
+  (set! %gexp-expanders (cons expander %gexp-expanders)))
+
+(define (lookup-expander object)
+  "Search an expander for OBJECT.  Upon success, return the three argument
+procedure to lower it; otherwise return #f."
+  (any (match-lambda
+        (($ <gexp-expander> predicate lower)
+         (and (predicate object) lower)))
+       %gexp-expanders))
+
+(define-syntax-rule (define-gexp-expander (name (predicate param)
+                                                system target)
+                      body ...)
+  "Define NAME as an expander 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-expander predicate
+                     (lambda (param system target)
+                       body ...)))
+    (register-expander! name)))
+
+(define-gexp-expander (origin-expander (origin? origin) system target)
+  ;; Expander for origins.
+  (origin->derivation origin system))
+
+(define-gexp-expander (package-expander (package? package) system target)
+  ;; Expander for packages.
+  (if target
+      (package->cross-derivation package target system)
+      (package->derivation package system)))
+
+
+;;;
+;;; Inputs & outputs.
+;;;
+
 ;; The input of a gexp.
 (define-record-type <gexp-input>
   (%gexp-input thing output native?)
@@ -116,15 +173,11 @@ the cross-compilation target triplet."
   (with-monad %store-monad
     (sequence %store-monad
               (map (match-lambda
-                    (((? package? package) sub-drv ...)
-                     (mlet %store-monad
-                         ((drv (if target
-                                   (package->cross-derivation package target
-                                                              system)
-                                   (package->derivation package system))))
-                       (return `(,drv ,@sub-drv))))
-                    (((? origin? origin) sub-drv ...)
-                     (mlet %store-monad ((drv (origin->derivation origin)))
+                    ((and ((? derivation?) sub-drv ...) input)
+                     (return input))
+                    ((and ((? struct? thing) sub-drv ...) input)
+                     (mlet* %store-monad ((lower -> (lookup-expander thing))
+                                          (drv (lower thing system target)))
                        (return `(,drv ,@sub-drv))))
                     (input
                      (return input)))
@@ -152,14 +205,9 @@ names and file names suitable for the #:allowed-references 
argument to
       (match-lambda
        ((? string? output)
         (return output))
-       ((? package? package)
-        (mlet %store-monad ((drv
-                             (if target
-                                 (package->cross-derivation package target
-                                                            #:system system
-                                                            #:graft? #f)
-                                 (package->derivation package system
-                                                      #:graft? #f))))
+       (thing
+        (mlet* %store-monad ((lower -> (lookup-expander thing))
+                             (drv      (lower thing system target)))
           (return (derivation->output-path drv))))))
 
     (sequence %store-monad (map lower lst))))
@@ -302,16 +350,17 @@ references."
     (match ref
       (($ <gexp-input> (? derivation? drv) output)
        (cons `(,drv ,output) result))
-      (($ <gexp-input> (? package? pkg) output)
-       (cons `(,pkg ,output) result))
-      (($ <gexp-input> (? origin? o))
-       (cons `(,o "out") result))
       (($ <gexp-input> (? gexp? exp))
        (append (gexp-inputs exp references) result))
       (($ <gexp-input> (? string? str))
        (if (direct-store-path? str)
            (cons `(,str) result)
            result))
+      (($ <gexp-input> (? struct? thing) output)
+       (if (lookup-expander thing)
+           ;; THING is a derivation, or a package, or an origin, etc.
+           (cons `(,thing ,output) result)
+           result))
       (($ <gexp-input> (lst ...) output native?)
        (fold-right add-reference-inputs result
                    ;; XXX: For now, automatically convert LST to a list of
@@ -364,14 +413,6 @@ and in the current monad setting (system type, etc.)"
       (match ref
         (($ <gexp-input> (? derivation? drv) output)
          (return (derivation->output-path drv output)))
-        (($ <gexp-input> (? package? p) output n?)
-         (package-file p
-                       #:output output
-                       #:system system
-                       #:target (if (or n? native?) #f target)))
-        (($ <gexp-input> (? origin? o) output)
-         (mlet %store-monad ((drv (origin->derivation o)))
-           (return (derivation->output-path drv output))))
         (($ <output-ref> output)
          ;; Output file names are not known in advance but the daemon defines
          ;; an environment variable for each of them at build time, so use
@@ -391,6 +432,11 @@ and in the current monad setting (system type, etc.)"
                                (%gexp-input ref "out" n?))
                            native?))
                         refs)))
+        (($ <gexp-input> (? struct? thing) output n?)
+         (let ((lower  (lookup-expander thing))
+               (target (if (or n? native?) #f target)))
+           (mlet %store-monad ((drv (lower thing system target)))
+             (return (derivation->output-path drv output)))))
         (($ <gexp-input> x)
          (return x))
         (x