diff options
Diffstat (limited to '')
-rw-r--r-- | monad/either.scm | 33 | ||||
-rw-r--r-- | monad/optional.scm | 71 |
2 files changed, 49 insertions, 55 deletions
diff --git a/monad/either.scm b/monad/either.scm index c597a60..c8f6487 100644 --- a/monad/either.scm +++ b/monad/either.scm @@ -1,30 +1,29 @@ -;;; TODO UNFINISHED - -(define-module (data either) +(define-module (monad either) #:use-module (oop goops) - #:use-module (ice-9 match)) + #:use-module (monad) + #:export (left right) + #:re-export (>>= >> return) + ) (define-class <either> () - (slot #:init-keyword #:slot) - (dir #:init-keyword #:dir #:init-value 'left)) + (slot #:init-keyword #:slot + #:getter unwrap-either)) +(define-class <left> (<either>)) +(define-class <right> (<either>)) (define (left val) "Error values" - (make <either> #:slot val #:dir 'left)) + (make <left> #:slot val)) (define (right val) "Good values" - (make <either> #:slot val #:dir 'right)) + (make <right> #:slot val)) (define-method (write (this <either>) port) - (format port "[~a ~s]" - (slot-ref this 'dir) - (slot-ref this 'slot))) + (format port "#<~a ~s>" (class-name (class-of this)) (unwrap-either this))) -(define-method (>>= (this <either>) - (proc <procedure>)) - (case (slot-ref this 'dir) - ((left) this) - ((right) (match this (($ <either> slot) (proc slot)))))) +(define-method (>>= (this <left>) (_ <procedure>)) this) +(define-method (>>= (this <right>) (proc <procedure>)) + (proc (unwrap-either this))) -(define return-either right) +(define-method (return (_ <either>)) right) 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 }))) |