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