aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--examples/optional.scm71
-rw-r--r--examples/state.scm56
2 files changed, 127 insertions, 0 deletions
diff --git a/examples/optional.scm b/examples/optional.scm
new file mode 100644
index 0000000..e3f2eec
--- /dev/null
+++ b/examples/optional.scm
@@ -0,0 +1,71 @@
+(module (data optional) (<some> some some? some-value <none> none none?)
+ (import scheme
+ (chicken base)
+ (chicken format))
+
+ (define-record-type <some>
+ (some value)
+ some?
+ (value some-value))
+
+ (set! (record-printer <some>)
+ (lambda (x out)
+ (fprintf out "#<(some ~S)>" (some-value x))))
+
+ (define-record-type <none>
+ (none)
+ none?)
+
+ (set! (record-printer <none>)
+ (lambda (_ out)
+ (fprintf out "#<(none)>"))))
+
+(module (data optional monad base) (pure map map2 >>=)
+ (import (except scheme map)
+ (prefix (data optional) opt:)
+ matchable)
+
+ (define (map f opt)
+ (match opt
+ [($ opt:<some> x) (opt:some (f x))]
+ [($ opt:<none>) (opt:none)]))
+
+ (define (pure x)
+ (opt:some x))
+
+ (define (map2 f opt1 opt2)
+ (match opt1
+ [($ opt:<some> x)
+ (match opt2
+ [($ opt:<some> y) (opt:some (f x y))]
+ [($ opt:<none>) (opt:none)])]
+ [($ opt:<none>) (opt:none)]))
+
+ (define (>>= opt f)
+ (match opt
+ [($ opt:<some> x) (f x)]
+ [($ opt:<none>) (opt:none)])))
+
+(import (only (algebraic-structs functor make))
+ (only (algebraic-structs applicative make))
+ (only (algebraic-structs monad make)))
+
+(module (data optional functor) = ((algebraic-structs functor make) (data optional monad base)))
+(module (data optional applicative) = ((algebraic-structs applicative make) (data optional monad base)))
+(module (data optional monad) = ((algebraic-structs monad make) (data optional monad base)))
+
+(import (prefix (data optional) opt:)
+ (prefix (data optional functor) opt:)
+ (prefix (data optional applicative) opt:)
+ (prefix (data optional monad) opt:))
+
+;; (opt:map (lambda (x) (* x x)) (opt:pure 5)) => (some 25)
+;; (opt:map (lambda (x) (* x x)) (opt:none)) => (none)
+
+;; (opt:map* + (opt:pure 1) (opt:pure 2) (opt:pure 3)) => (some 6)
+;; (opt:map* + (opt:pure 1) (opt:none) (opt:pure 3)) => (none)
+
+;; (opt:do (x <- (opt:pure 3))
+;; (y <- (opt:pure 4))
+;; (opt:pure (+ x y)))
+;; => (some 7)
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