1 files changed, 81 insertions, 0 deletions
diff --git a/data/optional.scm b/data/optional.scm
new file mode 100644
index 0000000..462c01b
--- /dev/null
+++ b/data/optional.scm
@@ -0,0 +1,81 @@
+(define-module (data optional)
+  #:use-module (oop goops)
+  #:use-module (ice-9 match)
+  #:use-module (control monad)
+  #:export (nothing just
+                    nothing? just?
+                    return-optional
+                    do <-)
+  ;; #:re-export (>>=)
+  )
+
+(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-method (write (this <optional>) port)
+  (if (just? this)
+      (format port "[Just ~s]" (slot-ref this 'slot))
+      (format port "[Nothing]")))
+
+(define return-optional just)
+
+(define-method (>>= (this <optional>)
+                    (proc <procedure>))
+  (cond ((nothing? this) (nothing))
+        ((just? this) 
+         (match this
+           (($ <optional> slot) (proc slot))))))
+
+#;
+(define-method (mappend (a <optional>) (b <optional>))
+  (match a
+    (($ ))))
+
+
+(define-syntax do
+  (syntax-rules (<- let =)
+    ((_ let var = val rest ...)
+     (let ((var val)) (do rest ...)))
+    ((_ ptrn <- val rest ...)
+     (<- ptrn val rest ...))
+    ((_ a) a)
+    ((_ token rest ...)
+     (begin token (do rest ...)))))
+
+(define-syntax <-
+  (syntax-rules (just writer)
+    ((_ (just var) val rest ...)
+     (>>= val (lambda (var) rest ...)))
+    ((_ (writer var) val rest ...)
+     (>>= val (lambda (var) rest ...))))
+  
+  
+  #;
+  (lambda (x)
+    (syntax-case x (just writer)
+      ((_ (just var) val rest ...)
+       #'(>>= val (lambda (var) rest ...)))
+      ((_ (writer var) val rest ...)
+       #'(>>= val (lambda (var) rest ...)))
+      #; 
+      ((_ (left var) val rest ...)      ;
+      #'(>>= val (lambda (var) rest ...)))
+      #; 
+      ((_ (right var) val rest ...)     ;
+      #'(>>= val (lambda (var) rest ...))))))