(.module:
  [lux #*]
  [//
   ["." functor (#+ Functor)]])

(def: (list;fold f init xs)
  (All [a b]
    (-> (-> b a a) a (List b) a)) 
  (case xs
    #.Nil
    init

    (#.Cons x xs')
    (list;fold f (f x init) xs')))

(def: (list;size xs)
  (All [a] (-> (List a) Nat))
  (loop [counter 0
         xs xs]
    (case xs
      #.Nil
      counter

      (#.Cons _ xs')
      (recur (inc counter) xs'))))

(def: (reverse xs)
  (All [a]
    (-> (List a) (List a)))
  (list;fold (function (_ head tail) (#.Cons head tail))
             #.Nil
             xs))

(def: (as-pairs xs)
  (All [a] (-> (List a) (List [a a])))
  (case xs
    (#.Cons x1 (#.Cons x2 xs'))
    (#.Cons [x1 x2] (as-pairs xs'))

    _
    #.Nil))

(signature: #export (Monad m)
  (: (Functor m)
     &functor)
  (: (All [a]
       (-> a (m a)))
     wrap)
  (: (All [a]
       (-> (m (m a)) (m a)))
     join))

(def: _cursor Cursor ["" 0 0])

(macro: #export (do tokens state)
  {#.doc (doc "Macro for easy concatenation of monadic operations."
              (do monad
                [y (f1 x)
                 z (f2 z)]
                (wrap (f3 z))))}
  (case tokens
    (#.Cons monad (#.Cons [_ (#.Tuple bindings)] (#.Cons body #.Nil)))
    (if (|> bindings list;size (n/% 2) (n/= 0))
      (let [g!_ (: Code [_cursor (#.Identifier ["" " _ "])])
            g!map (: Code [_cursor (#.Identifier ["" " map "])])
            g!join (: Code [_cursor (#.Identifier ["" " join "])])
            body' (list;fold (: (-> [Code Code] Code Code)
                                (function (_ binding body')
                                  (let [[var value] binding]
                                    (case var
                                      [_ (#.Tag ["" "let"])]
                                      (` (let (~ value) (~ body')))

                                      _
                                      (` (|> (~ value) ((~ g!map) (function ((~ g!_) (~ var)) (~ body'))) (~ g!join)))
                                      ))))
                             body
                             (reverse (as-pairs bindings)))]
        (#.Right [state (#.Cons (` ({(~' @)
                                     ({{#..&functor {#functor.map (~ g!map)}
                                        #..wrap (~' wrap)
                                        #..join (~ g!join)}
                                       (~ body')}
                                      (~' @))}
                                    (~ monad)))
                                #.Nil)]))
      (#.Left "'do' bindings must have an even number of parts."))

    _
    (#.Left "Wrong syntax for 'do'")))

(def: #export (seq monad)
  {#.doc "Run all the monadic values in the list and produce a list of the base values."}
  (All [M a]
    (-> (Monad M) (List (M a))
        (M (List a))))
  (let [(^open "!;.") monad]
    (function (recur xs)
      (case xs
        #.Nil
        (!;wrap #.Nil)
        
        (#.Cons x xs')
        (|> x
            (!;map (function (_ _x)
                     (!;map (|>> (#.Cons _x)) (recur xs'))))
            !;join)))))

(def: #export (map monad f)
  {#.doc "Apply a monadic function to all values in a list."}
  (All [M a b]
    (-> (Monad M) (-> a (M b)) (List a)
        (M (List b))))
  (let [(^open "!;.") monad]
    (function (recur xs)
      (case xs
        #.Nil
        (!;wrap #.Nil)
        
        (#.Cons x xs')
        (|> (f x)
            (!;map (function (_ _x)
                     (!;map (|>> (#.Cons _x)) (recur xs'))))
            !;join)))))

(def: #export (filter Monad<!> f)
  {#.doc "Filter the values in a list with a monadic function."}
  (All [! a b]
    (-> (Monad !) (-> a (! Bit)) (List a)
        (! (List a))))
  (let [(^open "!;.") Monad<!>]
    (function (recur xs)
      (case xs
        #.Nil
        (!;wrap #.Nil)
        
        (#.Cons head xs')
        (|> (f head)
            (!;map (function (_ verdict)
                     (!;map (function (_ tail)
                              (if verdict
                                (#.Cons head tail)
                                tail))
                            (recur xs'))))
            !;join)))))

(def: #export (fold monad f init xs)
  {#.doc "Fold a list with a monadic function."}
  (All [M a b]
    (-> (Monad M) (-> b a (M a)) a (List b)
        (M a)))
  (case xs
    #.Nil
    (:: monad wrap init)

    (#.Cons x xs')
    (do monad
      [init' (f x init)]
      (fold monad f init' xs'))))

(def: #export (lift monad f)
  {#.doc "Lift a normal function into the space of monads."}
  (All [M a b]
    (-> (Monad M) (-> a b) (-> (M a) (M b))))
  (function (_ ma)
    (do monad
      [a ma]
      (wrap (f a)))))