From 68ecc10a0948aea9b7fb8db56cda270b48bf8177 Mon Sep 17 00:00:00 2001 From: Masaya Tojo Date: Mon, 10 Jun 2024 00:59:14 +0900 Subject: Add monad examples --- examples/state.scm | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) create mode 100644 examples/state.scm (limited to 'examples/state.scm') diff --git a/examples/state.scm b/examples/state.scm new file mode 100644 index 0000000..b649859 --- /dev/null +++ b/examples/state.scm @@ -0,0 +1,56 @@ +(module (data state) + (run get put map pure map2 >>=) + (import (except scheme map) + (only (chicken base) void assert) + matchable) + + (define (run m init) + (car (m init))) + + (define get + (lambda (st) + (cons st st))) + + (define (put st) + (lambda (_st) + (cons (void) st))) + + (define (map f m) + (lambda (st) + (match-let ([(x . st*) (m st)]) + (cons (f x) st*)))) + + (define (pure x) + (lambda (st) (cons x st))) + + (define (map2 f m1 m2) + (lambda (st) + (match-let* ([(x . st*) (m1 st)] + [(y . st**) (m2 st*)]) + (cons (f x y) st**)))) + + (define (>>= m f) + (lambda (st) + (match-let* ([(x . st*) (m st)] + [(x* . st**) ((f x) st*)]) + (cons x* st**))))) + +(import (only (algebraic-structs functor make)) + (only (algebraic-structs applicative make)) + (only (algebraic-structs monad make))) +(module (data state functor) = ((algebraic-structs functor make) (data state))) +(module (data state applicative) = ((algebraic-structs applicative make) (data state))) +(module (data state monad) = ((algebraic-structs monad make) (data state))) + +(import (prefix (data state) st:) + (prefix (data state functor) st:) + (prefix (data state applicative) st:) + (prefix (data state monad) st:)) + +;; (st:run (st:do (x <- st:get) +;; (let y = (* x 3)) +;; (st:put y) +;; (z <- st:get) +;; (st:pure z)) +;; 5) +;; => 15 -- cgit v1.2.3