;;; Commentary:
;;
;; Your classical optional (Maybe) monad.
;; It has the constructors @code{just} and @code{nothing}.
;;
;;; Code:

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

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