(read-enable 'curly-infix)

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

(define-class <monoid> ())

(define-generic null)
(define-generic mappend)

(define (<> . args)
  (fold mappend (null (car args)) (reverse args)))

(define-method (mappend (a <pair>)
                        (b <pair>))
  (append a b))
(define-method (mappend (a <pair>) (b <null>)) a)
(define-method (mappend (a <null>) (b <pair>)) b)
(define-method (mappend (a <null>) (b <null>)) '())
(define-method (null (a <pair>)) '())
(define-method (null (a <null>)) '())

(define-macro (null type)
  (symbol-append type '-null))

(define-class <applicative> ())
(define-generic map)

(define-class <monad> (<applicative> <monoid>))
(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]")))

(define-class <either> ()
  (slot #:init-keyword #:slot)
  (dir #:init-keyword #:dir #:init-value 'left))

(define (left val)
  "Error values"
  (make <either> #:slot val #:dir 'left))

(define (right val)
  "Good values"
  (make <either> #:slot val #:dir 'right))

(define-method (write (this <either>) port)
  (format port "[~a ~s]"
          (slot-ref this 'dir)
          (slot-ref this 'slot)))

(define-method (>>= (this <either>)
                    (proc <procedure>))
  (case (slot-ref this 'dir)
    ((left) this) 
    ((right) (match this (($ <either> slot) (proc slot))))))

(define return-either right)
(define return-optional just)

;; 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-class <writer> ()
  (value #:init-keyword #:value)
  (monoid #:init-keyword #:monoid))

(define (writer value context)
  (make <writer>
    #:value value
    #:monoid context))

(define-method (>>= (this <writer>)
                    (proc <procedure>))
  (match this (($ <writer> value monoid)
               (match (proc value)
                 (($ <writer> nval ncontext)
                  (writer nval { monoid <> ", " <> ncontext }))))))

(define-method (write (this <writer>) port)
  (match this (($ <writer> value monoid)
               (format port "[Writer ~s, ~s]" value monoid))))

(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 <-
  (lambda (x)
    (syntax-case x (just left right 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 ...))))))

;;; Examples:
;;; These are do in the conext of the optional monad.

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

(do let y = (just 10)
    (just x) <- y
    (+ x 5)) ; => 15

(do (just x) <- (nothing)
    (+ x 5)) ; => [Nothing]

;;;

(do let either = left 10
    (left x) <- either
    x) ; EVALUATION ERROR

;; Int -> Writer Int String
(define (log-number n)
  (writer n (format #f "Got nuber: ~a" n)))

(define (mult-with-log)
  (do (writer a) <- (log-number 3)
      (writer b) <- (log-number 5)
      (* a b)))

(do (writer a) <- (log-number 1)
    a) ; EVALUATION ERROR

(begin { (log-number 1) >>= log-number })
;; => [Writer 1, "Got nuber: 1, Got nuber: 1"]

(do (writer a) <- (log-number 3)
    (writer b) <- (log-number 5)
    (writer (* a b) ""))
;; EVALUATION ERROR
;; => [Writer 3, "Got nuber: 3, base"]

(log-number 3) ; => [Writer 3, "Got nuber: 3"]
(just 1) ; => [Just 1]

(do let y = 5
    (just x) <- (just 10)
    (just (* x y)))
;; => [Just 50]

;;; TODO
;;; '<- and 'let can't be used after '<-