;;; Commentary:
;;
;; This is the base class of the monad interface.
;; It provides all the frames and glue required to use the library, and also
;; sets up the list monad (for multiple return values).
;;
;; To top it off, it gives default <top> definitions to return and bind (>>=),
;; meaning that they will sort of work with any type.
;;
;;; Code:

(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 return
             <$> <*>
             >> >>=))


(define-generic return)

;; We start by defining our primitive operations,
(define-method (return (a <top>))
  "@code{return :: Monad m => a -> m a}

Since we can't directly defer type from context we instead allow @code{return}
to take an object of the desired type for @code{return}.

The default implementation is simple the identity function.
"
  identity)

(define-generic >>=)
(define-method (>>= (a <top>) (proc <procedure>))
  "@code{bind :: Monad m => m a x (a -> m b) -> m b}

Bind (or >>=) takes a monad value along with a procedure taking a regular value
and returning a monad value.

The default implementation simply applies proc to the value. Allowing any value
to be have the monadic type of being a scheme object.
"
  (proc a))

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

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

;;- We replace Scheme's built in @code{do} with our own, which works exactly like
;;- Haskell's do. @code{let} and @code{<-} included.
(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 (<$> f m_)
  "@code{map :: Functor f => (a -> b) x f a -> f b}

@code{Fmap}; works on any monadic type since all monads are monoids in the
category of @emph{endofunctors}@footnote{What's the problem?}"
  (>>= m_ (lambda (m) ((return m_) (f m)))))

(define (<*> f_ i_)
  "@code{applicative :: Functor f => f (a -> b) x f a -> f b}"
  (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)))

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

(define-method (return (a <pair>)) list)

(define-method (>>= (this <null>) proc) '())
(define-method (>>= (this <pair>)
                    (proc <procedure>))
  (apply append (map proc this)))