Browse Source
* 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.version-0.8.3
Ludovic Courtès
9 years ago
5 changed files with 624 additions and 4 deletions
@ -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 |
|||
@ -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 new issue