(define-module (monad)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (ice-9 curried-definitions)
  #:use-module (oop goops)
  #:replace (do)
  #:export (sequence mapM
                     fmap <$> cmap <*>
                     >> >>= return))

(define-generic return)
(define-method (return (a <top>)) identity)
(define-method (return (a <pair>)) list)

(define-generic >>=)

(define-method (>>= (a <top>) (proc <procedure>))
  (proc a))

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

(define-generic >>)

(define-method (>> (a <top>) (b <top>))
  (>>= a (lambda args b)))

(define-method (>> (a <null>) (b <null>)) '())
(define-method (>> (a <pair>) (b <null>)) '())
(define-method (>> (a <null>) (b <pair>)) '())
(define-method (>> (a <pair>) (b <pair>))
  (concatenate! (map (const b) a)))

;; 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-syntax do
  (syntax-rules (<- let =)
    ((_ let ptrn = val rest ...)
     (match val
       (ptrn (do rest ...))))
    ((_ ptrn <- val rest ...)
     (>>= val (match-lambda (ptrn (do rest ...)))))
    ((_ a) a) ; Base case
    ((_ token rest ...)
     (>> token (do rest ...)))))

;;; ----------------------------------------

(define (fmap f m)
  (>>= m (lambda (x) ((return m) (f x)))))

(define <$> fmap)

;; Curried map
(define (cmap f)
  (lambda (m) (fmap f m)))

(define (<*> f_ i_)
  (do f <- f_
      i <- i_
      ((return f_) (f i))))

;;; ----------------------------------------

;; This makes all curly infix operators be left associative,
;; discarding regular order of operations.
;; It does however work in my below example where I do
;; > f <$> a <*> b
;; Which is all that really matters.
(define-syntax $nfx$
  (syntax-rules ()
    ((_ single) single)
    ((_ a * b rest ...)
     ($nfx$ (* a b) rest ...))))

;; sequence :: (list (M a)) → M (list a)
(define (sequence in-list)
  "Evaluate each monadic action in the structure from left to right, and collect
the results. For a version that ignores the results see sequence_.
https://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Monad.html#g:4"
  (define ((f done) item) (append done (list item)))
  (fold (lambda (m-item m-done)
          #!curly-infix { f <$> m-done <*> m-item })
        ;; TODO this fails on a list of length 0
        ((return (car in-list)) '())
        in-list))

;; mapM :: (a -> M b) x (list a) → M (list b)
(define (mapM proc items)
  "Map each element of a structure to a monadic action, evaluate these actions from
left to right, and collect the results. For a version that ignores the results
see mapM_.
https://hackage.haskell.org/package/base-4.12.0.0/docs/Control-Monad.html#g:4"
  (sequence (map (lambda (x) (>>= x proc)) items)))