01/03: gexp: Add 'lower-object'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit c2b8467645bb2c2e17eb9c580f39e345c4dc2f4a
Author: Ludovic Courtès <address@hidden>
Date:   Wed Aug 26 11:28:23 2015 +0200

    gexp: Add 'lower-object'.
    
    * guix/gexp.scm (lower-object): New procedure.
      (lower-inputs, lower-references, gexp->sexp): Use it.
    * tests/gexp.scm ("lower-object"): New test.
    * doc/guix.texi (G-Expressions): Document it.
---
 doc/guix.texi  |   18 +++++++++++++++++-
 guix/gexp.scm  |   31 +++++++++++++++++++++----------
 tests/gexp.scm |    7 +++++++
 3 files changed, 45 insertions(+), 11 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index f05376e..39093a9 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3125,9 +3125,11 @@ and these dependencies are automatically added as inputs 
to the build
 processes that use them.
 @end itemize
 
address@hidden lowering, of high-level objects in gexps
 This mechanism is not limited to package and derivation
 objects: @dfn{compilers} able to ``lower'' other high-level objects to
-derivations can be defined, such that these objects can also be inserted
+derivations or files in the store can be defined,
+such that these objects can also be inserted
 into gexps.  For example, a useful type of high-level object that can be
 inserted in a gexp is ``file-like objects'', which make it easy to
 add files to the store and refer to them in
@@ -3400,6 +3402,20 @@ also modules containing build tools.  To make it clear 
that they are
 meant to be used in the build stratum, these modules are kept in the
 @code{(guix build @dots{})} name space.
 
address@hidden lowering, of high-level objects in gexps
+Internally, high-level objects are @dfn{lowered}, using their compiler,
+to either derivations or store items.  For instance, lowering a package
+yields a derivation, and lowering a @code{plain-file} yields a store
+item.  This is achieved using the @code{lower-object} monadic procedure.
+
address@hidden {Monadic Procedure} lower-object @var{obj} address@hidden @
+           [#:target #f]
+Return as a value in @var{%store-monad} the derivation or store item
+corresponding to @var{obj} for @var{system}, cross-compiling for
address@hidden if @var{target} is true.  @var{obj} must be an object that
+has an associated gexp compiler, such as a @code{<package>}.
address@hidden deffn
+
 
 @c *********************************************************************
 @node Utilities
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 49dcc99..6dc816d 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -53,6 +53,7 @@
 
             define-gexp-compiler
             gexp-compiler?
+            lower-object
 
             lower-inputs))
 
@@ -126,6 +127,16 @@ procedure to lower it; otherwise return #f."
          (and (predicate object) lower)))
        %gexp-compilers))
 
+(define* (lower-object obj
+                       #:optional (system (%current-system))
+                       #:key target)
+  "Return as a value in %STORE-MONAD the derivation or store item
+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>."
+  (let ((lower (lookup-compiler obj)))
+    (lower obj system target)))
+
 (define-syntax-rule (define-gexp-compiler (name (param predicate)
                                                 system target)
                       body ...)
@@ -258,8 +269,8 @@ the cross-compilation target triplet."
     (sequence %store-monad
               (map (match-lambda
                      (((? struct? thing) sub-drv ...)
-                      (mlet* %store-monad ((lower -> (lookup-compiler thing))
-                                           (drv (lower thing system target)))
+                      (mlet %store-monad ((drv (lower-object
+                                                thing system #:target target)))
                         (return `(,drv ,@sub-drv))))
                      (input
                       (return input)))
@@ -288,13 +299,13 @@ names and file names suitable for the 
#:allowed-references argument to
        ((? string? output)
         (return output))
        (($ <gexp-input> thing output native?)
-        (mlet* %store-monad ((lower -> (lookup-compiler thing))
-                             (drv      (lower thing system
-                                              (if native? #f target))))
+        (mlet %store-monad ((drv (lower-object thing system
+                                               #:target (if native?
+                                                            #f target))))
           (return (derivation->output-path drv output))))
        (thing
-        (mlet* %store-monad ((lower -> (lookup-compiler thing))
-                             (drv      (lower thing system target)))
+        (mlet %store-monad ((drv (lower-object thing system
+                                               #:target target)))
           (return (derivation->output-path drv))))))
 
     (sequence %store-monad (map lower lst))))
@@ -540,9 +551,9 @@ and in the current monad setting (system type, etc.)"
                            native?))
                         refs)))
         (($ <gexp-input> (? struct? thing) output n?)
-         (let ((lower  (lookup-compiler thing))
-               (target (if (or n? native?) #f target)))
-           (mlet %store-monad ((obj (lower thing system target)))
+         (let ((target (if (or n? native?) #f target)))
+           (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)
diff --git a/tests/gexp.scm b/tests/gexp.scm
index 0749811..492f3d6 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -654,6 +654,13 @@
     (parameterize ((%current-target-system "fooooo"))
       (derivation? (run-with-store %store mval)))))
 
+(test-assertm "lower-object"
+  (mlet %store-monad ((drv1 (lower-object %bootstrap-guile))
+                      (drv2 (lower-object (package-source coreutils)))
+                      (item (lower-object (plain-file "foo" "Hello!"))))
+    (return (and (derivation? drv1) (derivation? drv2)
+                 (store-path? item)))))
+
 (test-assert "printer"
   (string-match "^#<gexp \\(string-append .*#<package coreutils.*\
  \"/bin/uname\"\\) [[:xdigit:]]+>$"