diff options
author | Hugo Hörnquist <hugo@hornquist.se> | 2018-11-13 00:01:36 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@hornquist.se> | 2018-11-13 00:01:36 +0100 |
commit | 8339e30f7b8f4219852a63ce9e9a181d1a69a86d (patch) | |
tree | 748d808cbb785f46e789476e7564f4d83a821eb4 /control/monad | |
parent | Move examples.scm to directory. (diff) | |
download | scheme-monad-8339e30f7b8f4219852a63ce9e9a181d1a69a86d.tar.gz scheme-monad-8339e30f7b8f4219852a63ce9e9a181d1a69a86d.tar.xz |
Add propper (control monad state).
Diffstat (limited to '')
-rw-r--r-- | control/monad/state.scm | 66 |
1 files changed, 66 insertions, 0 deletions
diff --git a/control/monad/state.scm b/control/monad/state.scm new file mode 100644 index 0000000..7e81b38 --- /dev/null +++ b/control/monad/state.scm @@ -0,0 +1,66 @@ +(define-module (control monad state) + #:use-module (oop goops) + #:use-module (ice-9 match) + #:use-module (control monad) + #:export (make-state return-state + get put + run-state) + #:re-export (>>= >>)) + + +;; 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-method (>>= (st <state>) f) + (lambda (st-list) + (let ((new-st-list ((proc st) st-list))) + (match new-st-list + ((v _) + ((proc (f v)) new-st-list)))))) + +(define-method (>> (a <state>) (b <state>)) + (lambda (st-list-a) + (let ((st-list-b ((proc a) st-list-a))) + ((proc b) st-list-b)))) + +(define (return-state v) + "Sets the return value to v" + (make-state + (lambda (st-list) + (cons v (cdr st-list))))) + +(define (get) + "Sets the return value of state to st." + (make-state + (lambda (st-list) + (match st-list + ((_ st) + (list st st)))))) + +(define (put v) + "Sets st to v." + (make-state + (lambda (st-list) + (list '() v)))) + +(define-method (run-state st-proc init) + "Exec state with init as starting state value and st." + (st-proc (list init init))) + |