From e650a80856edc1d1df1f163c3f84082455717fa0 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Mon, 18 Mar 2019 18:43:51 +0100
Subject: Compleately redid file structure.

---
 monad/optional.scm | 53 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 53 insertions(+)
 create mode 100644 monad/optional.scm

(limited to 'monad/optional.scm')

diff --git a/monad/optional.scm b/monad/optional.scm
new file mode 100644
index 0000000..1aa1e92
--- /dev/null
+++ b/monad/optional.scm
@@ -0,0 +1,53 @@
+(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?)
+  #:re-export (>>= >> return))
+
+(define-class <optional> ()
+  (slot #:init-value #f
+        #:init-keyword #:slot)
+  (just #:init-value #t
+        #:init-keyword #:just))
+
+(define (nothing) (make <optional> #:just #f))
+
+(define (just obj) (make <optional>
+                     #:just #t
+                     #:slot obj))
+
+(define (nothing? this)
+  (not (slot-ref this 'just)))
+
+(define (just? this)
+  (not (nothing? this)))
+
+(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))
+
+(define ((wrap-maybe proc) . values)
+  "Wraps a function in an optional monad, where #f returns are translated to nothing."
+  (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 (>>= (this <optional>)
+                    (proc <procedure>))
+  (cond ((nothing? this) (nothing))
+        ((just? this)
+         (match this
+           (($ <optional> slot) (proc slot))))))
+
+(define-method (return (a <optional>)) just)
-- 
cgit v1.2.3