aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorHugo Hörnquist <hugo@lysator.liu.se>2022-06-24 04:48:52 +0200
committerHugo Hörnquist <hugo@lysator.liu.se>2022-06-24 04:48:52 +0200
commit656fb512bf007abca6a7ac0aef6d035b7d5fce01 (patch)
tree3e5837bb18b3328ddd7a69f08d71a19730e5d8a8
parentAdd MIT-License. (diff)
downloadscheme-monad-656fb512bf007abca6a7ac0aef6d035b7d5fce01.tar.gz
scheme-monad-656fb512bf007abca6a7ac0aef6d035b7d5fce01.tar.xz
Rewrote optional and either to use more GOOPS goodness.HEADmaster
-rw-r--r--monad/either.scm33
-rw-r--r--monad/optional.scm71
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 })))