module ListForMonad where

import Monad

data Mlist m a = NIL | a :<: m (Mlist m a)

nullML :: Mlist m a -> Bool
nullML NIL = True
nullML _ = False

(<:) :: Monad m => a -> m (Mlist m a) -> m (Mlist m a)
x <: ms = return (x :<: ms)

(+<+) :: Monad m => Mlist m a -> m (Mlist m a) -> m (Mlist m a)
xs +<+ ms = foldrML (<:) ms xs

(!<!) :: Monad m => Mlist m a -> Int -> m a
NIL !<! _ = error "index out of bounds"
(x :<: ms) !<! 0 = return x
(_ :<: ms) !<! n = ms >>= (!<! (n-1))

lengthML :: Monad m => Mlist m a -> m Int
lengthML NIL = return 0
lengthML (_ :<: ms) = liftM (+1) (ms >>= lengthML)

headML :: Mlist m a -> a
headML (x :<: _ ) = x
headML NIL = error "head of empty list"

lastML :: Monad m => Mlist m a -> m a
lastML (x :<: ms) =
	do	xs<-ms
		case xs of NIL -> return x
                           p   -> lastML p
lastML NIL = error "last of empty list"

tailML :: Mlist m a -> m (Mlist m a)
tailML (_ :<: ms) = ms
tailML NIL = error "tail of empty list"

initML :: Monad m => Mlist m a -> m (Mlist m a)
initML NIL = error "init of empty list"
initML (x :<: ms) =
	do	xs<-ms
		case xs of NIL -> return NIL
                           p   -> return (x :<: initML p)

replicateML :: Monad m => Int -> m a -> m (Mlist m a)
replicateML n a = liftM (takeML n) (repeatML a)

repeatML :: Monad m => m a -> m (Mlist m a)
repeatML action = xs
                  where
                  xs = do { r<-action; return (r :<: xs) }

takeML :: Monad m => Int -> Mlist m a -> Mlist m a
takeML _ NIL = NIL
takeML 0 _ = NIL
takeML n (x:<:ms) = x :<: (liftM (takeML (n-1)) ms)

dropML :: Monad m => Int -> Mlist m a -> m(Mlist m a)
dropML 0 xs = return xs
dropML _ NIL = return NIL
dropML n (x:<:ms) = ms >>= dropML (n-1)


splitAtML :: Monad m => Int -> Mlist m a -> m (Mlist m a, m(Mlist m a))
splitAtML 0 xs = return (NIL, return xs)
splitAtML n NIL = return (NIL, return NIL)
splitAtML n (x:<: ms) =
	do	m<-ms
		(as,ns)<-splitAtML (n-1) m
		return (x :<: return as,ns)

reverseML :: Monad m => Mlist m a -> m (Mlist m a)
reverseML ms =
	do	xs <- mlToList ms
		foldr (<:) (return NIL) (reverse xs)

zipML :: Monad m => Mlist m a -> Mlist m b -> Mlist m (a,b)		
zipML (x:<:ms) (y:<:ns) = (x,y) :<: do { xs<-ms; ys<-ns; return(zipML xs ys) }
zipML _ _ = NIL

unzipML :: Monad m => Mlist m (a,b) -> (Mlist m a,Mlist m b)
unzipML xs = (fmap fst xs,fmap snd xs) {- note: re-evaluation -}

instance Monad m => Functor (Mlist m) where
	fmap f NIL = NIL
	fmap f (x:<:ms) = f x :<: (liftM (fmap f) ms)

mlToList :: Monad m => Mlist m a -> m [a]
mlToList NIL = return []
mlToList (x :<: ms) = liftM (x:)(ms >>= mlToList)



foldrML :: Monad m => (a -> m b -> m b) -> m b -> Mlist m a -> m b
foldrML f n NIL = n
foldrML f n (x :<: ms) = f x (ms >>= foldrML f n)

blift :: Monad m => (a->b->b) -> (a-> m b -> m b)
blift f x act = liftM (f x) act

(&<&) :: Monad m => Bool -> m Bool -> m Bool
True &<& xs = xs
False &<& _ = return False

