From f1225201c9ded1078ef1f98fbf4969a8480d3b38 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@hornquist.se>
Date: Tue, 13 Nov 2018 00:36:09 +0100
Subject: Add simple stateful stack implementation.

---
 control/monad/state.scm | 15 ++++++++++++---
 data/stack.scm          | 21 +++++++++++++++++++++
 2 files changed, 33 insertions(+), 3 deletions(-)
 create mode 100644 data/stack.scm

diff --git a/control/monad/state.scm b/control/monad/state.scm
index e369d5d..1097567 100644
--- a/control/monad/state.scm
+++ b/control/monad/state.scm
@@ -2,9 +2,12 @@
   #:use-module (oop goops)
   #:use-module (ice-9 match)
   #:use-module (control monad)
-  #:export (make-state return-state
-                       get put
-                       run-state)
+  #:export (return-state run-state
+                         get put
+                         ;; TODO
+                         ;; should these even be exported?
+                         define-stateful
+                         define-stateful-method)
   #:re-export (>>= >>))
 
 
@@ -28,6 +31,12 @@
   "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
diff --git a/data/stack.scm b/data/stack.scm
new file mode 100644
index 0000000..c28d648
--- /dev/null
+++ b/data/stack.scm
@@ -0,0 +1,21 @@
+(define-module (data stack)
+  #:use-module (control monad)
+  #:use-module (control 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!
+
+(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))))
-- 
cgit v1.2.3