Generilified return, monads now truly functors.

4 files changed, 62 insertions, 44 deletions

diff --git a/control/monad.scm b/control/monad.scm
index 2ef230c..e964b48 100644
--- a/control/monad.scm
+++ b/control/monad.scm
@@ -1,8 +1,12 @@
 (define-module (control monad)
   #:use-module (control monad procedures)
+  #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
-  #:export (do)
-  #:re-export (>> >>=))
+  #:use-module (ice-9 curried-definitions)
+  #:replace (do)
+  #:export (sequence mapM
+                     fmap <$> cmap <*>)
+  #:re-export (>> >>= return))
 
 (define-syntax do
   (syntax-rules (<- let =)
@@ -11,7 +15,43 @@
        (ptrn (do rest ...))))
     ((_ ptrn <- val rest ...)
      (>>= val (match-lambda (ptrn (do rest ...)))))
-    ((_ a) a)
+    ((_ a) a) ; Base case
     ((_ token rest ...)
      (>> token (do rest ...)))))
 
+;;; ----------------------------------------
+
+(define (fmap f m)
+  (>>= m (lambda (x) ((return m) (f x)))))
+
+(define <$> fmap)
+
+;; Curried map
+(define (cmap f)
+  (lambda (m) (fmap f m)))
+
+(define (<*> f_ i_)
+  (do f <- f_
+      i <- i_
+      ((return f_) (f i))))
+
+;;; ----------------------------------------
+
+;; sequence :: (list (M a)) → M (list a)
+(define (sequence in-list)
+  "Evaluate each monadic action in the structure from left to right, and collect
+the results. For a version that ignores the results see sequence_.
+https://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Monad.html#g:4"
+  (define ((f done) item) (append done (list item)))
+  (fold (lambda (m-item m-done)
+          #!curly-infix {{ f <$> m-done } <*> m-item })
+        ((return (car in-list)) '())
+        in-list))
+
+;; mapM :: (a -> M b) x (list a) → M (list b)
+(define (mapM proc items)
+  "Map each element of a structure to a monadic action, evaluate these actions from
+left to right, and collect the results. For a version that ignores the results
+see mapM_.
+https://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Monad.html#g:4"
+  (sequence (map proc items)))
diff --git a/control/monad/procedures.scm b/control/monad/procedures.scm
index 4be85ae..707dc0b 100644
--- a/control/monad/procedures.scm
+++ b/control/monad/procedures.scm
@@ -1,16 +1,27 @@
 (define-module (control monad procedures)
   #:use-module (oop goops)
   #:use-module (srfi srfi-1)            ; concatenate!
-  #:export (>> >>=))
+  #:export (>> >>= return))
+
+(define-generic return)
+(define-method (return (a <top>)) identity)
+(define-method (return (a <pair>)) list)
 
 (define-generic >>=)
 
+(define-method (>>= (a <top>) (proc <procedure>))
+  (proc a))
+
 (define-method (>>= (this <null>) proc) '())
 (define-method (>>= (this <pair>)
                     (proc <procedure>))
   (concatenate! (map proc this)))
 
 (define-generic >>)
+
+(define-method (>> (a <top>) (b <top>))
+  (>>= a (lambda args b)))
+
 (define-method (>> (a <null>) (b <null>)) '())
 (define-method (>> (a <pair>) (b <null>)) '())
 (define-method (>> (a <null>) (b <pair>)) '())
diff --git a/data/functor.scm b/data/functor.scm
deleted file mode 100644
index 4e4722f..0000000
--- a/data/functor.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-(define-module (data functor)
-  #:use-module (oop goops)
-  #:use-module (srfi srfi-1)
-  #:use-module (ice-9 curried-definitions)
-  #:export (fmap <$> cmap))
-
-;;; We don't overwrite the default map since that creates way to many
-;;; namespace problems.
-
-(define-generic fmap)
-(define <$> fmap)
-
-;;; Default fallback for fmap is regular (srfi-1) map.
-(define-method (fmap f . lists)
-  (apply map f lists))
-
-;; Curried map
-(define ((cmap f) item)
-  (fmap f item))
diff --git a/data/optional.scm b/data/optional.scm
index 7ab944c..61543d2 100644
--- a/data/optional.scm
+++ b/data/optional.scm
@@ -2,18 +2,16 @@
   #:use-module (oop goops)
   #:use-module (ice-9 match)
   #:use-module (control monad)
-  #:use-module (data functor)
   #:use-module (ice-9 curried-definitions)
-  #:export (nothing just
-                    nothing? just?
-                    from-just wrap-maybe
-                    return-optional)
-  #:re-export (>>= >> fmap))
+  #:export (from-just wrap-maybe
+                      nothing just
+                      nothing? just?)
+  #:re-export (>>= >> return))
 
 (define-class <optional> ()
   (slot #:init-value #f
         #:init-keyword #:slot)
-  (just  #:init-value #t
+  (just #:init-value #t
         #:init-keyword #:just))
 
 (define (nothing) (make <optional> #:just #f))
@@ -45,23 +43,11 @@ the value embedded in maybe-val"
       (format port "[Just ~s]" (slot-ref this 'slot))
       (format port "[Nothing]")))
 
-(define return-optional just)
-
 (define-method (>>= (this <optional>)
                     (proc <procedure>))
   (cond ((nothing? this) (nothing))
-        ((just? this) 
+        ((just? this)
          (match this
            (($ <optional> slot) (proc slot))))))
 
-(define-method (>> (a <optional>)
-                   (b <optional>))
-  (if (or (nothing? a)
-          (nothing? b))
-      (nothing)
-      b))
-
-(define-method (fmap (f <procedure>)
-                     (m <optional>))
-  (do x <- m
-      (return-optional (f x))))
+(define-method (return (a <optional>)) just)