From 656fb512bf007abca6a7ac0aef6d035b7d5fce01 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Fri, 24 Jun 2022 04:48:52 +0200
Subject: Rewrote optional and either to use more GOOPS goodness.

---
 monad/optional.scm | 71 +++++++++++++++++++++++++-----------------------------
 1 file changed, 33 insertions(+), 38 deletions(-)

(limited to 'monad/optional.scm')

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 })))
-- 
cgit v1.2.3