(|<|) :: Monad m => Bool -> m Bool -> m Bool
True |<| xs = return True
False |<| xs = xs

andML :: Monad m => Mlist m Bool -> m Bool
andML xs = foldrML (&<&) (return True) xs
orML :: Monad m => Mlist m Bool -> m Bool
orML xs = foldrML (|<|) (return False) xs

anyML :: Monad m => (a->Bool) -> Mlist m a -> m(Bool)
anyML p xs = orML $ fmap p xs
allML :: Monad m => (a->Bool) -> Mlist m a -> m(Bool)
allML p xs = andML $ fmap p xs

sumML :: (Monad m,Num a) => Mlist m a -> m a
sumML NIL = return 0
sumML (x:<:ms) = liftM (+x) (ms>>= sumML)

productML :: (Monad m,Num a) => Mlist m a -> m a
productML NIL = return 1
productML (x:<:ms) = liftM (*x) (ms>>= productML)

sequenceML :: Monad m => [m a] -> m(Mlist m a)
sequenceML [] = return NIL
sequenceML (x:xs) = liftM (:<: sequenceML xs) x

listEmbed :: Monad m => [a] -> Mlist m a
listEmbed [] = NIL
listEmbed (x:xs) = x :<: return (listEmbed xs)

filterML :: Monad m => (a->Bool) -> Mlist m a -> m(Mlist m a)
filterML _ NIL = return NIL
filterML p (x :<: ms)
    | p x = return (x :<: rs)
    | otherwise = rs
      where rs = ms >>= filterML p

takeWhileML :: Monad m => (a->Bool) -> Mlist m a -> Mlist m a
takeWhileML _ NIL = NIL
takeWhileML p (x :<: ms)
	| p x = x :<: (liftM (takeWhileML p) ms)
	| otherwise = NIL	

dropWhileML :: Monad m => (a->Bool) -> Mlist m a -> m(Mlist m a)
dropWhileML _ NIL = return NIL
dropWhileML p (x :<: ms)
	| p x = ms >>= dropWhileML p
	| otherwise = return (x :<: ms)

sequenceWhile_ :: Monad m => (a-> Bool) -> [m a] -> m ()
sequenceWhile_ p xs = do
			ml<-sequenceML xs
			mlToList $ takeWhileML p ml
                        return ()

showMLIO :: Show a => Mlist IO a -> IO ()
showMLIO NIL = putStr "[]"
showMLIO (x:<:ms) = 
	do
		putStr "["
		putStr (show x)
		ms >>= showRest
	where
	showRest NIL = putStr "]"
	showRest (y :<: ys) =
		do
			putStr ","
			putStr (show y)
			ys >>= showRest
			
{- not lazy enough -}
showMLx :: (Monad m,Show a) => Mlist m a -> m (String)
showMLx NIL = return "[]"
showMLx (x:<:ms) = 
	liftM (("[" ++ show x) ++) (ms >>= showRest)
	where
	showRest NIL = return "]"
	showRest (y :<: ys) =
		liftM ((","++show y)++) (ys >>= showRest)

singletonML x = x :<: return NIL

showML :: (Monad m,Show a) => Mlist m a -> Mlist m Char
showML NIL = listEmbed "[]"
showML (x:<:ms) =
	'[' :<: (listEmbed(show x) +<+ liftM showRest ms)
	where
	showRest NIL = singletonML ']'
	showRest (y:<:ys) =
		',' :<: (listEmbed(show y) +<+ (liftM showRest ys))


putStrML :: Mlist IO Char -> IO ()
putStrML NIL = return ()
putStrML (c :<: cs) = putChar c >> (cs >>= putStrML)

{-
type StringM m = Mlist m Char
type ShowM m = m (StringM m) -> m (StringM m)

class ShowML where
	showML :: Monad m => a -> m (StringM m)
	showsPrecML :: Monad m => Int -> a -> ShowM m
	showML t = showsPrecML 0 t (return NIL)
	showsPrecML n t ms = showML t +<+ ms
-}