module Data.List.Class (
List (..),
cons, fromList, filter, repeat,
takeWhile, genericTake, scanl,
sequence, sequence_, transpose,
zip, zipWith,
foldlL, toList, execute, lengthL, lastL,
convList, transformListMonad, liftListMonad
) where
import Control.Monad (MonadPlus(..), ap, join, liftM)
import Control.Monad.Identity (Identity(..))
import Control.Monad.ListT (ListT(..), ListItem(..), foldrListT)
import Control.Monad.Trans (MonadTrans(..))
import Data.Function (fix)
import Prelude hiding (
filter, repeat, scanl, sequence, sequence_, takeWhile, zip, zipWith)
class (MonadPlus l, Monad m) => List l m | l -> m where
joinL :: m (l b) -> l b
foldrL :: (a -> m b -> m b) -> m b -> l a -> m b
foldrL consFunc nilFunc = foldrL consFunc nilFunc . toListT
toListT :: l a -> ListT m a
toListT = convList
fromListT :: ListT m a -> l a
fromListT = convList
instance List [] Identity where
joinL = runIdentity
foldrL = foldr
toListT = fromList
instance Monad m => List (ListT m) m where
joinL = ListT . (>>= runListT)
foldrL = foldrListT
toListT = id
fromListT = id
cons :: MonadPlus m => a -> m a -> m a
cons = mplus . return
fromList :: MonadPlus m => [a] -> m a
fromList = foldr (mplus . return) mzero
convList :: (List l m, List k m) => l a -> k a
convList =
joinL . foldrL step (return mzero)
where
step x = return . cons x . joinL
filter :: MonadPlus m => (a -> Bool) -> m a -> m a
filter cond =
(>>= f)
where
f x
| cond x = return x
| otherwise = mzero
foldlL' :: List l m =>
(a -> m c -> c) -> (a -> c) -> (a -> b -> a) -> a -> l b -> c
foldlL' joinVals atEnd step startVal =
t startVal . foldrL astep (return atEnd)
where
astep x rest = return $ (`t` rest) . (`step` x)
t cur = joinVals cur . (`ap` return cur)
foldlL :: List l m => (a -> b -> a) -> a -> l b -> m a
foldlL step startVal =
foldlL' (const join) id astep (return startVal)
where
astep rest x = liftM (`step` x) rest
scanl :: List l m => (a -> b -> a) -> a -> l b -> l a
scanl =
foldlL' consJoin $ const mzero
where
consJoin cur = cons cur . joinL
genericTake :: (Integral i, List l m) => i -> l a -> l a
genericTake count
| count <= 0 = const mzero
| otherwise = foldlL' joinStep (const mzero) next Nothing
where
next Nothing x = Just (count, x)
next (Just (i, _)) y = Just (i 1, y)
joinStep Nothing = joinL
joinStep (Just (1, x)) = const $ return x
joinStep (Just (_, x)) = cons x . joinL
execute :: List l m => l a -> m ()
execute = foldlL const ()
sequence :: List l m => l (m a) -> m (l a)
sequence =
foldrL consFunc (return mzero)
where
consFunc action rest = do
x <- action
return . cons x . joinL $ rest
sequence_ :: List l m => l (m a) -> m ()
sequence_ = execute . joinL . sequence
takeWhile :: List l m => (a -> Bool) -> l a -> l a
takeWhile cond =
joinL . foldrL step (return mzero)
where
step x
| cond x = return . cons x . joinL
| otherwise = const $ return mzero
toList :: List l m => l a -> m [a]
toList =
foldrL step $ return []
where
step = liftM . (:)
lengthL :: (Integral i, List l m) => l a -> m i
lengthL = foldlL (const . (+ 1)) 0
transformListMonad :: (List l m, List k s) =>
(forall x. m x -> s x) -> l a -> k a
transformListMonad trans =
t . foldrL step (return mzero)
where
t = joinL . trans
step x = return . cons x . t
liftListMonad ::
(MonadTrans t, Monad (t m), List l m) =>
l a -> ListT (t m) a
liftListMonad = transformListMonad lift
zip :: List l m => l a -> l b -> l (a, b)
zip as bs =
r0 (toListT as) (toListT bs)
where
r0 xx yy =
joinL $ do
xi <- runListT xx
case xi of
Nil -> return mzero
Cons x xs -> r1 x xs yy
r1 x xs yy = do
yi <- runListT yy
return $ case yi of
Nil -> mzero
Cons y ys ->
cons (x, y) $ r0 xs ys
zipWith :: List l m => (a -> b -> c) -> l a -> l b -> l c
zipWith func as = liftM (uncurry func) . zip as
lastL :: List l m => l a -> m a
lastL = foldlL (const id) undefined
repeat :: MonadPlus m => a -> m a
repeat = fix . cons
transpose :: List l m => l (l a) -> l (l a)
transpose matrix =
joinL $ toList matrix >>= r . map toListT
where
r xs = do
items <- mapM runListT xs
return $ case filter isCons items of
[] -> mzero
citems ->
cons (fromList (map headL citems)) .
joinL . r $ map tailL citems
isCons Nil = False
isCons _ = True