summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-02-03 23:12:54 +0100
committerLudovic Courtès <ludo@gnu.org>2014-02-03 23:20:49 +0100
commit45adbd624f920d315259b102b923728d655a1efa (patch)
tree8f55c82395e63c58c32db0737017253b5645c288
parent67995f4beaeb97a10c455d265acc7a209fcc5312 (diff)
monads: Add 'text-file*'.
* guix/monads.scm (text-file*): New procedure. * tests/monads.scm ("text-file*"): New test. * doc/guix.texi (The Store Monad): Change example since the previous one would erroneously fail to retain a reference to Coreutils. Document 'text-file*'.
-rw-r--r--doc/guix.texi48
-rw-r--r--guix/monads.scm53
-rw-r--r--tests/monads.scm26
3 files changed, 113 insertions, 14 deletions
diff --git a/doc/guix.texi b/doc/guix.texi
index 91fa07f1a8..28b1cb8bd7 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -1590,23 +1590,22 @@ in a monad---values that carry this additional context---are called
Consider this ``normal'' procedure:
@example
-(define (profile.sh store)
- ;; Return the name of a shell script in the store that
- ;; initializes the 'PATH' environment variable.
- (let* ((drv (package-derivation store coreutils))
- (out (derivation->output-path drv)))
- (add-text-to-store store "profile.sh"
- (format #f "export PATH=~a/bin" out))))
+(define (sh-symlink store)
+ ;; Return a derivation that symlinks the 'bash' executable.
+ (let* ((drv (package-derivation store bash))
+ (out (derivation->output-path drv))
+ (sh (string-append out "/bin/bash")))
+ (build-expression->derivation store "sh"
+ `(symlink ,sh %output))))
@end example
Using @code{(guix monads)}, it may be rewritten as a monadic function:
@example
-(define (profile.sh)
+(define (sh-symlink)
;; Same, but return a monadic value.
- (mlet %store-monad ((bin (package-file coreutils "bin")))
- (text-file "profile.sh"
- (string-append "export PATH=" bin))))
+ (mlet %store-monad ((sh (package-file bash "bin")))
+ (derivation-expression "sh" `(symlink ,sh %output))))
@end example
There are two things to note in the second version: the @code{store}
@@ -1672,7 +1671,32 @@ open store connection.
@deffn {Monadic Procedure} text-file @var{name} @var{text}
Return as a monadic value the absolute file name in the store of the file
-containing @var{text}.
+containing @var{text}, a string.
+@end deffn
+
+@deffn {Monadic Procedure} text-file* @var{name} @var{text} @dots{}
+Return as a monadic value a derivation that builds a text file
+containing all of @var{text}. @var{text} may list, in addition to
+strings, packages, derivations, and store file names; the resulting
+store file holds references to all these.
+
+This variant should be preferred over @code{text-file} anytime the file
+to create will reference items from the store. This is typically the
+case when building a configuration file that embeds store file names,
+like this:
+
+@example
+(define (profile.sh)
+ ;; Return the name of a shell script in the store that
+ ;; initializes the 'PATH' environment variable.
+ (text-file* "profile.sh"
+ "export PATH=" coreutils "/bin:"
+ grep "/bin:" sed "/bin\n"))
+@end example
+
+In this example, the resulting @file{/nix/store/@dots{}-profile.sh} file
+will references @var{coreutils}, @var{grep}, and @var{sed}, thereby
+preventing them from being garbage-collected during its lifetime.
@end deffn
@deffn {Monadic Procedure} package-file @var{package} [@var{file}] @
diff --git a/guix/monads.scm b/guix/monads.scm
index ad80a0698d..db8b645402 100644
--- a/guix/monads.scm
+++ b/guix/monads.scm
@@ -23,6 +23,7 @@
#:use-module ((system syntax)
#:select (syntax-local-binding))
#:use-module (ice-9 match)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:export (;; Monads.
@@ -53,6 +54,7 @@
store-lift
run-with-store
text-file
+ text-file*
package-file
package->derivation
built-derivations
@@ -305,10 +307,59 @@ in the store monad."
(define* (text-file name text)
"Return as a monadic value the absolute file name in the store of the file
-containing TEXT."
+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))))
+
+ (mlet %store-monad ((inputs (lower-inputs inputs)))
+ (derivation-expression name (builder inputs)
+ #:inputs inputs)))
+
(define* (package-file package
#:optional file
#:key (system (%current-system)) (output "out"))
diff --git a/tests/monads.scm b/tests/monads.scm
index d3f78e1568..b51e705f01 100644
--- a/tests/monads.scm
+++ b/tests/monads.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -126,6 +126,30 @@
(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