monads: Rewrite 'text-file*' using gexps.

* guix/monads.scm (text-file*): Move to...
* guix/gexp.scm (text-file*): ... here.  Rewrite using gexps.
* tests/monads.scm ("text-file*"): Move to...
* tests/gexp.scm ("text-file*"): ... here.

4 files changed, 42 insertions, 80 deletions

diff --git a/guix/gexp.scm b/guix/gexp.scm
index 78e11f5850..d13e1c46da 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -33,7 +33,8 @@
             gexp?
             gexp->derivation
             gexp->file
-            gexp->script))
+            gexp->script
+            text-file*))
 
 ;;; Commentary:
 ;;;
@@ -522,6 +523,18 @@ its search path."
                          (write '(ungexp exp) port))))
                     #:local-build? #t))
 
+(define* (text-file* name #:rest text)
+  "Return as a monadic value a derivation that builds a text file containing
+all of TEXT.  TEXT may list, in addition to strings, packages, derivations,
+and store file names; the resulting store file holds references to all these."
+  (define builder
+    (gexp (call-with-output-file (ungexp output "out")
+            (lambda (port)
+              (display (string-append (ungexp-splicing text)) port)))))
+
+  (gexp->derivation name builder))
+
+
 
 ;;;
 ;;; Syntactic sugar.
diff --git a/guix/monads.scm b/guix/monads.scm
index 65683e65de..63c9cd8cfd 100644
--- a/guix/monads.scm
+++ b/guix/monads.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -57,7 +57,6 @@
             store-lift
             run-with-store
             text-file
-            text-file*
             interned-file
             package-file
             origin->derivation
@@ -357,56 +356,6 @@ containing TEXT, a string."
   (lambda (store)
     (add-text-to-store store name text '())))
 
-(define* (text-file* name #:rest text)
-  "Return as a monadic value a derivation that builds a text file containing
-all of TEXT.  TEXT may list, in addition to strings, packages, derivations,
-and store file names; the resulting store file holds references to all these."
-  (define inputs
-    ;; Transform packages and derivations from TEXT into a valid input list.
-    (filter-map (match-lambda
-                 ((? package? p) `("x" ,p))
-                 ((? derivation? d) `("x" ,d))
-                 ((x ...) `("x" ,@x))
-                 ((? string? s)
-                  (and (direct-store-path? s) `("x" ,s)))
-                 (x x))
-                text))
-
-  (define (computed-text text inputs)
-    ;; Using the lowered INPUTS, return TEXT with derivations replaced with
-    ;; their output file name.
-    (define (real-string? s)
-      (and (string? s) (not (direct-store-path? s))))
-
-    (let loop ((inputs inputs)
-               (text   text)
-               (result '()))
-      (match text
-        (()
-         (string-concatenate-reverse result))
-        (((? real-string? head) rest ...)
-         (loop inputs rest (cons head result)))
-        ((_ rest ...)
-         (match inputs
-           (((_ (? derivation? drv) sub-drv ...) inputs ...)
-            (loop inputs rest
-                  (cons (apply derivation->output-path drv
-                               sub-drv)
-                        result)))
-           (((_ file) inputs ...)
-            ;; FILE is the result of 'add-text-to-store' or so.
-            (loop inputs rest (cons file result))))))))
-
-  (define (builder inputs)
-    `(call-with-output-file (assoc-ref %outputs "out")
-       (lambda (port)
-         (display ,(computed-text text inputs) port))))
-
-  ;; TODO: Rewrite using 'gexp->derivation'.
-  (mlet %store-monad ((inputs (lower-inputs inputs)))
-    (derivation-expression name (builder inputs)
-                           #:inputs inputs)))
-
 (define* (interned-file file #:optional name
                         #:key (recursive? #t))
   "Return the name of FILE once interned in the store.  Use NAME as its store
diff --git a/tests/gexp.scm b/tests/gexp.scm
index ea4df48403..d80f14344d 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -421,6 +421,30 @@
       (return (and (zero? (close-pipe pipe))
                    (= (expt n 2) (string->number str)))))))
 
+(test-assert "text-file*"
+  (let ((references (store-lift references)))
+    (run-with-store %store
+      (mlet* %store-monad
+          ((drv  (package->derivation %bootstrap-guile))
+           (guile -> (derivation->output-path drv))
+           (file (text-file "bar" "This is bar."))
+           (text (text-file* "foo"
+                             %bootstrap-guile "/bin/guile "
+                             `(,%bootstrap-guile "out") "/bin/guile "
+                             drv "/bin/guile "
+                             file))
+           (done (built-derivations (list text)))
+           (out -> (derivation->output-path text))
+           (refs (references out)))
+        ;; Make sure we get the right references and the right content.
+        (return (and (lset= string=? refs (list guile file))
+                     (equal? (call-with-input-file out get-string-all)
+                             (string-append guile "/bin/guile "
+                                            guile "/bin/guile "
+                                            guile "/bin/guile "
+                                            file)))))
+      #:guile-for-build (package-derivation %store %bootstrap-guile))))
+
 (test-assert "printer"
   (string-match "^#<gexp \\(string-append .*#<package coreutils.*\
  \"/bin/uname\"\\) [[:xdigit:]]+>$"
diff --git a/tests/monads.scm b/tests/monads.scm
index 6e3dd00f72..bac9feb97a 100644
--- a/tests/monads.scm
+++ b/tests/monads.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -177,30 +177,6 @@
                            (readlink (string-append out "/guile-rocks"))))))
     #:guile-for-build (package-derivation %store %bootstrap-guile)))
 
-(test-assert "text-file*"
-  (let ((references (store-lift references)))
-    (run-with-store %store
-      (mlet* %store-monad
-          ((drv  (package->derivation %bootstrap-guile))
-           (guile -> (derivation->output-path drv))
-           (file (text-file "bar" "This is bar."))
-           (text (text-file* "foo"
-                             %bootstrap-guile "/bin/guile "
-                             `(,%bootstrap-guile "out") "/bin/guile "
-                             drv "/bin/guile "
-                             file))
-           (done (built-derivations (list text)))
-           (out -> (derivation->output-path text))
-           (refs (references out)))
-        ;; Make sure we get the right references and the right content.
-        (return (and (lset= string=? refs (list guile file))
-                     (equal? (call-with-input-file out get-string-all)
-                             (string-append guile "/bin/guile "
-                                            guile "/bin/guile "
-                                            guile "/bin/guile "
-                                            file)))))
-      #:guile-for-build (package-derivation %store %bootstrap-guile))))
-
 (test-assert "mapm"
   (every (lambda (monad run)
            (with-monad monad