diff options
Diffstat (limited to 'monad/optional.scm')
-rw-r--r-- | monad/optional.scm | 71 |
1 files changed, 33 insertions, 38 deletions
diff --git a/monad/optional.scm b/monad/optional.scm index 06c0e67..f1f44d8 100644 --- a/monad/optional.scm +++ b/monad/optional.scm @@ -7,62 +7,57 @@ (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?) + #:export (from-just + from-maybe 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-class <optional> ()) +(define-class <nothing> (<optional>)) +(define-class <just> (<optional>) + (slot #:init-keyword #:slot + #:getter from-just)) -(define (nothing) (make <optional> #:just #f)) +(define (nothing) (make <nothing>)) -(define (just obj) (make <optional> - #:just #t - #:slot obj)) +(define (just obj) (make <just> #:slot obj)) (define (nothing? this) - (not (slot-ref this 'just))) + (is-a? this <nothing>)) (define (just? this) - (not (nothing? this))) + (is-a? this <just>)) -(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)) +;; Returns default if maybe-val is nothing, otherwise +;; the value embedded in maybe-val +(define-method (from-maybe default (_ <nothing>)) default) +(define-method (from-maybe _ (m <just>)) (from-just m)) -(define ((wrap-maybe proc) . values) +(define (wrap-maybe proc) "Wraps a function in an optional monad, where #f returns are translated to nothing." - (let ((v (apply proc values))) - (if v (just v) (nothing)))) + (lambda values + (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 (write (this <just>) port) + (format port "#<just ~s>" (from-just this))) +(define-method (write (this <nothing>) port) + (format port "#<nothing>")) -(define-method (>>= (this <optional>) - (proc <procedure>)) - (cond ((nothing? this) (nothing)) - ((just? this) - (match this - (($ <optional> slot) (proc slot)))))) +(define-method (>>= (_ <nothing>) (f <procedure>)) (nothing)) +(define-method (>>= (j <just>) (f <procedure>)) (f (from-just j))) (define-method (return (a <optional>)) just) +(define (curry arg-count proc . collected) + (if (zero? arg-count) + (apply proc collected) + (lambda (x) (apply curry (1- arg-count) proc x collected)))) + (define-method (equal? (a <optional>) (b <optional>)) (or (and (nothing? a) (nothing? b)) - (from-just #f (do aa <- a - bb <- b - (just (equal? aa bb)))))) + (from-maybe #f #!curly-infix { {(curry 2 equal?) <$> a} <*> b }))) |