diff options
| -rw-r--r-- | guix/monads.scm | 46 | ||||
| -rw-r--r-- | tests/monads.scm | 13 |
2 files changed, 35 insertions, 24 deletions
diff --git a/guix/monads.scm b/guix/monads.scm index f693e99a59..4248525433 100644 --- a/guix/monads.scm +++ b/guix/monads.scm @@ -225,8 +225,11 @@ MONAD---i.e., return a monadic function in 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." + "Fold MPROC over LST and return a monadic value seeded by INIT. + + (foldm %state-monad (lift2 cons %state-monad) '() '(a b c)) + => '(c b a) ;monadic +" (with-monad monad (let loop ((lst lst) (result init)) @@ -234,18 +237,21 @@ monadic value seeded by INIT." (() (return result)) ((head tail ...) - (mlet* monad ((item head) - (result (mproc item result))) - (loop tail result))))))) + (>>= (mproc head result) + (lambda (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. LST items are bound from left to right, so effects in MONAD are known -to happen in that order." + "Map MPROC over LST and return a monadic list. + + (mapm %state-monad (lift1 1+ %state-monad) '(0 1 2)) + => (1 2 3) ;monadic +" (mlet monad ((result (foldm monad (lambda (item result) - (mlet monad ((item (mproc item))) - (return (cons item result)))) + (>>= (mproc item) + (lambda (item) + (return (cons item result))))) '() lst))) (return (reverse result)))) @@ -268,20 +274,24 @@ evaluating each item of LST in sequence." (lambda (item) (seq tail (cons item result))))))))) -(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." +(define (anym monad mproc lst) + "Apply MPROC to the list of values LST; return as a monadic value the first +value for which MPROC returns a true monadic value or #f. For example: + + (anym %state-monad (lift1 odd? %state-monad) '(0 1 2)) + => #t ;monadic +" (with-monad monad (let loop ((lst lst)) (match lst (() (return #f)) ((head tail ...) - (mlet* monad ((value head) - (result -> (proc value))) - (if result - (return result) - (loop tail)))))))) + (>>= (mproc head) + (lambda (result) + (if result + (return result) + (loop tail))))))))) (define-syntax listm (lambda (s) diff --git a/tests/monads.scm b/tests/monads.scm index 57a8e66797..5529a6188a 100644 --- a/tests/monads.scm +++ b/tests/monads.scm @@ -163,7 +163,7 @@ (test-assert "mapm" (every (lambda (monad run) (with-monad monad - (equal? (run (mapm monad (lift1 1+ monad) (map return (iota 10)))) + (equal? (run (mapm monad (lift1 1+ monad) (iota 10))) (map 1+ (iota 10))))) %monads %monad-run)) @@ -202,11 +202,12 @@ (test-assert "anym" (every (lambda (monad run) (eq? (run (with-monad monad - (let ((lst (list (return 1) (return 2) (return 3)))) - (anym monad - (lambda (x) - (and (odd? x) 'odd!)) - lst)))) + (anym monad + (lift1 (lambda (x) + (and (odd? x) 'odd!)) + monad) + (append (make-list 1000 0) + (list 1 2))))) 'odd!)) %monads %monad-run)) |