runState (return "X") 1
=> ("X", 1)

;;; return set the result value but leave the state unchanged

(read-enable 'curly-infix)

(use-modules (oop goops)
             (oop goops describe)
             (ice-9 match)
             (srfi srfi-1))

(define-generic bind)

(define-generic 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-method (write (this <optional>) port)
  (if (just? this)
      (format port "[Just ~s]" (slot-ref this 'slot))
      (format port "[Nothing]")))


;; bind :: Monad m => m a -> (a -> m b) -> m b
;; return :: Monad m => a -> m a
;; map :: Functor f => (a -> b) -> f a -> f b

(define-method (>>= (this <optional>)
                    (proc <procedure>))
  (cond ((nothing? this) nothing)
        ((just? this) 
         (match this
           (($ <optional> slot) (proc slot))))))

(define-method (>>= (this <null>)
                    proc)
  '())

(define-method (>>= (this <pair>)
                    (proc <procedure>))
  (concatenate! (map proc this)))

(define-syntax do
  (syntax-rules (<- let x)
    ((_ (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 <-
  (lambda (x)
    (syntax-case x (just)
      ((_ (just var) val rest ...)
       #'(match val
           (($ <optional> slot)
            (let ((var slot))
              rest ...)))))))

;;; Examples:

(do { (just x) <- (just 10) } x) ; => 10

(let ((j (just 10)))
  (do { (just x) <- j }
      (+ x 10))) ; => 20