{-# LANGUAGE UndecidableInstances, CPP #-}
module ListT
(
ListT(..),
uncons,
head,
tail,
null,
fold,
foldMaybe,
applyFoldM,
toList,
toReverseList,
traverse_,
splitAt,
cons,
fromFoldable,
fromMVar,
unfold,
unfoldM,
repeat,
traverse,
take,
drop,
slice,
)
where
import ListT.Prelude hiding (uncons, toList, yield, fold, traverse, head, tail, take, drop, repeat, null, traverse_, splitAt)
import Control.Monad
newtype ListT m a =
ListT (m (Maybe (a, ListT m a)))
instance Monad m => Semigroup (ListT m a) where
(<>) (ListT m1) (ListT m2) =
ListT $
m1 >>=
\case
Nothing ->
m2
Just (h1, s1') ->
return (Just (h1, ((<>) s1' (ListT m2))))
instance Monad m => Monoid (ListT m a) where
mempty =
ListT $
return Nothing
mappend = (<>)
instance Functor m => Functor (ListT m) where
fmap f =
ListT . (fmap . fmap) (f *** fmap f) . uncons
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)
#if !MIN_VERSION_base(4,11,0)
fail _ =
mempty
#endif
instance Monad m => MonadFail (ListT m) where
fail _ =
inline mempty
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 . f . (liftM . fmap) (id *** hoist f) . uncons
instance MMonad ListT where
embed f (ListT m) =
f m >>= \case
Nothing -> mzero
Just (h, t) -> ListT $ return $ Just $ (h, embed f t)
instance MonadBase b m => MonadBase b (ListT m) where
liftBase =
lift . liftBase
instance MonadBaseControl b m => MonadBaseControl b (ListT m) where
type StM (ListT m) a =
StM m (Maybe (a, ListT m a))
liftBaseWith runToBase =
lift $ liftBaseWith $ \runInner ->
runToBase $ runInner . uncons
restoreM inner =
lift (restoreM inner) >>= \case
Nothing -> mzero
Just (h, t) -> cons h t
instance MonadError e m => MonadError e (ListT m) where
throwError = ListT . throwError
catchError m handler = ListT $ catchError (uncons m) $ uncons . handler
uncons :: ListT m a -> m (Maybe (a, ListT m a))
uncons (ListT m) =
m
{-# INLINABLE head #-}
head :: Monad m => ListT m a -> m (Maybe a)
head =
liftM (fmap fst) . uncons
{-# INLINABLE tail #-}
tail :: Monad m => ListT m a -> m (Maybe (ListT m a))
tail =
liftM (fmap snd) . uncons
{-# INLINABLE null #-}
null :: Monad m => ListT m a -> m Bool
null =
liftM (maybe True (const False)) . uncons
{-# INLINABLE fold #-}
fold :: Monad m => (r -> a -> m r) -> r -> ListT m a -> m r
fold s r =
uncons >=> maybe (return r) (\(h, t) -> s r h >>= \r' -> fold s r' t)
{-# INLINABLE foldMaybe #-}
foldMaybe :: Monad m => (r -> a -> m (Maybe r)) -> r -> ListT m a -> m r
foldMaybe s r l =
liftM (maybe r id) $ runMaybeT $ do
(h, t) <- MaybeT $ uncons l
r' <- MaybeT $ s r h
lift $ foldMaybe s r' t
applyFoldM :: Monad m => FoldM m i o -> ListT m i -> m o
applyFoldM (FoldM step init extract) lt = do
a <- init
b <- fold step a lt
extract b
{-# INLINABLE toList #-}
toList :: Monad m => ListT m a -> m [a]
toList =
liftM ($ []) . fold (\f e -> return $ f . (e :)) id
{-# INLINABLE toReverseList #-}
toReverseList :: Monad m => ListT m a -> m [a]
toReverseList =
ListT.fold (\l -> return . (:l)) []
{-# INLINABLE traverse_ #-}
traverse_ :: Monad m => (a -> m ()) -> ListT m a -> m ()
traverse_ f =
fold (const f) ()
{-# INLINABLE splitAt #-}
splitAt :: Monad m => Int -> ListT m a -> m ([a], ListT 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)
cons :: Monad m => a -> ListT m a -> ListT m a
cons h t =
ListT $ return (Just (h, t))
{-# INLINABLE fromFoldable #-}
fromFoldable :: (Monad m, Foldable f) => f a -> ListT m a
fromFoldable =
foldr cons mzero
fromMVar :: (MonadIO m) => MVar (Maybe a) -> ListT m a
fromMVar v =
fix $ \loop -> liftIO (takeMVar v) >>= maybe mzero (flip cons loop)
{-# INLINABLE unfold #-}
unfold :: Monad m => (b -> Maybe (a, b)) -> b -> ListT m a
unfold f s =
maybe mzero (\(h, t) -> cons h (unfold f t)) (f s)
{-# INLINABLE unfoldM #-}
unfoldM :: Monad m => (b -> m (Maybe (a, b))) -> b -> ListT m a
unfoldM f = go where
go s = ListT $ f s >>= \case
Nothing -> return Nothing
Just (a,r) -> return (Just (a, go r))
{-# INLINABLE repeat #-}
repeat :: Monad m => a -> ListT m a
repeat =
fix . cons
{-# INLINABLE traverse #-}
traverse :: Monad m => (a -> m b) -> ListT m a -> ListT m b
traverse f s =
lift (uncons s) >>=
mapM (\(h, t) -> lift (f h) >>= \h' -> cons h' (traverse f t)) >>=
maybe mzero return
{-# INLINABLE take #-}
take :: Monad m => Int -> ListT m a -> ListT m a
take =
\case
n | n > 0 -> \t ->
lift (uncons t) >>=
\case
Nothing -> t
Just (h, t) -> cons h (take (pred n) t)
_ ->
const $ mzero
{-# INLINABLE drop #-}
drop :: Monad m => Int -> ListT m a -> ListT m a
drop =
\case
n | n > 0 ->
lift . uncons >=> maybe mzero (drop (pred n) . snd)
_ ->
id
{-# INLINABLE slice #-}
slice :: Monad m => Int -> ListT m a -> ListT m [a]
slice n l =
do
(h, t) <- lift $ splitAt n l
case h of
[] -> mzero
_ -> cons h (slice n t)