From 559d68dbc2d97925a577750f8487207c954e3862 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@hornquist.se>
Date: Sat, 10 Nov 2018 01:35:47 +0100
Subject: Initial commit.

---
 state-monad.scm | 86 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 86 insertions(+)
 create mode 100644 state-monad.scm

diff --git a/state-monad.scm b/state-monad.scm
new file mode 100644
index 0000000..b261d95
--- /dev/null
+++ b/state-monad.scm
@@ -0,0 +1,86 @@
+runState (return "X") 1
+=> ("X", 1)
+
+;;; return set the result value but leave the state unchanged
+
+(read-enable 'curly-infix)
+
+(use-modules (oop goops)
+             (oop goops describe)
+             (ice-9 match)
+             (srfi srfi-1))
+
+(define-generic bind)
+
+(define-generic return)
+
+(define-class <optional> ()
+  (slot #:init-value #f
+        #:init-keyword #:slot)
+  (just  #:init-value #t
+        #:init-keyword #:just))
+
+(define (nothing) (make <optional> #:just #f))
+
+(define (just obj) (make <optional>
+                     #:just #t
+                     #:slot obj))
+
+(define (nothing? this)
+  (not (slot-ref this 'just)))
+
+(define (just? this)
+  (not (nothing? this)))
+
+
+(define-method (write (this <optional>) port)
+  (if (just? this)
+      (format port "[Just ~s]" (slot-ref this 'slot))
+      (format port "[Nothing]")))
+
+
+;; 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
+
+(define-method (>>= (this <optional>)
+                    (proc <procedure>))
+  (cond ((nothing? this) nothing)
+        ((just? this) 
+         (match this
+           (($ <optional> slot) (proc slot))))))
+
+(define-method (>>= (this <null>)
+                    proc)
+  '())
+
+(define-method (>>= (this <pair>)
+                    (proc <procedure>))
+  (concatenate! (map proc this)))
+
+(define-syntax do
+  (syntax-rules (<- let x)
+    ((_ (let var = val) rest ...)
+     (let ((var val)) (do rest ...)))
+    ((_ (<- ptrn val) rest ...)
+     (<- ptrn val rest ...))
+    ((_ a) a)
+    ((_ token rest ...)
+     (begin token (do rest ...)))))
+
+(define-syntax <-
+  (lambda (x)
+    (syntax-case x (just)
+      ((_ (just var) val rest ...)
+       #'(match val
+           (($ <optional> slot)
+            (let ((var slot))
+              rest ...)))))))
+
+;;; Examples:
+
+(do { (just x) <- (just 10) } x) ; => 10
+
+(let ((j (just 10)))
+  (do { (just x) <- j }
+      (+ x 10))) ; => 20
-- 
cgit v1.2.3