initial commit

5 files changed, 178 insertions, 0 deletions

diff --git a/monad/core.scm b/monad/core.scm
new file mode 100644
index 0000000..f338dab
--- /dev/null
+++ b/monad/core.scm
@@ -0,0 +1,32 @@
+(define-module (monad core)
+  #:use-module (srfi srfi-9)
+  #:export (make-monad with-monad: monad? monad-bind monad-return))
+
+(define-record-type monad
+  (make-monad bind return)
+  monad?
+  (bind monad-bind)
+  (return monad-return))
+
+;; TODO: try to refactor let bindings
+(define-syntax with-monad:
+  (lambda (x)
+    (with-syntax ((return (datum->syntax x 'return))
+                  (>>=    (datum->syntax x '>>=)))
+      (syntax-case x (<-)
+        ((_ monad action)
+         #'(let ((return (monad-return monad))
+                 (>>=    (monad-bind   monad)))
+             action))
+        ((_ monad (res <- action) exp ...)
+         #'(let ((return (monad-return monad))
+                 (>>=    (monad-bind   monad)))
+             (>>= action
+                  (lambda (res)
+                    (with-monad: monad exp ...)))))
+        ((_ monad action exp ...)
+         #'(let ((return (monad-return monad))
+                 (>>=    (monad-bind   monad)))
+             (>>= action
+                  (lambda (_)
+                    (with-monad: monad exp ...)))))))))
diff --git a/monad/either.scm b/monad/either.scm
new file mode 100644
index 0000000..91725b2
--- /dev/null
+++ b/monad/either.scm
@@ -0,0 +1,24 @@
+(define-module (monad either)
+  #:use-module (monad core)
+  #:use-module (srfi srfi-9)
+  #:use-module (ice-9 match)
+  #:re-export (with-monad:)
+  #:export (either-monad
+            Left Right))
+
+(define-record-type :Left
+  (Left v) left? (v from-left))
+(define-record-type :Right
+  (Right v) right? (v from-right))
+
+(define (return a)
+  (Right a))
+
+(define (>>= m f)
+  (match m
+    (($ :Right v)
+     (f v))
+    (($ :Left v)
+     m)))
+
+(define either-monad (make-monad >>= return))
diff --git a/monad/maybe.scm b/monad/maybe.scm
new file mode 100644
index 0000000..fdf4de7
--- /dev/null
+++ b/monad/maybe.scm
@@ -0,0 +1,26 @@
+(define-module (monad maybe)
+  #:use-module (monad core)
+  #:use-module (srfi srfi-9)
+  #:use-module (ice-9 match)
+  #:re-export (with-monad:)
+  #:export (maybe-monad
+            Just just? from-just
+            Nothing))
+
+(define-record-type :Just
+  (Just v) just? (v from-just))
+
+(define-record-type :Nothing
+  (Nothing) Nothing?)
+
+(define (return a)
+  (Just a))
+
+(define (>>= m f)
+  (match m
+    (($ :Just v)
+     (f v))
+    (($ :Nothing)
+     m)))
+
+(define maybe-monad (make-monad >>= return))
diff --git a/monad/state.scm b/monad/state.scm
new file mode 100644
index 0000000..86a5c75
--- /dev/null
+++ b/monad/state.scm
@@ -0,0 +1,34 @@
+(define-module (monad state)
+  #:use-module (monad core)
+  #:re-export (with-monad:)
+  #:export (state-monad run-state
+            get put modify))
+
+(define (return x)
+  (lambda (state)
+    (cons x state)))
+
+(define (>>= m f)
+  (lambda (old-state)
+    (let ((state-pair (m old-state)))
+      ((f (car state-pair)) (cdr state-pair)))))
+
+(define state-monad (make-monad >>= return))
+
+(define (run-state initial-state m)
+  (car (m initial-state)))
+
+;; Examine the state at this point in the computation.
+(define (get)
+  (lambda (s)
+    (cons s s)))
+
+;; replace the state
+(define (put s)
+  (lambda (_)
+    (cons #f s)))
+
+;; update the state
+(define (modify f)
+  (lambda (s)
+    (cons #f (f s))))
diff --git a/test.scm b/test.scm
new file mode 100644
index 0000000..c0e7297
--- /dev/null
+++ b/test.scm
@@ -0,0 +1,62 @@
+(set! %load-path (cons "." %load-path))
+(use-modules (monad maybe)
+             (monad either)
+             (monad state))
+
+(define (test name expr expectation)
+  (let ((res (eval expr (interaction-environment))))
+    (if (equal? res expectation)
+      (format #t "[~s] passed\n" name)
+      (format #t "[~s] ERROR: expected: ~s, but got: ~s\n" name expectation res))))
+
+(define (f x)
+  (if (> x 0)
+      (Just x)
+      (Nothing)))
+
+(begin
+  (test "maybe 1"
+        '(with-monad: maybe-monad
+              (a <- (Just 5))
+              (b <- (f 2))
+              (c <- (Just 10))
+              (return (+ a b c)))
+        (Just 17))
+
+  (test "maybe 2"
+        '(with-monad: maybe-monad
+              (a <- (Just 5))
+              (b <- (f 0))
+              (c <- (Just 10))
+              (return (+ a b c)))
+        (Nothing))
+
+  (test "state 1"
+        '(run-state 0 (with-monad: state-monad
+                           (put 10)
+                           (put 9)
+                           (modify (lambda (x) (+ 2 x)))
+                           (modify (lambda (x) (+ 2 x)))
+                           (get)))
+        13)
+
+  (test "state 2"
+        '(run-state 10 (with-monad: state-monad
+                            (get)))
+        10)
+
+  (test "either 1"
+        '(with-monad: either-monad
+              (a <- (Right 5))
+              (b <- (Right 0))
+              (c <- (Right 10))
+              (return (+ a b c)))
+        (Right 15))
+
+  (test "either 2"
+        '(with-monad: either-monad
+              (a <- (Right 5))
+              (b <- (Left "an error"))
+              (c <- (Right 10))
+              (return (+ a b c)))
+        (Left "an error")))