02/02: monads: 'foldm', 'mapm', and 'anym' now take a list of regular values.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit b734996f9cf395705860703422d5e92565dd3a13
Author: Ludovic Courtès <address@hidden>
Date:   Wed May 27 09:40:19 2015 +0200

    monads: 'foldm', 'mapm', and 'anym' now take a list of regular values.
    
    * guix/monads.scm (foldm, mapm, anym): Change to take a list of regular
      values as is customary.
    * tests/monads.scm ("mapm", "anym"): Adjust accordingly.
---
 guix/monads.scm  |   46 ++++++++++++++++++++++++++++------------------
 tests/monads.scm |   13 +++++++------
 2 files changed, 35 insertions(+), 24 deletions(-)

diff --git a/guix/monads.scm b/guix/monads.scm
index f693e99..4248525 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 57a8e66..5529a61 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))