module Data.List.Class (
List (..),
cons, fromList, filter, repeat,
takeWhile, genericTake, scanl,
transpose, zip, zipWith,
foldlL, toList, lengthL, lastL,
merge2On, mergeOn,
execute, joinM,
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, takeWhile, zip, zipWith)
class (MonadPlus l, Monad (ItemM l)) => List l where
type ItemM l :: * -> *
joinL :: ItemM l (l b) -> l b
foldrL :: (a -> ItemM l b -> ItemM l b) -> ItemM l b -> l a -> ItemM l b
foldrL consFunc nilFunc = foldrL consFunc nilFunc . toListT
toListT :: l a -> ListT (ItemM l) a
toListT = convList
fromListT :: ListT (ItemM l) a -> l a
fromListT = convList
instance List [] where
type ItemM [] = Identity
joinL = runIdentity
foldrL = foldr
toListT = fromList
instance Monad m => List (ListT m) where
type ItemM (ListT m) = m
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 :: (ItemM l ~ ItemM k, List l, List k) => 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 =>
(a -> (ItemM l) 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 => (a -> b -> a) -> a -> l b -> ItemM l a
foldlL step startVal =
foldlL' (const join) id astep (return startVal)
where
astep rest x = liftM (`step` x) rest
scanl :: List l => (a -> b -> a) -> a -> l b -> l a
scanl =
foldlL' consJoin $ const mzero
where
consJoin cur = cons cur . joinL
genericTake :: (Integral i, List l) => 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 => l a -> ItemM l ()
execute = foldlL const ()
joinM :: List l => l (ItemM l a) -> l a
joinM =
joinL . foldrL consFunc (return mzero)
where
consFunc action rest = do
x <- action
return . cons x . joinL $ rest
takeWhile :: List l => (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 => l a -> ItemM l [a]
toList =
foldrL step $ return []
where
step = liftM . (:)
lengthL :: (Integral i, List l) => l a -> ItemM l i
lengthL = foldlL (const . (+ 1)) 0
transformListMonad :: (List l, List k) =>
(forall x. ItemM l x -> ItemM k 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 (ItemM l)), List l) =>
l a -> ListT (t (ItemM l)) a
liftListMonad = transformListMonad lift
zip :: List l => 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 :: List l => a -> ListT (ItemM l) a -> ListT (ItemM l) b -> ItemM l (l (a, b))
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 => (a -> b -> c) -> l a -> l b -> l c
zipWith func as = liftM (uncurry func) . zip as
lastL :: List l => l a -> ItemM l a
lastL = foldlL (const id) undefined
repeat :: MonadPlus m => a -> m a
repeat = fix . cons
transpose :: List l => 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
mergeOn :: (Ord b, List l) => (a -> b) -> l (l a) -> l a
mergeOn f = joinL . foldlL (merge2On f) mzero
merge2On :: (Ord b, List l) => (a -> b) -> l a -> l a -> l a
merge2On f xx yy =
fromListT . joinL $ do
xi <- runListT (toListT xx)
yi <- runListT (toListT yy)
return $ case (xi, yi) of
(Cons x xs, Cons y ys)
| f y > f x -> cons x . merge2On f xs $ cons y ys
| otherwise -> cons y $ merge2On f (cons x xs) ys
(Cons x xs, Nil) -> cons x xs
(Nil, Cons y ys) -> cons y ys
(Nil, Nil) -> mzero