module ListT
(
ListT,
ListTrans(..),
ListMonad(..),
head,
tail,
null,
fold,
toList,
toReverseList,
traverse_,
splitAt,
fromFoldable,
unfold,
repeat,
Transformation,
traverse,
take,
drop,
slice,
Positive,
positive,
)
where
import BasePrelude hiding (uncons, toList, yield, fold, traverse, head, tail, take, drop, repeat, null, traverse_, splitAt)
import Control.Monad.Morph hiding (MonadTrans(..))
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Control
import Control.Monad.Base
newtype ListT m a =
ListT (m (Maybe (a, ListT m a)))
instance Monad m => Monoid (ListT m a) where
mempty =
ListT $
return Nothing
mappend (ListT m1) (ListT m2) =
ListT $
m1 >>=
\case
Nothing ->
m2
Just (h1, s1') ->
return (Just (h1, (mappend s1' (ListT m2))))
instance Functor m => Functor (ListT m) where
fmap f (ListT m) =
ListT $ (fmap . fmap) (\(a, b) -> (f a, fmap f b)) m
instance (Monad m, Functor m) => Applicative (ListT m) where
pure =
return
(<*>) =
ap
instance (Monad m, Functor m) => Alternative (ListT m) where
empty =
inline mzero
(<|>) =
inline mplus
instance Monad m => Monad (ListT m) where
return a =
ListT $ return (Just (a, (ListT (return Nothing))))
(>>=) s1 k2 =
ListT $
uncons s1 >>=
\case
Nothing ->
return Nothing
Just (h1, t1) ->
uncons $ k2 h1 <> (t1 >>= k2)
instance Monad m => MonadPlus (ListT m) where
mzero =
inline mempty
mplus =
inline mappend
instance MonadTrans ListT where
lift =
ListT . liftM (\a -> Just (a, mempty))
instance MonadIO m => MonadIO (ListT m) where
liftIO =
lift . liftIO
instance MFunctor ListT where
hoist f (ListT m) =
ListT $ f $ m >>= return . fmap (\(h, t) -> (h, hoist f t))
instance MonadBase b m => MonadBase b (ListT m) where
liftBase =
lift . liftBase
instance MonadBaseControl b m => MonadBaseControl b (ListT m) where
newtype StM (ListT m) a =
StM (StM m (Maybe (a, ListT m a)))
liftBaseWith runToBase =
lift $ liftBaseWith $ \runInner ->
runToBase $ liftM StM . runInner . uncons
restoreM (StM inner) =
lift (restoreM inner) >>= \case
Nothing -> mzero
Just (h, t) -> cons h t
class MonadTrans t => ListTrans t where
uncons :: t m a -> m (Maybe (a, t m a))
instance ListTrans ListT where
uncons (ListT m) = m
class MonadPlus m => ListMonad m where
cons :: a -> m a -> m a
instance ListMonad [] where
cons a m = a : m
instance Monad m => ListMonad (ListT m) where
cons h t = ListT $ return (Just (h, t))
instance ListMonad m => ListMonad (ReaderT e m) where
cons a m = ReaderT $ cons a . runReaderT m
head :: (Monad m, ListTrans t) => t m a -> m (Maybe a)
head =
liftM (fmap fst) . uncons
tail :: (Monad m, ListTrans t) => t m a -> m (Maybe (t m a))
tail =
liftM (fmap snd) . uncons
null :: (Monad m, ListTrans t) => t m a -> m Bool
null =
liftM (maybe True (const False)) . uncons
fold :: (Monad m, ListTrans t) => (r -> a -> m r) -> r -> t m a -> m r
fold s r =
uncons >=> maybe (return r) (\(h, t) -> s r h >>= \r' -> fold s r' t)
toList :: (Monad m, ListTrans t) => t m a -> m [a]
toList =
liftM ($ []) . fold (\f e -> return $ f . (e :)) id
toReverseList :: (Monad m, ListTrans t) => t m a -> m [a]
toReverseList =
ListT.fold (\l -> return . (:l)) []
traverse_ :: (Monad m, ListTrans t) => (a -> m ()) -> t m a -> m ()
traverse_ f =
fold (const f) ()
splitAt :: (Monad m, ListTrans t, MonadPlus (t m)) => Int -> t m a -> m ([a], t m a)
splitAt =
\case
n | n > 0 -> \l ->
uncons l >>= \case
Nothing -> return ([], mzero)
Just (h, t) -> do
(r1, r2) <- splitAt (pred n) t
return (h : r1, r2)
_ -> \l ->
return ([], l)
fromFoldable :: (ListMonad m, Foldable f) => f a -> m a
fromFoldable =
foldr cons mzero
unfold :: (ListMonad m) => (b -> Maybe (a, b)) -> b -> m a
unfold f s =
maybe mzero (\(h, t) -> cons h (unfold f t)) (f s)
repeat :: (ListMonad m) => a -> m a
repeat =
fix . cons
type Transformation m a b =
forall t. (Monad m, ListMonad (t m), ListTrans t) =>
t m a -> t m b
traverse :: (a -> m b) -> Transformation m a b
traverse f s =
lift (uncons s) >>=
mapM (\(h, t) -> lift (f h) >>= \h' -> cons h' (traverse f t)) >>=
maybe mzero return
take :: Int -> Transformation m a a
take =
\case
n | n > 0 -> \t ->
lift (uncons t) >>=
\case
Nothing -> t
Just (h, t) -> cons h (take (pred n) t)
_ ->
const $ mzero
drop :: Int -> Transformation m a a
drop =
\case
n | n > 0 ->
lift . uncons >=> maybe mzero (drop (pred n) . snd)
_ ->
id
slice :: Positive Int -> Transformation m a [a]
slice n l =
do
(h, t) <- lift $ splitAt (case n of Positive n -> n) l
case h of
[] -> mzero
_ -> cons h (slice n t)
newtype Positive n =
Positive n
deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
positive :: (Ord n, Num n) => n -> Maybe (Positive n)
positive =
\case
n | n > 0 -> Just $ Positive n
_ -> Nothing