diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2019-03-18 18:43:51 +0100 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2019-03-18 18:43:51 +0100 |
commit | e650a80856edc1d1df1f163c3f84082455717fa0 (patch) | |
tree | 4848ad975d95f5765980980d0e10ed0752e553f9 /monad/optional.scm | |
parent | Assorted comments and cleanup. (diff) | |
download | scheme-monad-e650a80856edc1d1df1f163c3f84082455717fa0.tar.gz scheme-monad-e650a80856edc1d1df1f163c3f84082455717fa0.tar.xz |
Compleately redid file structure.
Diffstat (limited to 'monad/optional.scm')
-rw-r--r-- | monad/optional.scm | 53 |
1 files changed, 53 insertions, 0 deletions
diff --git a/monad/optional.scm b/monad/optional.scm new file mode 100644 index 0000000..1aa1e92 --- /dev/null +++ b/monad/optional.scm @@ -0,0 +1,53 @@ +(define-module (monad optional) + #:use-module (oop goops) + #:use-module (ice-9 match) + #:use-module (monad) + #:use-module (ice-9 curried-definitions) + #:export (from-just wrap-maybe + nothing just + nothing? just?) + #:re-export (>>= >> 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 (from-just default maybe-val) + "Returns default if maybe-val is nothing, otherwise +the value embedded in maybe-val" + (if (just? maybe-val) + (slot-ref maybe-val 'slot) + default)) + +(define ((wrap-maybe proc) . values) + "Wraps a function in an optional monad, where #f returns are translated to nothing." + (let ((v (apply proc values))) + (if v (just v) (nothing)))) + +(define-method (write (this <optional>) port) + (if (just? this) + (format port "[Just ~s]" (slot-ref this 'slot)) + (format port "[Nothing]"))) + +(define-method (>>= (this <optional>) + (proc <procedure>)) + (cond ((nothing? this) (nothing)) + ((just? this) + (match this + (($ <optional> slot) (proc slot)))))) + +(define-method (return (a <optional>)) just) |