module Data.List.Class (
List (..), ListItem (..),
cons, fromList, filter, repeat,
takeWhile, genericTake, scanl,
transpose, zip, zipWith,
foldrL, foldlL, foldl1L, toList, lengthL, lastL,
merge2On, mergeOn,
execute, joinM, mapL, iterateM, takeWhileM,
sortOn,
transformListMonad,
listStateJoin
) where
import Control.Monad (MonadPlus(..), liftM)
import Control.Monad.Trans.State (StateT(..), evalStateT, get)
import Data.Function (fix)
import Data.Functor.Identity (Identity(..))
import Data.List (sortBy)
import Data.Maybe (fromJust)
import Data.Ord (comparing)
import Prelude hiding (
filter, repeat, scanl, takeWhile, zip, zipWith)
data ListItem l a =
Nil |
Cons { headL :: a, tailL :: l a }
deriving (Eq, Ord, Read, Show)
class (MonadPlus l, Monad (ItemM l)) => List l where
type ItemM l :: * -> *
runList :: l a -> ItemM l (ListItem l a)
joinL :: ItemM l (l a) -> l a
instance List [] where
type ItemM [] = Identity
runList [] = Identity Nil
runList (x:xs) = Identity $ Cons x xs
joinL = runIdentity
instance Functor m => Functor (ListItem m) where
fmap _ Nil = Nil
fmap func (Cons x xs) = Cons (func x) (fmap func xs)
foldrL :: List l => (a -> ItemM l b -> ItemM l b) -> ItemM l b -> l a -> ItemM l b
foldrL consFunc nilFunc list = do
item <- runList list
case item of
Nil -> nilFunc
Cons x xs -> consFunc x (foldrL consFunc nilFunc xs)
cons :: MonadPlus m => a -> m a -> m a
cons = mplus . return
fromList :: MonadPlus m => [a] -> m a
fromList = foldr (mplus . return) mzero
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 -> b -> a) -> a -> l b -> ItemM l a
foldlL step startVal list = do
item <- runList list
case item of
Nil -> return startVal
Cons x xs ->
let v = step startVal x
in v `seq` foldlL step v xs
foldl1L :: List l => (a -> a -> a) -> l a -> ItemM l a
foldl1L step list = do
item <- runList list
let Cons x xs = item
foldlL step x xs
scanl :: List l => (a -> b -> a) -> a -> l b -> l a
scanl step startVal list =
cons startVal . joinL $ do
item <- runList list
return $ case item of
Nil -> mzero
Cons x xs -> scanl step (step startVal x) xs
genericTake :: (Integral i, List l) => i -> l a -> l a
genericTake count list
| count <= 0 = mzero
| otherwise =
joinL $ do
item <- runList list
return $ case item of
Nil -> mzero
Cons x xs -> cons x (genericTake (count1) xs)
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 =
liftM (`cons` joinL rest) action
mapL :: List l => (a -> ItemM l b) -> l a -> l b
mapL func = joinM . liftM func
takeWhile :: List l => (a -> Bool) -> l a -> l a
takeWhile = takeWhileM . fmap return
takeWhileM :: List l => (a -> ItemM l Bool) -> l a -> l a
takeWhileM cond =
joinL . foldrL step (return mzero)
where
step x rest = do
b <- cond x
if b
then return . cons x . joinL $ rest
else 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
zip :: List l => l a -> l b -> l (a, b)
zip xx yy =
joinL $ do
xi <- runList xx
case xi of
Nil -> return mzero
Cons x xs -> do
yi <- runList yy
return $ case yi of
Nil -> mzero
Cons y ys -> cons (x, y) (zip 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 = liftM fromJust . foldlL (const Just) Nothing
repeat :: MonadPlus m => a -> m a
repeat = fix . cons
transpose :: List l => l (l a) -> l (l a)
transpose matrix =
joinL $ toList matrix >>= r
where
r xs = do
items <- mapM runList 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 =
joinL $ do
xi <- runList xx
yi <- runList 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
sortOn :: Ord b => (a -> b) -> [a] -> [a]
sortOn = sortBy . comparing
iterateM :: List l => (a -> ItemM l a) -> ItemM l a -> l a
iterateM step startM =
joinL $ do
start <- startM
return . cons start
. iterateM step
. step $ start
listStateJoin :: (List l, List k, ItemM l ~ StateT s (ItemM k))
=> l a -> ItemM l (k a)
listStateJoin list = do
start <- get
return . joinL . (`evalStateT` start) $ do
item <- runList list
case item of
Nil -> return mzero
Cons x xs -> liftM (cons x) (listStateJoin xs)