diff options
author | Hugo Hörnquist <hugo@hornquist.se> | 2018-11-10 01:35:47 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@hornquist.se> | 2018-11-10 01:35:47 +0100 |
commit | 559d68dbc2d97925a577750f8487207c954e3862 (patch) | |
tree | b70e3160e14c6b9db867fc0f5c16e06b9201e011 | |
download | scheme-monad-559d68dbc2d97925a577750f8487207c954e3862.tar.gz scheme-monad-559d68dbc2d97925a577750f8487207c954e3862.tar.xz |
Initial commit.
-rw-r--r-- | state-monad.scm | 86 |
1 files changed, 86 insertions, 0 deletions
diff --git a/state-monad.scm b/state-monad.scm new file mode 100644 index 0000000..b261d95 --- /dev/null +++ b/state-monad.scm @@ -0,0 +1,86 @@ +runState (return "X") 1 +=> ("X", 1) + +;;; return set the result value but leave the state unchanged + +(read-enable 'curly-infix) + +(use-modules (oop goops) + (oop goops describe) + (ice-9 match) + (srfi srfi-1)) + +(define-generic bind) + +(define-generic return) + +(define-class <optional> () + (slot #:init-value #f + #:init-keyword #:slot) + (just #:init-value #t + #:init-keyword #:just)) + +(define (nothing) (make <optional> #:just #f)) + +(define (just obj) (make <optional> + #:just #t + #:slot obj)) + +(define (nothing? this) + (not (slot-ref this 'just))) + +(define (just? this) + (not (nothing? this))) + + +(define-method (write (this <optional>) port) + (if (just? this) + (format port "[Just ~s]" (slot-ref this 'slot)) + (format port "[Nothing]"))) + + +;; bind :: Monad m => m a -> (a -> m b) -> m b +;; return :: Monad m => a -> m a +;; map :: Functor f => (a -> b) -> f a -> f b + +(define-method (>>= (this <optional>) + (proc <procedure>)) + (cond ((nothing? this) nothing) + ((just? this) + (match this + (($ <optional> slot) (proc slot)))))) + +(define-method (>>= (this <null>) + proc) + '()) + +(define-method (>>= (this <pair>) + (proc <procedure>)) + (concatenate! (map proc this))) + +(define-syntax do + (syntax-rules (<- let x) + ((_ (let var = val) rest ...) + (let ((var val)) (do rest ...))) + ((_ (<- ptrn val) rest ...) + (<- ptrn val rest ...)) + ((_ a) a) + ((_ token rest ...) + (begin token (do rest ...))))) + +(define-syntax <- + (lambda (x) + (syntax-case x (just) + ((_ (just var) val rest ...) + #'(match val + (($ <optional> slot) + (let ((var slot)) + rest ...))))))) + +;;; Examples: + +(do { (just x) <- (just 10) } x) ; => 10 + +(let ((j (just 10))) + (do { (just x) <- j } + (+ x 10))) ; => 20 |