[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
04/05: monads: Rewrite 'text-file*' using gexps.
|
From: |
Ludovic Courtès |
|
Subject: |
04/05: monads: Rewrite 'text-file*' using gexps. |
|
Date: |
Mon, 12 Jan 2015 22:33:20 +0000 |
civodul pushed a commit to branch master
in repository guix.
commit 462a3fa36cddeb683df765b2982f76712f6c40f0
Author: Ludovic Courtès <address@hidden>
Date: Mon Jan 12 23:26:52 2015 +0100
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.
---
guix/gexp.scm | 17 +++++++++++++++--
guix/monads.scm | 53 +----------------------------------------------------
tests/gexp.scm | 26 +++++++++++++++++++++++++-
tests/monads.scm | 26 +-------------------------
4 files changed, 42 insertions(+), 80 deletions(-)
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 78e11f5..d13e1c4 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 <address@hidden>
+;;; Copyright © 2014, 2015 Ludovic Courtès <address@hidden>
;;;
;;; 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 65683e6..63c9cd8 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 <address@hidden>
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <address@hidden>
;;;
;;; 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 ea4df48..d80f143 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 <address@hidden>
+;;; Copyright © 2014, 2015 Ludovic Courtès <address@hidden>
;;;
;;; 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 6e3dd00..bac9feb 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 <address@hidden>
+;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <address@hidden>
;;;
;;; 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