diff options
| -rw-r--r-- | doc/guix.texi | 48 | ||||
| -rw-r--r-- | guix/monads.scm | 53 | ||||
| -rw-r--r-- | tests/monads.scm | 26 |
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 |