aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorHugo Hörnquist <hugo@hornquist.se>2018-11-10 23:57:53 +0100
committerHugo Hörnquist <hugo@hornquist.se>2018-11-10 23:57:53 +0100
commitd86d88b96cd7aba976ab58b909fd4eae48323bb0 (patch)
tree0c7f93144cbe8c93a5a7c838165bd0e8a0cf24b0
parentAdd README. (diff)
downloadscheme-monad-d86d88b96cd7aba976ab58b909fd4eae48323bb0.tar.gz
scheme-monad-d86d88b96cd7aba976ab58b909fd4eae48323bb0.tar.xz
Add >>, fix do to use it.
-rw-r--r--control/monad.scm4
-rw-r--r--control/monad/procedures.scm13
-rw-r--r--data/optional.scm7
-rw-r--r--data/writer.scm9
-rw-r--r--examples.scm8
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"]