(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 ...))))))