aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorHugo Hörnquist <hugo@hornquist.se>2018-11-13 00:36:09 +0100
committerHugo Hörnquist <hugo@hornquist.se>2018-11-13 00:38:38 +0100
commitf1225201c9ded1078ef1f98fbf4969a8480d3b38 (patch)
treedfca9a64349927b9daf585939f3494b5d43742a6
parentAdd define-stateful-method. (diff)
downloadscheme-monad-f1225201c9ded1078ef1f98fbf4969a8480d3b38.tar.gz
scheme-monad-f1225201c9ded1078ef1f98fbf4969a8480d3b38.tar.xz
Add simple stateful stack implementation.
-rw-r--r--control/monad/state.scm15
-rw-r--r--data/stack.scm21
2 files changed, 33 insertions, 3 deletions
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))))