From 8b091336e20946cab231bb75b5fd75f68faf80b5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@hornquist.se>
Date: Sat, 10 Nov 2018 16:09:18 +0100
Subject: Further work.

---
 state-monad.scm | 129 ++++++++++++++++++++++++++++++++++++++++++++++++++++----
 1 file changed, 120 insertions(+), 9 deletions(-)

diff --git a/state-monad.scm b/state-monad.scm
index d8d96e3..eaafe30 100644
--- a/state-monad.scm
+++ b/state-monad.scm
@@ -1,8 +1,3 @@
-runState (return "X") 1
-=> ("X", 1)
-
-;;; return set the result value but leave the state unchanged
-
 (read-enable 'curly-infix)
 
 (use-modules (oop goops)
@@ -10,9 +5,32 @@ runState (return "X") 1
              (ice-9 match)
              (srfi srfi-1))
 
-(define-generic bind)
+(define-class <monoid> ())
+
+(define-generic null)
+(define-generic mappend)
+
+(define (<> . args)
+  (fold mappend (null (car args)) (reverse args)))
+
+(define-method (mappend (a <pair>)
+                        (b <pair>))
+  (append a b))
+(define-method (mappend (a <pair>) (b <null>)) a)
+(define-method (mappend (a <null>) (b <pair>)) b)
+(define-method (mappend (a <null>) (b <null>)) '())
+(define-method (null (a <pair>)) '())
+(define-method (null (a <null>)) '())
+
+(define-macro (null type)
+  (symbol-append type '-null))
+
+(define-class <applicative> ())
+(define-generic map)
 
-(define-generic return)
+(define-class <monad> (<applicative> <monoid>))
+(define-generic bind)
+#; (define-generic return)
 
 (define-class <optional> ()
   (slot #:init-value #f
@@ -38,6 +56,32 @@ runState (return "X") 1
       (format port "[Just ~s]" (slot-ref this 'slot))
       (format port "[Nothing]")))
 
+(define-class <either> ()
+  (slot #:init-keyword #:slot)
+  (dir #:init-keyword #:dir #:init-value 'left))
+
+(define (left val)
+  "Error values"
+  (make <either> #:slot val #:dir 'left))
+
+(define (right val)
+  "Good values"
+  (make <either> #:slot val #:dir 'right))
+
+(define-method (write (this <either>) port)
+  (format port "[~a ~s]"
+          (slot-ref this 'dir)
+          (slot-ref this 'slot)))
+
+(define-method (>>= (this <either>)
+                    (proc <procedure>))
+  (case (slot-ref this 'dir)
+    ((left) this) 
+    ((right) (match this (($ <either> slot) (proc slot))))))
+
+(define return-either right)
+(define return-optional just)
+
 ;; 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
@@ -57,6 +101,26 @@ runState (return "X") 1
                     (proc <procedure>))
   (concatenate! (map proc this)))
 
+(define-class <writer> ()
+  (value #:init-keyword #:value)
+  (monoid #:init-keyword #:monoid))
+
+(define (writer value context)
+  (make <writer>
+    #:value value
+    #:monoid context))
+
+(define-method (>>= (this <writer>)
+                    (proc <procedure>))
+  (match this (($ <writer> value monoid)
+               (match (proc value)
+                 (($ <writer> nval ncontext)
+                  (writer nval { monoid <> ", " <> ncontext }))))))
+
+(define-method (write (this <writer>) port)
+  (match this (($ <writer> value monoid)
+               (format port "[Writer ~s, ~s]" value monoid))))
+
 (define-syntax do
   (syntax-rules (<- let =)
     ((_ let var = val rest ...)
@@ -69,11 +133,20 @@ runState (return "X") 1
 
 (define-syntax <-
   (lambda (x)
-    (syntax-case x (just)
+    (syntax-case x (just left right writer)
       ((_ (just var) val rest ...)
-       #'(>>= val (lambda (var) rest ...))))))
+       #'(>>= val (lambda (var) rest ...)))
+      ((_ (writer var) val rest ...)
+       #'(>>= val (lambda (var) rest ...)))
+      #; 
+      ((_ (left var) val rest ...)      ;
+      #'(>>= val (lambda (var) rest ...)))
+      #; 
+      ((_ (right var) val rest ...)     ;
+      #'(>>= val (lambda (var) rest ...))))))
 
 ;;; Examples:
+;;; These are do in the conext of the optional monad.
 
 (do (just x) <- (just 10)
     x) ; => 10
@@ -84,3 +157,41 @@ runState (return "X") 1
 
 (do (just x) <- (nothing)
     (+ x 5)) ; => [Nothing]
+
+;;;
+
+(do let either = left 10
+    (left x) <- either
+    x) ; EVALUATION ERROR
+
+;; Int -> Writer Int String
+(define (log-number n)
+  (writer n (format #f "Got nuber: ~a" n)))
+
+(define (mult-with-log)
+  (do (writer a) <- (log-number 3)
+      (writer b) <- (log-number 5)
+      (* a b)))
+
+(do (writer a) <- (log-number 1)
+    a) ; EVALUATION ERROR
+
+(begin { (log-number 1) >>= log-number })
+;; => [Writer 1, "Got nuber: 1, Got nuber: 1"]
+
+(do (writer a) <- (log-number 3)
+    (writer b) <- (log-number 5)
+    (writer (* a b) ""))
+;; EVALUATION ERROR
+;; => [Writer 3, "Got nuber: 3, base"]
+
+(log-number 3) ; => [Writer 3, "Got nuber: 3"]
+(just 1) ; => [Just 1]
+
+(do let y = 5
+    (just x) <- (just 10)
+    (just (* x y)))
+;; => [Just 50]
+
+;;; TODO
+;;; '<- and 'let can't be used after '<-
-- 
cgit v1.2.3