mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 15:36:20 -05:00
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.
This commit is contained in:
Ludovic Courtès
parent
4a4dd5d89d
commit
462a3fa36c
4 changed files with 42 additions and 80 deletions
|
|
@ -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 @@ (define-module (guix gexp)
|
|||
gexp?
|
||||
gexp->derivation
|
||||
gexp->file
|
||||
gexp->script))
|
||||
gexp->script
|
||||
text-file*))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
|
|
@ -522,6 +523,18 @@ (define (gexp->file name exp)
|
|||
(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.
|
||||
|
|
|
|||
|
|
@ -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 @@ (define-module (guix monads)
|
|||
store-lift
|
||||
run-with-store
|
||||
text-file
|
||||
text-file*
|
||||
interned-file
|
||||
package-file
|
||||
origin->derivation
|
||||
|
|
@ -357,56 +356,6 @@ (define* (text-file name text)
|
|||
(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
|
||||
|
|
|
|||
|
|
@ -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 @@ (define shebang
|
|||
(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:]]+>$"
|
||||
|
|
|
|||
|
|
@ -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 @@ (define derivation-expression
|
|||
(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
|
||||
|
|
|
|||
Loading…
Reference in a new issue