Compleately redid file structure.

6 files changed, 255 insertions, 0 deletions

diff --git a/monad/either.scm b/monad/either.scm
new file mode 100644
index 0000000..c597a60
--- /dev/null
+++ b/monad/either.scm
@@ -0,0 +1,30 @@
+;;; TODO UNFINISHED
+
+(define-module (data either)
+  #:use-module (oop goops)
+  #:use-module (ice-9 match))
+
+(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)
diff --git a/monad/monoid.scm b/monad/monoid.scm
new file mode 100644
index 0000000..4b10a72
--- /dev/null
+++ b/monad/monoid.scm
@@ -0,0 +1,26 @@
+;;; ???
+(define-module (monad monoid)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-1)
+  #:export (null mappend <>))
+
+(define-generic null)
+(define-generic mappend)
+
+(define (<> . args)
+  (fold mappend (null (car args)) (reverse args)))
+
+;;; Lists
+
+(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>)) '())
+
+;;; Strings
+(define-method (mappend (a <string>) (b <string>))
+  (string-append a b))
+(define-method (null (a <string>)) "")
diff --git a/monad/optional.scm b/monad/optional.scm
new file mode 100644
index 0000000..1aa1e92
--- /dev/null
+++ b/monad/optional.scm
@@ -0,0 +1,53 @@
+(define-module (monad optional)
+  #:use-module (oop goops)
+  #:use-module (ice-9 match)
+  #:use-module (monad)
+  #:use-module (ice-9 curried-definitions)
+  #:export (from-just wrap-maybe
+                      nothing just
+                      nothing? just?)
+  #:re-export (>>= >> 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 (from-just default maybe-val)
+  "Returns default if maybe-val is nothing, otherwise
+the value embedded in maybe-val"
+  (if (just? maybe-val)
+      (slot-ref maybe-val 'slot)
+      default))
+
+(define ((wrap-maybe proc) . values)
+  "Wraps a function in an optional monad, where #f returns are translated to nothing."
+  (let ((v (apply proc values)))
+    (if v (just v) (nothing))))
+
+(define-method (write (this <optional>) port)
+  (if (just? this)
+      (format port "[Just ~s]" (slot-ref this 'slot))
+      (format port "[Nothing]")))
+
+(define-method (>>= (this <optional>)
+                    (proc <procedure>))
+  (cond ((nothing? this) (nothing))
+        ((just? this)
+         (match this
+           (($ <optional> slot) (proc slot))))))
+
+(define-method (return (a <optional>)) just)
diff --git a/monad/stack.scm b/monad/stack.scm
new file mode 100644
index 0000000..8d25303
--- /dev/null
+++ b/monad/stack.scm
@@ -0,0 +1,24 @@
+(define-module (monad stack)
+  #:export (pop peek push)
+  #:use-module (monad)
+  #:use-module (monad state))
+
+;;; Simple stateful stack module for showing the state monad
+;;; in action. These functions assume that they are in a
+;;; (state list) monad. But dynamic types!
+
+;;; TODO test these for empty stack
+
+(define (pop)
+  (do st <- (get)
+      let top = (car st)
+      (put (cdr st))
+      (return-state top)))
+
+(define (peek)
+  (do st <- (get)
+      (return-state (car st))))
+
+(define (push v)
+  (do st <- (get)
+      (put (cons v st))))
diff --git a/monad/state.scm b/monad/state.scm
new file mode 100644
index 0000000..471e756
--- /dev/null
+++ b/monad/state.scm
@@ -0,0 +1,83 @@
+(define-module (monad state)
+  #:use-module (oop goops)
+  #:use-module (ice-9 match)
+  #:use-module (monad)
+  #:export (return-state run-state get put modify)
+  #:re-export (>>= >> fmap return))
+
+
+;; Alternative implementation of get.
+;; See https://hackage.haskell.org/package/mtl-2.2.1/docs/src/Control.Monad.State.Class.html#get
+
+;;; newtype State = st-list -> st-list
+
+;;; state procedure <=> st-list -> st-list
+;;; state list <=> (list ret st)
+
+;;; Wrapper around a procedure with signature:
+;;; (st-list -> st-list). Wrapped to allow goops
+;;; multiple dispatch to do its thing.
+(define-class <state> ()
+  (proc #:init-keyword #:proc
+        #:getter proc))
+
+;; (st-list -> st-list) -> State
+(define (make-state proc)
+  "Creates a state object from a State procedure"
+  (make <state> #:proc proc))
+
+;;; Define a procedure which is in the state monad. This means that it takes a
+;;; state list as a curried argument, and it's return is wrappen in a <state>
+;;; object.
+;;; It's fully possible to create stateful objects without these macros, but it's
+;;; ill adviced since that would just be boilerplate.
+
+(define-syntax-rule (define-stateful ((proc args ...) st) body ...)
+  (define (proc args ...)
+    (make-state
+     (lambda (st) body ...))))
+
+(define-syntax-rule (define-stateful-method ((proc args ...) st) body ...)
+  (define-method (proc args ...)
+    (make-state
+     (lambda (st) body ...))))
+
+(define-stateful-method ((>>= (st <state>) (f <procedure>)) st-list)
+  (let ((new-st-list ((proc st) st-list)))
+    (match new-st-list
+      ((v _)
+       ((proc (f v)) new-st-list)))))
+
+;; (define-stateful-method ((>> (a <state>) (b <state>)) st-list-a)
+;;   (let ((st-list-b ((proc a) st-list-a)))
+;;     ((proc b) st-list-b)))
+
+(define-stateful ((return-state v) st-list)
+  "Sets the return value to v"
+  (cons v (cdr st-list)))
+
+(define-method (return (a <state>)) return-state)
+
+(define-stateful ((get) st-list)
+  "Sets the return value of state to st."
+  (match st-list
+    ((_ st)
+     (list st st))))
+
+(define-stateful ((put v) st-list)
+  "Sets st to v."
+  (list '() v))
+
+(define-stateful ((modify proc) st-list)
+  (match st-list
+    ((r s)
+     (list '() (proc s)))))
+
+;; (define-stateful-method ((fmap (f <procedure>) (s <state>)) st-list)
+;;   (match ((proc s) st-list)
+;;     ((r st)
+;;      (list (f r) st))))
+
+(define-method (run-state (st <state>) init)
+  "Exec state with init as starting state value and st."
+  ((proc st) (list init init)))
diff --git a/monad/writer.scm b/monad/writer.scm
new file mode 100644
index 0000000..8be72c2
--- /dev/null
+++ b/monad/writer.scm
@@ -0,0 +1,39 @@
+(define-module (monad writer)
+  #:use-module (oop goops)
+  #:use-module (ice-9 match)
+  #:use-module (monad monoid) ; ?
+  #:use-module (monad)
+  #:export (writer return-writer))
+
+(read-enable 'curly-infix)
+
+(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 (>> (a <writer>)
+                   (b <writer>))
+  (match a (($ <writer> _ monoid-a)
+            (match b (($ <writer> val monoid-b)
+                      (writer val (<> monoid-a monoid-b))
+                      )))))
+
+;;; TODO replace this
+(define (return-writer val)
+  (writer val ""))
+
+(define-method (write (this <writer>) port)
+  (match this (($ <writer> value monoid)
+               (format port "[Writer ~s, ~s]" value monoid))))