mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
Add (guix monads).
* guix/monads.scm: New file. * tests/monads.scm: New file. * Makefile.am (MODULES): Add guix/monads.scm. (SCM_TESTS): Add tests/monads.scm. * doc/guix.texi (The Store Monad): New node. (The Store): Reference it.
This commit is contained in:
parent
c8957c77d6
commit
b860f38244
5 changed files with 624 additions and 4 deletions
|
@ -16,7 +16,13 @@
|
||||||
(eval . (put 'package 'scheme-indent-function 1))
|
(eval . (put 'package 'scheme-indent-function 1))
|
||||||
(eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1))
|
(eval . (put 'substitute-keyword-arguments 'scheme-indent-function 1))
|
||||||
(eval . (put 'with-error-handling 'scheme-indent-function 0))
|
(eval . (put 'with-error-handling 'scheme-indent-function 0))
|
||||||
(eval . (put 'with-mutex 'scheme-indent-function 1))))
|
(eval . (put 'with-mutex 'scheme-indent-function 1))
|
||||||
|
|
||||||
|
(eval . (put 'syntax-parameterize 'scheme-indent-function 1))
|
||||||
|
(eval . (put 'with-monad 'scheme-indent-function 1))
|
||||||
|
(eval . (put 'mlet* 'scheme-indent-function 2))
|
||||||
|
(eval . (put 'mlet 'scheme-indent-function 2))
|
||||||
|
(eval . (put 'run-with-store 'scheme-indent-function 1))))
|
||||||
(emacs-lisp-mode . ((indent-tabs-mode . nil)))
|
(emacs-lisp-mode . ((indent-tabs-mode . nil)))
|
||||||
(texinfo-mode . ((indent-tabs-mode . nil)
|
(texinfo-mode . ((indent-tabs-mode . nil)
|
||||||
(fill-column . 72))))
|
(fill-column . 72))))
|
||||||
|
|
|
@ -40,6 +40,7 @@ MODULES = \
|
||||||
guix/records.scm \
|
guix/records.scm \
|
||||||
guix/hash.scm \
|
guix/hash.scm \
|
||||||
guix/utils.scm \
|
guix/utils.scm \
|
||||||
|
guix/monads.scm \
|
||||||
guix/serialization.scm \
|
guix/serialization.scm \
|
||||||
guix/nar.scm \
|
guix/nar.scm \
|
||||||
guix/derivations.scm \
|
guix/derivations.scm \
|
||||||
|
@ -107,6 +108,7 @@ SCM_TESTS = \
|
||||||
tests/packages.scm \
|
tests/packages.scm \
|
||||||
tests/snix.scm \
|
tests/snix.scm \
|
||||||
tests/store.scm \
|
tests/store.scm \
|
||||||
|
tests/monads.scm \
|
||||||
tests/nar.scm \
|
tests/nar.scm \
|
||||||
tests/union.scm
|
tests/union.scm
|
||||||
|
|
||||||
|
|
149
doc/guix.texi
149
doc/guix.texi
|
@ -914,9 +914,10 @@ This chapter describes all these APIs in turn, starting from high-level
|
||||||
package definitions.
|
package definitions.
|
||||||
|
|
||||||
@menu
|
@menu
|
||||||
* Defining Packages:: Defining new packages.
|
* Defining Packages:: Defining new packages.
|
||||||
* The Store:: Manipulating the package store.
|
* The Store:: Manipulating the package store.
|
||||||
* Derivations:: Low-level interface to package derivations.
|
* Derivations:: Low-level interface to package derivations.
|
||||||
|
* The Store Monad:: Purely functional interface to the store.
|
||||||
@end menu
|
@end menu
|
||||||
|
|
||||||
@node Defining Packages
|
@node Defining Packages
|
||||||
|
@ -1133,6 +1134,11 @@ derivation paths), and return when the worker is done building them.
|
||||||
Return @code{#t} on success.
|
Return @code{#t} on success.
|
||||||
@end deffn
|
@end deffn
|
||||||
|
|
||||||
|
Note that the @code{(guix monads)} module provides a monad as well as
|
||||||
|
monadic versions of the above procedures, with the goal of making it
|
||||||
|
more convenient to work with code that accesses the store (@pxref{The
|
||||||
|
Store Monad}).
|
||||||
|
|
||||||
@c FIXME
|
@c FIXME
|
||||||
@i{This section is currently incomplete.}
|
@i{This section is currently incomplete.}
|
||||||
|
|
||||||
|
@ -1272,6 +1278,143 @@ Packages}). For this reason, Guix modules that are meant to be used in
|
||||||
the build stratum are kept in the @code{(guix build @dots{})} name
|
the build stratum are kept in the @code{(guix build @dots{})} name
|
||||||
space.
|
space.
|
||||||
|
|
||||||
|
@node The Store Monad
|
||||||
|
@section The Store Monad
|
||||||
|
|
||||||
|
@cindex monad
|
||||||
|
|
||||||
|
The procedures that operate on the store described in the previous
|
||||||
|
sections all take an open connection to the build daemon as their first
|
||||||
|
argument. Although the underlying model is functional, they either have
|
||||||
|
side effects or depend on the current state of the store.
|
||||||
|
|
||||||
|
The former is inconvenient: the connection to the build daemon has to be
|
||||||
|
carried around in all those functions, making it impossible to compose
|
||||||
|
functions that do not take that parameter with functions that do. The
|
||||||
|
latter can be problematic: since store operations have side effects
|
||||||
|
and/or depend on external state, they have to be properly sequenced.
|
||||||
|
|
||||||
|
@cindex monadic values
|
||||||
|
@cindex monadic functions
|
||||||
|
This is where the @code{(guix monads)} module comes in. This module
|
||||||
|
provides a framework for working with @dfn{monads}, and a particularly
|
||||||
|
useful monad for our uses, the @dfn{store monad}. Monads are a
|
||||||
|
construct that allows two things: associating ``context'' with values
|
||||||
|
(in our case, the context is the store), and building sequences of
|
||||||
|
computations (here computations includes accesses to the store.) Values
|
||||||
|
in a monad---values that carry this additional context---are called
|
||||||
|
@dfn{monadic values}; procedures that return such values are called
|
||||||
|
@dfn{monadic procedures}.
|
||||||
|
|
||||||
|
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))))
|
||||||
|
@end example
|
||||||
|
|
||||||
|
Using @code{(guix monads)}, it may be rewritten as a monadic function:
|
||||||
|
|
||||||
|
@example
|
||||||
|
(define (profile.sh)
|
||||||
|
;; Same, but return a monadic value.
|
||||||
|
(mlet %store-monad ((bin (package-file coreutils "bin")))
|
||||||
|
(text-file "profile.sh"
|
||||||
|
(string-append "export PATH=" bin))))
|
||||||
|
@end example
|
||||||
|
|
||||||
|
There are two things to note in the second version: the @code{store}
|
||||||
|
parameter is now implicit, and the monadic value returned by
|
||||||
|
@code{package-file}---a wrapper around @code{package-derivation} and
|
||||||
|
@code{derivation->output-path}---is @dfn{bound} using @code{mlet}
|
||||||
|
instead of plain @code{let}.
|
||||||
|
|
||||||
|
Calling the monadic @code{profile.sh} has no effect. To get the desired
|
||||||
|
effect, one must use @code{run-with-store}:
|
||||||
|
|
||||||
|
@example
|
||||||
|
(run-with-store (open-connection) (profile.sh))
|
||||||
|
@result{} /nix/store/...-profile.sh
|
||||||
|
@end example
|
||||||
|
|
||||||
|
The main syntactic forms to deal with monads in general are described
|
||||||
|
below.
|
||||||
|
|
||||||
|
@deffn {Scheme Syntax} with-monad @var{monad} @var{body} ...
|
||||||
|
Evaluate any @code{>>=} or @code{return} forms in @var{body} as being
|
||||||
|
in @var{monad}.
|
||||||
|
@end deffn
|
||||||
|
|
||||||
|
@deffn {Scheme Syntax} return @var{val}
|
||||||
|
Return a monadic value that encapsulates @var{val}.
|
||||||
|
@end deffn
|
||||||
|
|
||||||
|
@deffn {Scheme Syntax} >>= @var{mval} @var{mproc}
|
||||||
|
@dfn{Bind} monadic value @var{mval}, passing its ``contents'' to monadic
|
||||||
|
procedure @var{mproc}@footnote{This operation is commonly referred to as
|
||||||
|
``bind'', but that name denotes an unrelated procedure in Guile. Thus
|
||||||
|
we use this somewhat cryptic symbol inherited from the Haskell
|
||||||
|
language.}.
|
||||||
|
@end deffn
|
||||||
|
|
||||||
|
@deffn {Scheme Syntax} mlet @var{monad} ((@var{var} @var{mval}) ...) @
|
||||||
|
@var{body} ...
|
||||||
|
@deffnx {Scheme Syntax} mlet* @var{monad} ((@var{var} @var{mval}) ...) @
|
||||||
|
@var{body} ...
|
||||||
|
Bind the variables @var{var} to the monadic values @var{mval} in
|
||||||
|
@var{body}. The form (@var{var} -> @var{val}) binds @var{var} to the
|
||||||
|
``normal'' value @var{val}, as per @code{let}.
|
||||||
|
|
||||||
|
@code{mlet*} is to @code{mlet} what @code{let*} is to @code{let}
|
||||||
|
(@pxref{Local Bindings,,, guile, GNU Guile Reference Manual}).
|
||||||
|
@end deffn
|
||||||
|
|
||||||
|
The interface to the store monad provided by @code{(guix monads)} is as
|
||||||
|
follows.
|
||||||
|
|
||||||
|
@defvr {Scheme Variable} %store-monad
|
||||||
|
The store monad. Values in the store monad encapsulate accesses to the
|
||||||
|
store. When its effect is needed, a value of the store monad must be
|
||||||
|
``evaluated'' by passing it to the @code{run-with-store} procedure (see
|
||||||
|
below.)
|
||||||
|
@end defvr
|
||||||
|
|
||||||
|
@deffn {Scheme Procedure} run-with-store @var{store} @var{mval} [#:guile-for-build] [#:system (%current-system)]
|
||||||
|
Run @var{mval}, a monadic value in the store monad, in @var{store}, an
|
||||||
|
open store connection.
|
||||||
|
@end deffn
|
||||||
|
|
||||||
|
@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}.
|
||||||
|
@end deffn
|
||||||
|
|
||||||
|
@deffn {Monadic Procedure} package-file @var{package} [@var{file}] @
|
||||||
|
[#:system (%current-system)] [#:output "out"] Return as a monadic
|
||||||
|
value in the absolute file name of @var{file} within the @var{output}
|
||||||
|
directory of @var{package}. When @var{file} is omitted, return the name
|
||||||
|
of the @var{output} directory of @var{package}.
|
||||||
|
@end deffn
|
||||||
|
|
||||||
|
@deffn {Monadic Procedure} derivation-expression @var{name} @var{system} @
|
||||||
|
@var{exp} @var{inputs} [#:outputs '("out")] [#:hash #f] @
|
||||||
|
[#:hash-algo #f] [#:env-vars '()] [#:modules '()] @
|
||||||
|
[#:references-graphs #f] [#:guile-for-build #f]
|
||||||
|
Monadic version of @code{build-expression->derivation}
|
||||||
|
(@pxref{Derivations}).
|
||||||
|
@end deffn
|
||||||
|
|
||||||
|
@deffn {Monadic Procedure} package->derivation @var{package} [@var{system}]
|
||||||
|
Monadic version of @code{package-derivation} (@pxref{Defining
|
||||||
|
Packages}).
|
||||||
|
@end deffn
|
||||||
|
|
||||||
|
|
||||||
@c *********************************************************************
|
@c *********************************************************************
|
||||||
@node Utilities
|
@node Utilities
|
||||||
@chapter Utilities
|
@chapter Utilities
|
||||||
|
|
306
guix/monads.scm
Normal file
306
guix/monads.scm
Normal file
|
@ -0,0 +1,306 @@
|
||||||
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
|
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
;;;
|
||||||
|
;;; This file is part of GNU Guix.
|
||||||
|
;;;
|
||||||
|
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||||
|
;;; under the terms of the GNU General Public License as published by
|
||||||
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||||
|
;;; your option) any later version.
|
||||||
|
;;;
|
||||||
|
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||||
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
;;; GNU General Public License for more details.
|
||||||
|
;;;
|
||||||
|
;;; You should have received a copy of the GNU General Public License
|
||||||
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
(define-module (guix monads)
|
||||||
|
#:use-module (guix records)
|
||||||
|
#:use-module (guix store)
|
||||||
|
#:use-module (guix derivations)
|
||||||
|
#:use-module (guix packages)
|
||||||
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (srfi srfi-26)
|
||||||
|
#:export (;; Monads.
|
||||||
|
monad
|
||||||
|
monad?
|
||||||
|
monad-bind
|
||||||
|
monad-return
|
||||||
|
|
||||||
|
;; Syntax.
|
||||||
|
>>=
|
||||||
|
return
|
||||||
|
with-monad
|
||||||
|
mlet
|
||||||
|
mlet*
|
||||||
|
lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift
|
||||||
|
listm
|
||||||
|
foldm
|
||||||
|
mapm
|
||||||
|
sequence
|
||||||
|
anym
|
||||||
|
|
||||||
|
;; Concrete monads.
|
||||||
|
%identity-monad
|
||||||
|
|
||||||
|
%store-monad
|
||||||
|
store-bind
|
||||||
|
store-return
|
||||||
|
store-lift
|
||||||
|
run-with-store
|
||||||
|
text-file
|
||||||
|
package-file
|
||||||
|
package->derivation
|
||||||
|
built-derivations
|
||||||
|
derivation-expression))
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
;;;
|
||||||
|
;;; This module implements the general mechanism of monads, and provides in
|
||||||
|
;;; particular an instance of the "store" monad. The API was inspired by that
|
||||||
|
;;; of Racket's "better-monads" module (see
|
||||||
|
;;; <http://planet.racket-lang.org/package-source/toups/functional.plt/1/1/planet-docs/better-monads-guide/index.html>).
|
||||||
|
;;; The implementation and use case were influenced by Oleg Kysielov's
|
||||||
|
;;; "Monadic Programming in Scheme" (see
|
||||||
|
;;; <http://okmij.org/ftp/Scheme/monad-in-Scheme.html>).
|
||||||
|
;;;
|
||||||
|
;;; The store monad allows us to (1) build sequences of operations in the
|
||||||
|
;;; store, and (2) make the store an implicit part of the execution context,
|
||||||
|
;;; rather than a parameter of every single function.
|
||||||
|
;;;
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-record-type* <monad> monad make-monad
|
||||||
|
monad?
|
||||||
|
(bind monad-bind)
|
||||||
|
(return monad-return)) ; TODO: Add 'plus' and 'zero'
|
||||||
|
|
||||||
|
(define-syntax-parameter >>=
|
||||||
|
;; The name 'bind' is already taken, so we choose this (obscure) symbol.
|
||||||
|
(lambda (s)
|
||||||
|
(syntax-violation '>>= ">>= (bind) used outside of 'with-monad'" s)))
|
||||||
|
|
||||||
|
(define-syntax-parameter return
|
||||||
|
(lambda (s)
|
||||||
|
(syntax-violation 'return "return used outside of 'with-monad'" s)))
|
||||||
|
|
||||||
|
(define-syntax with-monad
|
||||||
|
(lambda (s)
|
||||||
|
"Evaluate BODY in the context of MONAD, and return its result."
|
||||||
|
(syntax-case s ()
|
||||||
|
((_ monad body ...)
|
||||||
|
#'(syntax-parameterize ((>>= (identifier-syntax
|
||||||
|
(monad-bind monad)))
|
||||||
|
(return (identifier-syntax
|
||||||
|
(monad-return monad))))
|
||||||
|
body ...)))))
|
||||||
|
|
||||||
|
(define-syntax mlet*
|
||||||
|
(syntax-rules (->)
|
||||||
|
"Bind the given monadic values MVAL to the given variables VAR. When the
|
||||||
|
form is (VAR -> VAL), bind VAR to the non-monadic value VAL in the same way as
|
||||||
|
'let'."
|
||||||
|
;; Note: the '->' symbol corresponds to 'is:' in 'better-monads.rkt'.
|
||||||
|
((_ monad () body ...)
|
||||||
|
(with-monad monad body ...))
|
||||||
|
((_ monad ((var mval) rest ...) body ...)
|
||||||
|
(with-monad monad
|
||||||
|
(>>= mval
|
||||||
|
(lambda (var)
|
||||||
|
(mlet* monad (rest ...)
|
||||||
|
body ...)))))
|
||||||
|
((_ monad ((var -> val) rest ...) body ...)
|
||||||
|
(let ((var val))
|
||||||
|
(mlet* monad (rest ...)
|
||||||
|
body ...)))))
|
||||||
|
|
||||||
|
(define-syntax mlet
|
||||||
|
(lambda (s)
|
||||||
|
(syntax-case s ()
|
||||||
|
((_ monad ((var mval ...) ...) body ...)
|
||||||
|
(with-syntax (((temp ...) (generate-temporaries #'(var ...))))
|
||||||
|
#'(mlet* monad ((temp mval ...) ...)
|
||||||
|
(let ((var temp) ...)
|
||||||
|
body ...)))))))
|
||||||
|
|
||||||
|
(define-syntax define-lift
|
||||||
|
(syntax-rules ()
|
||||||
|
((_ liftn (args ...))
|
||||||
|
(define (liftn proc monad)
|
||||||
|
"Lift PROC to MONAD---i.e., return a monadic function in MONAD."
|
||||||
|
(lambda (args ...)
|
||||||
|
(with-monad monad
|
||||||
|
(return (proc args ...))))))))
|
||||||
|
|
||||||
|
(define-lift lift1 (a))
|
||||||
|
(define-lift lift2 (a b))
|
||||||
|
(define-lift lift3 (a b c))
|
||||||
|
(define-lift lift4 (a b c d))
|
||||||
|
(define-lift lift5 (a b c d e))
|
||||||
|
(define-lift lift6 (a b c d e f))
|
||||||
|
(define-lift lift7 (a b c d e f g))
|
||||||
|
|
||||||
|
(define (lift nargs proc monad)
|
||||||
|
"Lift PROC, a procedure that accepts NARGS arguments, to MONAD---i.e.,
|
||||||
|
return a monadic function in MONAD."
|
||||||
|
(lambda args
|
||||||
|
(with-monad monad
|
||||||
|
(return (apply proc args)))))
|
||||||
|
|
||||||
|
(define (foldm monad mproc init lst)
|
||||||
|
"Fold MPROC over LST, a list of monadic values in MONAD, and return a
|
||||||
|
monadic value seeded by INIT."
|
||||||
|
(with-monad monad
|
||||||
|
(let loop ((lst lst)
|
||||||
|
(result init))
|
||||||
|
(match lst
|
||||||
|
(()
|
||||||
|
(return result))
|
||||||
|
((head tail ...)
|
||||||
|
(mlet* monad ((item head)
|
||||||
|
(result (mproc item result)))
|
||||||
|
(loop tail result)))))))
|
||||||
|
|
||||||
|
(define (mapm monad mproc lst)
|
||||||
|
"Map MPROC over LST, a list of monadic values in MONAD, and return a monadic
|
||||||
|
list."
|
||||||
|
(foldm monad
|
||||||
|
(lambda (item result)
|
||||||
|
(mlet monad ((item (mproc item)))
|
||||||
|
(return (cons item result))))
|
||||||
|
'()
|
||||||
|
(reverse lst)))
|
||||||
|
|
||||||
|
(define-inlinable (sequence monad lst)
|
||||||
|
"Turn the list of monadic values LST into a monadic list of values, by
|
||||||
|
evaluating each item of LST in sequence."
|
||||||
|
;; FIXME: 'mapm' binds from right to left.
|
||||||
|
(with-monad monad
|
||||||
|
(mapm monad return lst)))
|
||||||
|
|
||||||
|
(define (anym monad proc lst)
|
||||||
|
"Apply PROC to the list of monadic values LST; return the first value,
|
||||||
|
lifted in MONAD, for which PROC returns true."
|
||||||
|
(with-monad monad
|
||||||
|
(let loop ((lst lst))
|
||||||
|
(match lst
|
||||||
|
(()
|
||||||
|
(return #f))
|
||||||
|
((head tail ...)
|
||||||
|
(mlet monad ((value head))
|
||||||
|
(or (and=> (proc value) return)
|
||||||
|
head
|
||||||
|
(loop tail))))))))
|
||||||
|
|
||||||
|
(define-syntax listm
|
||||||
|
(lambda (s)
|
||||||
|
"Return a monadic list in MONAD from the monadic values MVAL."
|
||||||
|
(syntax-case s ()
|
||||||
|
((_ monad mval ...)
|
||||||
|
(with-syntax (((val ...) (generate-temporaries #'(mval ...))))
|
||||||
|
#'(mlet monad ((val mval) ...)
|
||||||
|
(return (list val ...))))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Identity monad.
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define (identity-return value)
|
||||||
|
value)
|
||||||
|
|
||||||
|
(define (identity-bind mvalue mproc)
|
||||||
|
(mproc mvalue))
|
||||||
|
|
||||||
|
(define %identity-monad
|
||||||
|
(monad
|
||||||
|
(bind identity-bind)
|
||||||
|
(return identity-return)))
|
||||||
|
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Store monad.
|
||||||
|
;;;
|
||||||
|
|
||||||
|
;; return:: a -> StoreM a
|
||||||
|
(define (store-return value)
|
||||||
|
"Return VALUE from a monadic function."
|
||||||
|
;; The monadic value is just this.
|
||||||
|
(lambda (store)
|
||||||
|
value))
|
||||||
|
|
||||||
|
;; >>=:: StoreM a -> (a -> StoreM b) -> StoreM b
|
||||||
|
(define (store-bind mvalue mproc)
|
||||||
|
(lambda (store)
|
||||||
|
(let* ((value (mvalue store))
|
||||||
|
(mresult (mproc value)))
|
||||||
|
(mresult store))))
|
||||||
|
|
||||||
|
(define %store-monad
|
||||||
|
(monad
|
||||||
|
(return store-return)
|
||||||
|
(bind store-bind)))
|
||||||
|
|
||||||
|
|
||||||
|
(define (store-lift proc)
|
||||||
|
"Lift PROC, a procedure whose first argument is a connection to the store,
|
||||||
|
in the store monad."
|
||||||
|
(define result
|
||||||
|
(lambda args
|
||||||
|
(lambda (store)
|
||||||
|
(apply proc store args))))
|
||||||
|
|
||||||
|
(set-object-property! result 'documentation
|
||||||
|
(procedure-property proc 'documentation))
|
||||||
|
result)
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; Store monad operators.
|
||||||
|
;;;
|
||||||
|
|
||||||
|
(define* (text-file name text)
|
||||||
|
"Return as a monadic value the absolute file name in the store of the file
|
||||||
|
containing TEXT."
|
||||||
|
(lambda (store)
|
||||||
|
(add-text-to-store store name text '())))
|
||||||
|
|
||||||
|
(define* (package-file package
|
||||||
|
#:optional file
|
||||||
|
#:key (system (%current-system)) (output "out"))
|
||||||
|
"Return as a monadic value in the absolute file name of FILE within the
|
||||||
|
OUTPUT directory of PACKAGE. When FILE is omitted, return the name of the
|
||||||
|
OUTPUT directory of PACKAGE."
|
||||||
|
(lambda (store)
|
||||||
|
(let* ((drv (package-derivation store package system))
|
||||||
|
(out (derivation->output-path drv output)))
|
||||||
|
(if file
|
||||||
|
(string-append out "/" file)
|
||||||
|
out))))
|
||||||
|
|
||||||
|
(define derivation-expression
|
||||||
|
(store-lift build-expression->derivation))
|
||||||
|
|
||||||
|
(define package->derivation
|
||||||
|
(store-lift package-derivation))
|
||||||
|
|
||||||
|
(define built-derivations
|
||||||
|
(store-lift build-derivations))
|
||||||
|
|
||||||
|
(define* (run-with-store store mval
|
||||||
|
#:key
|
||||||
|
(guile-for-build (%guile-for-build))
|
||||||
|
(system (%current-system)))
|
||||||
|
"Run MVAL, a monadic value in the store monad, in STORE, an open store
|
||||||
|
connection."
|
||||||
|
(parameterize ((%guile-for-build (or guile-for-build
|
||||||
|
(package-derivation store
|
||||||
|
(@ (gnu packages base)
|
||||||
|
guile-final)
|
||||||
|
system)))
|
||||||
|
(%current-system system))
|
||||||
|
(mval store)))
|
||||||
|
|
||||||
|
;;; monads.scm end here
|
163
tests/monads.scm
Normal file
163
tests/monads.scm
Normal file
|
@ -0,0 +1,163 @@
|
||||||
|
;;; GNU Guix --- Functional package management for GNU
|
||||||
|
;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
|
||||||
|
;;;
|
||||||
|
;;; This file is part of GNU Guix.
|
||||||
|
;;;
|
||||||
|
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||||
|
;;; under the terms of the GNU General Public License as published by
|
||||||
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||||
|
;;; your option) any later version.
|
||||||
|
;;;
|
||||||
|
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||||
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
;;; GNU General Public License for more details.
|
||||||
|
;;;
|
||||||
|
;;; You should have received a copy of the GNU General Public License
|
||||||
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||||
|
|
||||||
|
(define-module (test-monads)
|
||||||
|
#:use-module (guix store)
|
||||||
|
#:use-module (guix monads)
|
||||||
|
#:use-module (guix derivations)
|
||||||
|
#:use-module ((guix packages)
|
||||||
|
#:select (package-derivation %current-system))
|
||||||
|
#:use-module (gnu packages)
|
||||||
|
#:use-module (gnu packages bootstrap)
|
||||||
|
#:use-module (ice-9 match)
|
||||||
|
#:use-module (rnrs io ports)
|
||||||
|
#:use-module (srfi srfi-1)
|
||||||
|
#:use-module (srfi srfi-26)
|
||||||
|
#:use-module (srfi srfi-64))
|
||||||
|
|
||||||
|
;; Test the (guix store) module.
|
||||||
|
|
||||||
|
(define %store
|
||||||
|
(open-connection))
|
||||||
|
|
||||||
|
;; Make sure we build everything by ourselves.
|
||||||
|
(set-build-options %store #:use-substitutes? #f)
|
||||||
|
|
||||||
|
(define %monads
|
||||||
|
(list %identity-monad %store-monad))
|
||||||
|
|
||||||
|
(define %monad-run
|
||||||
|
(list identity
|
||||||
|
(cut run-with-store %store <>)))
|
||||||
|
|
||||||
|
|
||||||
|
(test-begin "monads")
|
||||||
|
|
||||||
|
;; The 3 "monad laws": <http://www.haskell.org/haskellwiki/Monad_laws>.
|
||||||
|
|
||||||
|
(test-assert "left identity"
|
||||||
|
(every (lambda (monad run)
|
||||||
|
(let ((number (random 777)))
|
||||||
|
(with-monad monad
|
||||||
|
(define (f x)
|
||||||
|
(return (* (1+ number) 2)))
|
||||||
|
|
||||||
|
(= (run (>>= (return number) f))
|
||||||
|
(run (f number))))))
|
||||||
|
%monads
|
||||||
|
%monad-run))
|
||||||
|
|
||||||
|
(test-assert "right identity"
|
||||||
|
(every (lambda (monad run)
|
||||||
|
(with-monad monad
|
||||||
|
(let ((number (return (random 777))))
|
||||||
|
(= (run (>>= number return))
|
||||||
|
(run number)))))
|
||||||
|
%monads
|
||||||
|
%monad-run))
|
||||||
|
|
||||||
|
(test-assert "associativity"
|
||||||
|
(every (lambda (monad run)
|
||||||
|
(with-monad monad
|
||||||
|
(define (f x)
|
||||||
|
(return (+ 1 x)))
|
||||||
|
(define (g x)
|
||||||
|
(return (* 2 x)))
|
||||||
|
|
||||||
|
(let ((number (return (random 777))))
|
||||||
|
(= (run (>>= (>>= number f) g))
|
||||||
|
(run (>>= number (lambda (x) (>>= (f x) g))))))))
|
||||||
|
%monads
|
||||||
|
%monad-run))
|
||||||
|
|
||||||
|
(test-assert "lift"
|
||||||
|
(every (lambda (monad run)
|
||||||
|
(let ((f (lift1 1+ monad)))
|
||||||
|
(with-monad monad
|
||||||
|
(let ((number (random 777)))
|
||||||
|
(= (run (>>= (return number) f))
|
||||||
|
(1+ number))))))
|
||||||
|
%monads
|
||||||
|
%monad-run))
|
||||||
|
|
||||||
|
(test-assert "mlet* + text-file + package-file"
|
||||||
|
(run-with-store %store
|
||||||
|
(mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile"))
|
||||||
|
(file (text-file "monadic" guile)))
|
||||||
|
(return (equal? (call-with-input-file file get-string-all)
|
||||||
|
guile)))
|
||||||
|
#:guile-for-build (package-derivation %store %bootstrap-guile)))
|
||||||
|
|
||||||
|
(test-assert "mlet* + derivation-expression"
|
||||||
|
(run-with-store %store
|
||||||
|
(mlet* %store-monad ((guile (package-file %bootstrap-guile "bin/guile"))
|
||||||
|
(gdrv (package->derivation %bootstrap-guile))
|
||||||
|
(exp -> `(let ((out (assoc-ref %outputs "out")))
|
||||||
|
(mkdir out)
|
||||||
|
(symlink ,guile
|
||||||
|
(string-append out "/guile-rocks"))))
|
||||||
|
(drv (derivation-expression "rocks" (%current-system)
|
||||||
|
exp `(("g" ,gdrv))))
|
||||||
|
(out -> (derivation->output-path drv))
|
||||||
|
(built? (built-derivations (list drv))))
|
||||||
|
(return (and built?
|
||||||
|
(equal? guile
|
||||||
|
(readlink (string-append out "/guile-rocks"))))))
|
||||||
|
#:guile-for-build (package-derivation %store %bootstrap-guile)))
|
||||||
|
|
||||||
|
(test-assert "mapm"
|
||||||
|
(every (lambda (monad run)
|
||||||
|
(with-monad monad
|
||||||
|
(equal? (run (mapm monad (lift1 1+ monad) (map return (iota 10))))
|
||||||
|
(map 1+ (iota 10)))))
|
||||||
|
%monads
|
||||||
|
%monad-run))
|
||||||
|
|
||||||
|
(test-assert "sequence"
|
||||||
|
(every (lambda (monad run)
|
||||||
|
(let* ((input (iota 100))
|
||||||
|
(order '()))
|
||||||
|
(define (frob i)
|
||||||
|
;; The side effect here is used to keep track of the order in
|
||||||
|
;; which monadic values are bound.
|
||||||
|
(set! order (cons i order))
|
||||||
|
i)
|
||||||
|
|
||||||
|
(and (equal? input
|
||||||
|
(run (sequence monad
|
||||||
|
(map (lift1 frob monad) input))))
|
||||||
|
|
||||||
|
;; Make sure this is from left to right.
|
||||||
|
(equal? order (reverse input)))))
|
||||||
|
%monads
|
||||||
|
%monad-run))
|
||||||
|
|
||||||
|
(test-assert "listm"
|
||||||
|
(every (lambda (monad run)
|
||||||
|
(run (with-monad monad
|
||||||
|
(let ((lst (listm monad
|
||||||
|
(return 1) (return 2) (return 3))))
|
||||||
|
(mlet monad ((lst lst))
|
||||||
|
(return (equal? '(1 2 3) lst)))))))
|
||||||
|
%monads
|
||||||
|
%monad-run))
|
||||||
|
|
||||||
|
(test-end "monads")
|
||||||
|
|
||||||
|
|
||||||
|
(exit (= (test-runner-fail-count (test-runner-current)) 0))
|
Loading…
Reference in a new issue