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

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