{-# OPTIONS -O2 -Wall #-}

module Data.MList(MList(..)
                 ,MListItem(..)
                 ,empty
                 ,cons
                 ,singleton

                 ,fromList
                 ,toList
                 ,execute

                 ,zipWith
                 ,take
                 ,repeat
                 ,replicate
                 ,mrepeat
                 ,mreplicate
                 ,cycle

                 ,mfoldr
                 ,mfoldr'
                 ,map
                 ,condense
                 ,msequence
                 ,msequence_
                 ,mmap
                 ,mfor

                 ,append
                 ,concat
                 ,mmerge) where

import Prelude hiding (zipWith,concat,take,replicate,repeat,cycle,map)

import Control.Applicative(Applicative(..))
import Control.Monad(liftM,liftM2)
import Data.Monoid(Monoid(..))

data Monad m => MListItem m a = MNil | MCons a (MList m a)
newtype Monad m => MList m a = MList { unMList :: m (MListItem m a) }

mlist :: Monad m => MListItem m a -> MList m a
mlist = MList . return

empty :: Monad m => MList m a
empty = mlist MNil

cons :: Monad m => a -> MList m a -> MList m a
cons x = mlist . MCons x

singleton :: Monad m => a -> MList m a
singleton x = cons x empty

fromList :: Monad m => [a] -> MList m a
fromList = foldr cons empty

-- strict foldr -- executes the entire list in any case!
sfoldr :: Monad m => (a -> b -> b) -> b -> MList m a -> m b
sfoldr consFunc nilFunc = mfoldr liftConsFunc liftNilFunc
    where
      liftConsFunc x act = liftM (x `consFunc`) act
      liftNilFunc = return nilFunc
-- strict
toList :: Monad m => MList m a -> m [a]
toList = sfoldr (:) []
execute :: Monad m => MList m a -> m ()
execute = sfoldr ((const . const) ()) ()

zipWith :: Monad m => (a -> b -> c) -> MList m a -> MList m b -> MList m c
zipWith f (MList acx) (MList acy) =
    MList $ do
      cx <- acx
      case cx of
        MNil -> return MNil
        MCons x xs -> do
          cy <- acy
          return $
            case cy of
              MNil -> MNil
              MCons y acyRest ->
                  MCons (f x y) (zipWith f xs acyRest)

-- bind the monadic effect before the first item in the list.
mmerge :: Monad m => m (MList m a) -> MList m a
mmerge act = MList $ act >>= unMList

mfoldr :: Monad m => (a -> m b -> m b) -> m b -> MList m a -> m b
mfoldr consFunc nilFunc (MList acx) = do
  cx <- acx
  case cx of
    MNil -> nilFunc
    MCons x xs -> consFunc x $ mfoldr consFunc nilFunc xs

mfoldr' :: Monad m => (a -> MList m b -> MList m b) -> MList m b -> MList m a -> MList m b
mfoldr' consFunc nilFunc = mmerge . mfoldr liftConsFunc liftNilFunc
    where
      liftNilFunc = return nilFunc
      liftConsFunc x rest = return . consFunc x . mmerge $ rest

map :: Monad m => (a -> b) -> MList m a -> MList m b
map f = mfoldr' (cons . f) empty

append :: Monad m => MList m a -> MList m a -> MList m a
xs `append` ys = mfoldr' cons ys xs

concat :: Monad m => MList m (MList m a) -> MList m a
concat = mfoldr' append empty

condense :: Monad m => MList m (m a) -> MList m a
condense = mfoldr' consFunc empty
    where
      consFunc x xs = mmerge . liftM (`cons` xs) $ x

take :: (Integral i, Monad m) => i -> MList m a -> MList m a
take i (MList acx)
    | i <= 0    = empty
    | otherwise = MList $ do
                    cx <- acx
                    case cx of
                      MNil -> return MNil
                      MCons x rest -> return . MCons x . take (i-1) $ rest

repeat :: Monad m => a -> MList m a
repeat x = xs
    where xs = cons x xs

replicate :: (Monad m, Integral i) => i -> a -> MList m a
replicate n = take n . repeat

mrepeat :: Monad m => m a -> MList m a
mrepeat ax = xs
    where xs = MList $ liftM (`MCons` xs) ax

mreplicate :: (Monad m, Integral i) => i -> m a -> MList m a
mreplicate n = take n . mrepeat

cycle :: Monad m => MList m a -> MList m a
cycle xs = cxs
    where cxs = xs `append` cxs

msequence :: Monad m => MList m (m a) -> m [a]
msequence = toList . condense

msequence_ :: Monad m => MList m (m a) -> m ()
msequence_ = execute . condense

mmap :: Monad m => (a -> m b) -> MList m a -> MList m b
mmap f = condense . map f

mfor :: Monad m => MList m a -> (a -> m b) -> MList m b
mfor = flip mmap

instance Monad m => Monoid (MList m a) where
    mempty = empty
    mappend = append

instance Monad m => Functor (MList m) where
    fmap = map

instance Monad m => Applicative (MList m) where
    pure = return
    (<*>) = liftM2 id

instance Monad m => Monad (MList m) where
    return = singleton
    xs >>= f = concat . map f $ xs