Rewrote optional and either to use more GOOPS goodness.HEADmaster

1 files changed, 16 insertions, 17 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)