futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
* 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.
This commit is contained in:
Ludovic Courtès 2015-01-12 23:26:52 +01:00
parent 4a4dd5d89d
commit 462a3fa36c
4 changed files with 42 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
guix/gexp.scm
View File

@ -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.

53
guix/monads.scm
View File

@ -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

26
tests/gexp.scm
View File

@ -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:]]+>$"

26
tests/monads.scm
View File

@ -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