From d86d88b96cd7aba976ab58b909fd4eae48323bb0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@hornquist.se>
Date: Sat, 10 Nov 2018 23:57:53 +0100
Subject: Add >>, fix do to use it.

---
 control/monad.scm            |  4 ++--
 control/monad/procedures.scm | 13 +++++++++----
 data/optional.scm            |  7 +++++++
 data/writer.scm              |  9 ++++++++-
 examples.scm                 |  8 ++++++++
 5 files changed, 34 insertions(+), 7 deletions(-)

diff --git a/control/monad.scm b/control/monad.scm
index 8bc46bf..f51289d 100644
--- a/control/monad.scm
+++ b/control/monad.scm
@@ -1,7 +1,7 @@
 (define-module (control monad)
   #:use-module (control monad procedures)
   #:export (do)
-  #:re-export (>>=))
+  #:re-export (>> >>=))
 
 (define-syntax do
   (syntax-rules (<- let =)
@@ -11,5 +11,5 @@
      (>>= val (lambda (var) (do rest ...))))
     ((_ a) a)
     ((_ token rest ...)
-     (begin token (do rest ...)))))
+     (>> token (do rest ...)))))
 
diff --git a/control/monad/procedures.scm b/control/monad/procedures.scm
index 701f871..2c25d57 100644
--- a/control/monad/procedures.scm
+++ b/control/monad/procedures.scm
@@ -1,17 +1,22 @@
 (define-module (control monad procedures)
   #:use-module (oop goops)
   #:use-module (srfi srfi-1)            ; concatenate!
-  #:export (>>=))
+  #:export (>> >>=))
 
 (define-generic >>=)
 
-(define-method (>>= (this <null>)
-                    proc)
-  '())
+(define-method (>>= (this <null>) proc) '())
 (define-method (>>= (this <pair>)
                     (proc <procedure>))
   (concatenate! (map proc this)))
 
+(define-generic >>)
+(define-method (>> (a <null>) (b <null>)) '())
+(define-method (>> (a <pair>) (b <null>)) '())
+(define-method (>> (a <null>) (b <pair>)) '())
+(define-method (>> (a <pair>) (b <pair>))
+  (concatenate! (map (constant b) a)))
+
 ;; bind :: Monad m => m a -> (a -> m b) -> m b
 ;; return :: Monad m => a -> m a
 ;; map :: Functor f => (a -> b) -> f a -> f b
diff --git a/data/optional.scm b/data/optional.scm
index e71c10d..b008471 100644
--- a/data/optional.scm
+++ b/data/optional.scm
@@ -40,3 +40,10 @@
         ((just? this) 
          (match this
            (($ <optional> slot) (proc slot))))))
+
+(define-method (>> (a <optional>)
+                   (b <optional>))
+  (if (or (nothing? a)
+          (nothing? b))
+      (nothing)
+      b))
diff --git a/data/writer.scm b/data/writer.scm
index 462d391..93f3798 100644
--- a/data/writer.scm
+++ b/data/writer.scm
@@ -21,7 +21,14 @@
   (match this (($ <writer> value monoid)
                (match (proc value)
                  (($ <writer> nval ncontext)
-                  (writer nval { monoid <> ", " <> ncontext }))))))
+                  (writer nval { monoid <> ncontext }))))))
+
+(define-method (>> (a <writer>)
+                   (b <writer>))
+  (match a (($ <writer> _ monoid-a)
+            (match b (($ <writer> val monoid-b)
+                      (writer val (<> monoid-a monoid-b))
+                      )))))
 
 (define (return-writer val)
   (writer val ""))
diff --git a/examples.scm b/examples.scm
index 1fd453c..7eed583 100644
--- a/examples.scm
+++ b/examples.scm
@@ -21,6 +21,10 @@
     y <- (just 20)
     (+ x y)) ; => 30
 
+(do (just 10)
+    (nothing)
+  (just 20)) ; => [Nothing]
+
 ;;; Writer Monad, and do notation
 
 ;; Int -> Writer Int String
@@ -31,3 +35,7 @@
     b <- (log-number 5)
     (writer (* a b) ""))
 ;; => [Writer 15, "Got nuber: 3, Got nuber: 5, "]
+
+(do (log-number 3)
+    (log-number 5))
+;; => [Writer 5, "Got nuber: 3Got nuber: 5"]
-- 
cgit v1.2.3