list-t 0.4.7 → 1.0.5.7
raw patch · 6 files changed
Files
- Setup.hs +0/−2
- htf-test/Main.hs +160/−0
- library/ListT.hs +358/−230
- library/ListT/Prelude.hs +93/−0
- list-t.cabal +78/−62
- tests/Main.hs +0/−156
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ htf-test/Main.hs view
@@ -0,0 +1,160 @@+{-# OPTIONS_GHC -F -pgmF htfpp -Wno-redundant-constraints #-}++import BasePrelude hiding (toList)+import Control.Monad.Morph+import qualified ListT as L+import MTLPrelude+import Test.Framework++main :: IO ()+main = htfMain htf_thisModulesTests++-- * MMonad++-- embed lift = id+prop_mmonadLaw1 :: [Int] -> Bool+prop_mmonadLaw1 (l :: [Int]) =+ let s = L.fromFoldable l+ in runIdentity $ streamsEqual s (embed lift s)++-- embed f (lift m) = f m+prop_mmonadLaw2 :: [Int] -> Bool+prop_mmonadLaw2 l =+ let s = (L.fromFoldable :: [Int] -> L.ListT Identity Int) l+ f = MaybeT . fmap Just+ run = runIdentity . L.toList . runMaybeT+ in run (f s)+ == run (embed f (lift s))++-- * Applicative++prop_applicativeIdentityLaw :: [Int] -> Bool+prop_applicativeIdentityLaw (l :: [Int]) =+ runIdentity $ streamsEqual (pure id <*> s) s+ where+ s = L.fromFoldable l++prop_applicativeBehavesLikeList :: [Int] -> Bool+prop_applicativeBehavesLikeList =+ \(ns :: [Int]) ->+ let a = fs <*> ns+ b = runIdentity (toList $ L.fromFoldable fs <*> L.fromFoldable ns)+ in a == b+ where+ fs = [(+ 1), (+ 3), (+ 5)]++-- * Monad++test_monadLaw1 :: IO ()+test_monadLaw1 =+ assertBool =<< streamsEqual (return a >>= k) (k a)+ where+ a = 2+ k a = return $ chr a++test_monadLaw2 :: IO ()+test_monadLaw2 =+ assertBool =<< streamsEqual (m >>= return) m+ where+ m = L.fromFoldable ['a' .. 'z']++test_monadLaw3 :: IO ()+test_monadLaw3 =+ assertBool =<< streamsEqual (m >>= (\x -> k x >>= h)) ((m >>= k) >>= h)+ where+ m = L.fromFoldable ['a' .. 'z']+ k a = return $ ord a+ h a = return $ a + 1++test_monadLaw4 :: IO ()+test_monadLaw4 =+ assertBool =<< streamsEqual (fmap f xs) (xs >>= return . f)+ where+ f = ord+ xs = L.fromFoldable ['a' .. 'z']++-- * Monoid++test_mappend :: IO ()+test_mappend =+ assertBool+ =<< streamsEqual+ (L.fromFoldable [0 .. 7])+ (L.fromFoldable [0 .. 3] <> L.fromFoldable [4 .. 7])++test_mappendAndTake :: IO ()+test_mappendAndTake =+ assertBool+ =<< streamsEqual+ (L.fromFoldable [0 .. 5])+ (L.take 6 $ L.fromFoldable [0 .. 3] <> L.fromFoldable [4 .. 7])++test_mappendDoesntCauseTraversal :: IO ()+test_mappendDoesntCauseTraversal =+ do+ ref <- newIORef 0+ (flip runReaderT) ref (toList $ L.take 5 $ stream <> stream)+ assertEqual 5 =<< readIORef ref+ where+ stream =+ do+ ref <- lift $ ask+ x <- L.fromFoldable [0 .. 4]+ liftIO $ modifyIORef ref (+ 1)+ return x++-- * Other++test_repeat :: IO ()+test_repeat =+ assertEqual [2, 2, 2] =<< do+ toList $ L.take 3 $ L.repeat (2 :: Int)++test_traverseDoesntCauseTraversal :: IO ()+test_traverseDoesntCauseTraversal =+ do+ ref <- newIORef 0+ (flip runReaderT) ref (toList stream3)+ assertEqual 3 =<< readIORef ref+ where+ stream1 =+ do+ ref <- lift $ ask+ x <- L.fromFoldable ['a' .. 'z']+ liftIO $ modifyIORef ref (+ 1)+ return x+ stream2 =+ L.traverse (return . toUpper) stream1+ stream3 =+ L.take 3 stream2++test_takeDoesntCauseTraversal :: IO ()+test_takeDoesntCauseTraversal =+ do+ ref <- newIORef 0+ (flip runReaderT) ref (toList $ L.take 3 $ L.take 7 $ stream)+ assertEqual 3 =<< readIORef ref+ where+ stream =+ do+ ref <- lift $ ask+ x <- L.fromFoldable [0 .. 10]+ liftIO $ modifyIORef ref (+ 1)+ return x++test_drop :: IO ()+test_drop =+ assertEqual [3, 4] =<< do+ toList $ L.drop 2 $ L.fromFoldable [1 .. 4]++test_slice :: IO ()+test_slice =+ assertEqual ["abc", "def", "gh"] =<< do+ toList $ L.slice 3 $ L.fromFoldable ("abcdefgh" :: [Char])++toList :: (Monad m) => L.ListT m a -> m [a]+toList = L.toList++streamsEqual :: (Applicative m, Monad m, Eq a) => L.ListT m a -> L.ListT m a -> m Bool+streamsEqual a b =+ (==) <$> L.toList a <*> L.toList b
library/ListT.hs view
@@ -1,122 +1,188 @@-{-# LANGUAGE UndecidableInstances, CPP #-}+{-# OPTIONS_GHC -Wno-dodgy-imports #-}+ module ListT-(- ListT,- -- * Classes- MonadTransUncons(..),- MonadCons(..),- -- * Execution utilities- head,- tail,- null,- fold,- foldMaybe,- toList,- toReverseList,- traverse_,- splitAt,- -- * Construction utilities- fromFoldable,- fromMVar,- unfold,- unfoldM,- repeat,- -- * Transformation utilities- -- | - -- These utilities only accumulate the transformations- -- without actually traversing the stream.- -- They only get applied with a single traversal, - -- which happens at the execution.- Transformation,- traverse,- take,- drop,- slice,- -- * Positive numbers- Positive,- positive,-)+ ( ListT (..),++ -- * Execution utilities+ uncons,+ head,+ tail,+ null,+ alternate,+ alternateHoisting,+ fold,+ foldMaybe,+ applyFoldM,+ toList,+ toReverseList,+ traverse_,+ splitAt,++ -- * Construction utilities+ cons,+ fromFoldable,+ fromMVar,+ unfold,+ unfoldM,+ repeat,++ -- * Transformation utilities++ -- |+ -- These utilities only accumulate the transformations+ -- without actually traversing the stream.+ -- They only get applied in a single traversal,+ -- which only happens at the execution.+ traverse,+ take,+ drop,+ slice,+ ) 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.Error.Class -import Control.Monad.Trans.Class-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Control hiding (embed, embed_)-import Control.Monad.Base+import ListT.Prelude hiding (drop, fold, head, null, repeat, splitAt, tail, take, toList, traverse, traverse_, uncons, yield) -- | -- A proper implementation of the list monad-transformer. -- Useful for streaming of monadic data structures.--- +-- -- Since it has instances of 'MonadPlus' and 'Alternative', -- you can use general utilities packages like -- <http://hackage.haskell.org/package/monadplus "monadplus"> -- with it.-newtype ListT m a =- ListT { unListT :: m (Maybe (a, ListT m a)) }+newtype ListT m a+ = ListT (m (Maybe (a, ListT m a)))+ deriving (Foldable, Traversable, Generic) -instance Monad m => Monoid (ListT m a) where- mempty =- ListT $ - return Nothing- mappend (ListT m1) (ListT m2) =+deriving instance (Show (m (Maybe (a, ListT m a)))) => Show (ListT m a)++deriving instance (Read (m (Maybe (a, ListT m a)))) => Read (ListT m a)++deriving instance (Eq (m (Maybe (a, ListT m a)))) => Eq (ListT m a)++deriving instance (Ord (m (Maybe (a, ListT m a)))) => Ord (ListT m a)++deriving instance (Typeable m, Typeable a, Data (m (Maybe (a, ListT m a)))) => Data (ListT m a)++instance (Eq1 m) => Eq1 (ListT m) where+ liftEq eq = go+ where+ go (ListT m) (ListT n) = liftEq (liftEq (\(a, as) (b, bs) -> eq a b && go as bs)) m n++instance (Ord1 m) => Ord1 (ListT m) where+ liftCompare cmp = go+ where+ go (ListT m) (ListT n) = liftCompare (liftCompare (\(a, as) (b, bs) -> cmp a b <> go as bs)) m n++instance (Show1 m) => Show1 (ListT m) where+ -- I wish I were joking.+ liftShowsPrec sp (sl :: [a] -> ShowS) = mark+ where+ bob :: Int -> m (Maybe (a, ListT m a)) -> ShowS+ bob = liftShowsPrec jill edith++ edith :: [Maybe (a, ListT m a)] -> ShowS+ edith = liftShowList jack martha++ jill :: Int -> Maybe (a, ListT m a) -> ShowS+ jill = liftShowsPrec jack martha++ martha :: [(a, ListT m a)] -> ShowS+ martha = liftShowList2 sp sl mark juan++ mark :: Int -> ListT m a -> ShowS+ mark d (ListT m) = showsUnaryWith bob "ListT" d m++ juan :: [ListT m a] -> ShowS+ juan = liftShowList sp sl++ jack :: Int -> (a, ListT m a) -> ShowS+ jack = liftShowsPrec2 sp sl mark juan++instance (Monad m) => Semigroup (ListT m a) where+ (<>) (ListT m1) (ListT m2) = ListT $- m1 >>=- \case+ m1+ >>= \case Nothing -> m2 Just (h1, s1') ->- return (Just (h1, (mappend s1' (ListT m2))))+ return (Just (h1, ((<>) s1' (ListT m2)))) -instance Functor m => Functor (ListT m) where- fmap f =- ListT . (fmap . fmap) (f *** fmap f) . unListT+instance (Monad m) => Monoid (ListT m a) where+ mempty =+ ListT $+ return Nothing+ mappend = (<>) +instance (Functor m) => Functor (ListT m) where+ fmap f = go+ where+ go =+ ListT . (fmap . fmap) (bimapPair' f go) . uncons+ instance (Monad m, Functor m) => Applicative (ListT m) where- pure = - return- (<*>) = + pure a =+ ListT $ return (Just (a, (ListT (return Nothing))))+ (<*>) = ap + -- This is just like liftM2, but it uses fmap over the second+ -- action. liftM2 can't do that, because it has to deal with+ -- the possibility that someone defines liftA2 = liftM2 and+ -- fmap f = (pure f <*>) (leaving (<*>) to the default).+ liftA2 f m1 m2 = do+ x1 <- m1+ fmap (f x1) m2+ instance (Monad m, Functor m) => Alternative (ListT m) where- empty = - inline mzero- (<|>) = - inline mplus+ empty =+ inline mempty+ (<|>) =+ inline mappend -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) => Monad (ListT m) where+ return = pure -instance Monad m => MonadPlus (ListT m) where- mzero = + -- We use a go function so GHC can inline k2+ -- if it likes.+ (>>=) s10 k2 = go s10+ where+ go s1 =+ ListT $+ uncons s1+ >>= \case+ Nothing ->+ return Nothing+ Just (h1, t1) ->+ uncons $ k2 h1 <> go t1++instance (Monad m) => MonadFail (ListT m) where+ fail _ = inline mempty- mplus = ++instance (Monad m) => MonadPlus (ListT m) where+ mzero =+ inline mempty+ mplus = inline mappend instance MonadTrans ListT where lift =- ListT . liftM (\a -> Just (a, mempty))+ ListT . fmap (\a -> Just (a, mempty)) -instance MonadIO m => MonadIO (ListT m) where+instance (MonadIO m) => MonadIO (ListT m) where liftIO = lift . liftIO instance MFunctor ListT where- hoist f =- ListT . f . (liftM . fmap) (id *** hoist f) . unListT+ hoist f = go+ where+ go (ListT run) =+ ListT . f $+ run <&> \case+ Just (elem, next) -> Just (elem, go next)+ Nothing -> Nothing instance MMonad ListT where embed f (ListT m) =@@ -124,140 +190,217 @@ Nothing -> mzero Just (h, t) -> ListT $ return $ Just $ (h, embed f t) -instance MonadBase b m => MonadBase b (ListT m) where+instance (MonadBase b m) => MonadBase b (ListT m) where liftBase = lift . liftBase -#if MIN_VERSION_monad_control(1,0,0)-instance MonadBaseControl b m => MonadBaseControl b (ListT m) where- type StM (ListT m) a =- StM m (Maybe (a, ListT m a))+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+ lift $+ liftBaseWith $ \runInner ->+ runToBase $ runInner . uncons restoreM inner = lift (restoreM inner) >>= \case Nothing -> mzero Just (h, t) -> cons h t-#else-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-#endif -instance MonadError e m => MonadError e (ListT m) where+instance (MonadError e m) => MonadError e (ListT m) where throwError = ListT . throwError- catchError m handler = ListT $ catchError (unListT m) $ unListT . handler+ catchError m handler = ListT $ catchError (uncons m) $ uncons . handler --- * Classes--------------------------+instance (MonadReader e m) => MonadReader e (ListT m) where+ ask = lift ask+ reader = lift . reader+ local r = go+ where+ go (ListT m) = ListT $ local r (fmap (fmap (secondPair' go)) m) --- |--- A monad transformer capable of deconstructing like a list.-class MonadTrans t => MonadTransUncons t where- -- |- -- Execute in the inner monad,- -- getting the head and the tail.- -- Returns nothing if it's empty.- uncons :: Monad m => t m a -> m (Maybe (a, t m a))+instance (MonadState e m) => MonadState e (ListT m) where+ get = lift get+ put = lift . put+ state = lift . state -instance MonadTransUncons ListT where- {-# INLINE uncons #-}- uncons (ListT m) = m+instance (Monad m) => MonadLogic (ListT m) where+ msplit (ListT m) = lift m + interleave m1 m2 =+ ListT $+ uncons m1 >>= \case+ Nothing -> uncons m2+ Just (a, m1') -> uncons $ cons a (interleave m2 m1') --- |--- A monad capable of constructing like a list.-class MonadPlus m => MonadCons m where- -- |- -- Prepend an element.- cons :: a -> m a -> m a+ m >>- f =+ ListT $+ uncons m >>= \case+ Nothing -> uncons empty+ Just (a, m') -> uncons $ interleave (f a) (m' >>- f) -instance MonadCons [] where- cons a m = a : m+ ifte t th el =+ ListT $+ uncons t >>= \case+ Nothing -> uncons el+ Just (a, m) -> uncons $ th a <|> (m >>= th) -instance Monad m => MonadCons (ListT m) where- {-# INLINABLE cons #-}- cons h t = ListT $ return (Just (h, t))+ once (ListT m) =+ ListT $+ m >>= \case+ Nothing -> uncons empty+ Just (a, _) -> uncons (return a) -instance MonadCons m => MonadCons (ReaderT e m) where- cons a m = ReaderT $ cons a . runReaderT m+ lnot (ListT m) =+ ListT $+ m >>= \case+ Nothing -> uncons (return ())+ Just _ -> uncons empty +instance (MonadZip m) => MonadZip (ListT m) where+ mzipWith f = go+ where+ go (ListT m1) (ListT m2) =+ ListT $+ mzipWith+ ( mzipWith $+ \(a, as) (b, bs) -> (f a b, go as bs)+ )+ m1+ m2 + munzip (ListT m)+ | (l, r) <- munzip (fmap go m) =+ (ListT l, ListT r)+ where+ go Nothing = (Nothing, Nothing)+ go (Just ((a, b), listab)) =+ (Just (a, la), Just (b, lb))+ where+ -- If the underlying munzip is careful not to leak memory, then we+ -- don't want to defeat it. We need to be sure that la and lb are+ -- realized as selector thunks.+ {-# NOINLINE remains #-}+ {-# NOINLINE la #-}+ {-# NOINLINE lb #-}+ remains = munzip listab+ (la, lb) = remains+ -- * Execution in the inner monad+ ------------------------- -- |+-- Execute in the inner monad,+-- getting the head and the tail.+-- Returns nothing if it's empty.+uncons :: ListT m a -> m (Maybe (a, ListT m a))+uncons (ListT m) =+ m++-- | -- Execute, getting the head. Returns nothing if it's empty.-{-# INLINABLE head #-}-head :: (Monad m, MonadTransUncons t) => t m a -> m (Maybe a)+{-# INLINEABLE head #-}+head :: (Monad m) => ListT m a -> m (Maybe a) head =- liftM (fmap fst) . uncons+ fmap (fmap fst) . uncons -- | -- Execute, getting the tail. Returns nothing if it's empty.-{-# INLINABLE tail #-}-tail :: (Monad m, MonadTransUncons t) => t m a -> m (Maybe (t m a))+{-# INLINEABLE tail #-}+tail :: (Monad m) => ListT m a -> m (Maybe (ListT m a)) tail =- liftM (fmap snd) . uncons+ fmap (fmap snd) . uncons -- | -- Execute, checking whether it's empty.-{-# INLINABLE null #-}-null :: (Monad m, MonadTransUncons t) => t m a -> m Bool+{-# INLINEABLE null #-}+null :: (Monad m) => ListT m a -> m Bool null =- liftM (maybe True (const False)) . uncons+ fmap (maybe True (const False)) . uncons -- |--- Execute, applying a left fold.-{-# INLINABLE fold #-}-fold :: (Monad m, MonadTransUncons 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)+-- Execute in the inner monad,+-- using its '(<|>)' function on each entry.+{-# INLINEABLE alternate #-}+alternate :: (Alternative m, Monad m) => ListT m a -> m a+alternate (ListT m) =+ m >>= \case+ Nothing -> empty+ Just (a, as) -> pure a <|> alternate as -- |+-- Use a monad morphism to convert a 'ListT' to a similar+-- monad, such as '[]'.+--+-- A more efficient alternative to @'alternate' . 'hoist' f@.+{-# INLINEABLE alternateHoisting #-}+alternateHoisting :: (Monad n, Alternative n) => (forall a. m a -> n a) -> ListT m a -> n a+alternateHoisting f = go+ where+ go (ListT m) =+ f m >>= \case+ Nothing -> empty+ Just (a, as) -> pure a <|> go as++-- |+-- Execute, applying a strict left fold.+{-# INLINEABLE fold #-}+fold :: (Monad m) => (b -> a -> m b) -> b -> ListT m a -> m b+fold step = go+ where+ go !acc (ListT run) =+ run >>= \case+ Just (element, next) -> do+ acc' <- step acc element+ go acc' next+ Nothing ->+ return acc++-- | -- A version of 'fold', which allows early termination.-{-# INLINABLE foldMaybe #-}-foldMaybe :: (Monad m, MonadTransUncons t) => (r -> a -> m (Maybe r)) -> r -> t m a -> m r+{-# INLINEABLE foldMaybe #-}+foldMaybe :: (Monad m) => (b -> a -> m (Maybe b)) -> b -> ListT m a -> m b 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+ fmap (maybe r id) $+ runMaybeT $ do+ (h, t) <- MaybeT $ uncons l+ r' <- MaybeT $ s r h+ lift $ foldMaybe s r' t -- |+-- Apply the left fold abstraction from the \"foldl\" package.+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++-- | -- Execute, folding to a list.-{-# INLINABLE toList #-}-toList :: (Monad m, MonadTransUncons t) => t m a -> m [a]+{-# INLINEABLE toList #-}+toList :: (Monad m) => ListT m a -> m [a] toList =- liftM ($ []) . fold (\f e -> return $ f . (e :)) id+ fmap reverse . toReverseList -- |--- Execute, folding to a list in a reverse order.+-- Execute, folding to a list in the reverse order. -- Performs more efficiently than 'toList'.-{-# INLINABLE toReverseList #-}-toReverseList :: (Monad m, MonadTransUncons t) => t m a -> m [a]+{-# INLINEABLE toReverseList #-}+toReverseList :: (Monad m) => ListT m a -> m [a] toReverseList =- ListT.fold (\l -> return . (:l)) []+ fold (\list element -> return (element : list)) [] -- |--- Execute, traversing the stream with a side effect in the inner monad. -{-# INLINABLE traverse_ #-}-traverse_ :: (Monad m, MonadTransUncons t) => (a -> m ()) -> t m a -> m ()+-- Execute, traversing the stream with a side effect in the inner monad.+{-# INLINEABLE traverse_ #-}+traverse_ :: (Monad m) => (a -> m ()) -> ListT m a -> m () traverse_ f = fold (const f) () -- | -- Execute, consuming a list of the specified length and returning the remainder stream.-{-# INLINABLE splitAt #-}-splitAt :: (Monad m, MonadTransUncons t, MonadPlus (t m)) => Int -> t m a -> m ([a], t m a)+{-# INLINEABLE splitAt #-}+splitAt :: (Monad m) => Int -> ListT m a -> m ([a], ListT m a) splitAt = \case n | n > 0 -> \l ->@@ -266,85 +409,89 @@ Just (h, t) -> do (r1, r2) <- splitAt (pred n) t return (h : r1, r2)- _ -> \l -> + _ -> \l -> return ([], l) - -- * Construction+ ------------------------- -- |+-- Prepend an element.+cons :: (Monad m) => a -> ListT m a -> ListT m a+cons h t =+ ListT $ return (Just (h, t))++-- | -- Construct from any foldable.-{-# INLINABLE fromFoldable #-}-fromFoldable :: (MonadCons m, Foldable f) => f a -> m a-fromFoldable = +{-# INLINEABLE fromFoldable #-}+fromFoldable :: (Monad m, Foldable f) => f a -> ListT m a+fromFoldable = foldr cons mzero -- |--- Construct from an MVar, interpreting a value of Nothing as an end.-fromMVar :: (MonadCons m, MonadIO m) => MVar (Maybe a) -> m a+-- Construct from an MVar, interpreting the value of Nothing as the end.+fromMVar :: (MonadIO m) => MVar (Maybe a) -> ListT m a fromMVar v = fix $ \loop -> liftIO (takeMVar v) >>= maybe mzero (flip cons loop) -- | -- Construct by unfolding a pure data structure.-{-# INLINABLE unfold #-}-unfold :: (MonadCons m) => (b -> Maybe (a, b)) -> b -> m a+{-# INLINEABLE 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) -- | -- Construct by unfolding a monadic data structure ----- This is the most memory-efficient way to construct a ListT where+-- This is the most memory-efficient way to construct ListT where -- the length depends on the inner monad.-{-# INLINABLE unfoldM #-}+{-# INLINEABLE 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))+unfoldM f = go+ where+ go s =+ ListT $+ f s >>= \case+ Nothing -> return Nothing+ Just (a, r) -> return (Just (a, go r)) -- | -- Produce an infinite stream.-{-# INLINABLE repeat #-}-repeat :: (MonadCons m) => a -> m a-repeat = +{-# INLINEABLE repeat #-}+repeat :: (Monad m) => a -> ListT m a+repeat = fix . cons - -- * Transformation-------------------------- --- |--- A function, which updates the contents of a list transformer.--- --- Since it's merely just a function,--- you can run it by passing a list transformer as an argument.-type Transformation m a b = - forall t. (Monad m, MonadCons (t m), MonadTransUncons t) =>- t m a -> t m b+------------------------- -- | -- A transformation, -- which traverses the stream with an action in the inner monad.-{-# INLINABLE traverse #-}-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+{-# INLINEABLE traverse #-}+traverse :: (Monad m) => (a -> m b) -> ListT m a -> ListT m b+traverse f =+ go+ where+ go (ListT run) =+ ListT $+ run >>= \case+ Nothing -> return Nothing+ Just (a, next) -> f a <&> \b -> Just (b, go next) -- | -- A transformation, -- reproducing the behaviour of @Data.List.'Data.List.take'@.-{-# INLINABLE take #-}-take :: Int -> Transformation m a a+{-# INLINEABLE take #-}+take :: (Monad m) => Int -> ListT m a -> ListT m a take = \case n | n > 0 -> \t ->- lift (uncons t) >>= - \case+ lift (uncons t)+ >>= \case Nothing -> t Just (h, t) -> cons h (take (pred n) t) _ ->@@ -353,43 +500,24 @@ -- | -- A transformation, -- reproducing the behaviour of @Data.List.'Data.List.drop'@.-{-# INLINABLE drop #-}-drop :: Int -> Transformation m a a+{-# INLINEABLE drop #-}+drop :: (Monad m) => Int -> ListT m a -> ListT m a drop = \case- n | n > 0 ->- lift . uncons >=> maybe mzero (drop (pred n) . snd)+ n+ | n > 0 ->+ lift . uncons >=> maybe mzero (drop (pred n) . snd) _ -> id -- | -- A transformation, -- which slices a list into chunks of the specified length.-{-# INLINABLE slice #-}-slice :: Positive Int -> Transformation m a [a]-slice n l = +{-# INLINEABLE slice #-}+slice :: (Monad m) => Int -> ListT m a -> ListT m [a]+slice n l = do- (h, t) <- lift $ splitAt (case n of Positive n -> n) l+ (h, t) <- lift $ splitAt n l case h of [] -> mzero _ -> cons h (slice n t)----- * Positive numbers------------------------------ |--- A newtype wrapper around a number,--- which ensures that it is greater than zero.-newtype Positive n = - Positive n- deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)---- |--- A smart constructor for positive numbers.-positive :: (Ord n, Num n) => n -> Maybe (Positive n)-positive =- \case- n | n > 0 -> Just $ Positive n- _ -> Nothing-
+ library/ListT/Prelude.hs view
@@ -0,0 +1,93 @@+{-# OPTIONS_GHC -Wno-dodgy-imports #-}++module ListT.Prelude+ ( module Exports,+ bimapPair',+ secondPair',+ )+where++import Control.Applicative as Exports+import Control.Category as Exports+import Control.Concurrent as Exports+import Control.Exception as Exports+import Control.Foldl as Exports (Fold (..), FoldM (..))+import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_)+import Control.Monad.Base as Exports+import Control.Monad.Error.Class as Exports+import Control.Monad.Fail as Exports+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports+import Control.Monad.Logic.Class as Exports+import Control.Monad.Morph as Exports hiding (MonadTrans (..))+import Control.Monad.Reader.Class as Exports+import Control.Monad.ST as Exports+import Control.Monad.State.Class as Exports+import Control.Monad.Trans.Class as Exports+import Control.Monad.Trans.Control as Exports hiding (embed, embed_)+import Control.Monad.Trans.Maybe as Exports hiding (liftCallCC, liftCatch)+import Control.Monad.Zip as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports hiding (unzip)+import Data.Functor.Classes as Exports+import Data.IORef as Exports+import Data.Int as Exports+import Data.Ix as Exports+import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)+import Data.Maybe as Exports+import Data.Monoid as Exports hiding (First, Last, getFirst, getLast, (<>))+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.STRef as Exports+import Data.Semigroup as Exports+import Data.String as Exports+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.Unique as Exports+import Data.Version as Exports+import Data.Word as Exports+import Debug.Trace as Exports+import Foreign.ForeignPtr as Exports+import Foreign.Ptr as Exports+import Foreign.StablePtr as Exports+import Foreign.Storable as Exports+import GHC.Conc as Exports hiding (threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (groupWith, inline, lazy, sortWith)+import GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+import Numeric as Exports+import System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports (Handle, hClose)+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+import System.Mem as Exports+import System.Mem.StableName as Exports+import System.Timeout as Exports+import Text.Printf as Exports (hPrintf, printf)+import Text.Read as Exports (Read (..), readEither, readMaybe)+import Unsafe.Coerce as Exports+import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, unzip, (.))++-- |+-- A slightly stricter version of Data.Bifunctor.bimap.+-- There's no benefit to producing lazy pairs here.+bimapPair' :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)+bimapPair' f g = \(a, c) -> (f a, g c)++-- |+-- A slightly stricter version of Data.Bifunctor.second+-- that doesn't produce gratuitous lazy pairs.+secondPair' :: (b -> c) -> (a, b) -> (a, c)+secondPair' f = \(a, b) -> (a, f b)
list-t.cabal view
@@ -1,75 +1,91 @@-name:- list-t-version:- 0.4.7-synopsis:- ListT done right+cabal-version: 3.0+name: list-t+version: 1.0.5.7+synopsis: ListT done right description: A correct implementation of the list monad-transformer. Useful for basic streaming.-category:- Streaming, Data Structures, Control-homepage:- https://github.com/nikita-volkov/list-t-bug-reports:- https://github.com/nikita-volkov/list-t/issues-author:- Nikita Volkov <nikita.y.volkov@mail.ru>-maintainer:- Nikita Volkov <nikita.y.volkov@mail.ru>-copyright:- (c) 2014, Nikita Volkov-license:- MIT-license-file:- LICENSE-build-type:- Simple-cabal-version:- >=1.10 +category: Streaming, Data Structures, Control+homepage: https://github.com/nikita-volkov/list-t+bug-reports: https://github.com/nikita-volkov/list-t/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2014, Nikita Volkov+license: MIT+license-file: LICENSE source-repository head- type:- git- location:- git://github.com/nikita-volkov/list-t.git+ type: git+ location: git://github.com/nikita-volkov/list-t.git +common language-settings+ default-extensions:+ NoImplicitPrelude+ NoMonomorphismRestriction+ BangPatterns+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveDataTypeable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ EmptyDataDecls+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ LambdaCase+ LiberalTypeSynonyms+ MagicHash+ MultiParamTypeClasses+ MultiWayIf+ OverloadedStrings+ ParallelListComp+ PatternGuards+ PolyKinds+ QuasiQuotes+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeFamilies+ TypeOperators+ UnboxedTuples+ UndecidableInstances + default-language: Haskell2010+ library- hs-source-dirs:- library- other-modules:- exposed-modules:- ListT+ import: language-settings+ hs-source-dirs: library+ exposed-modules: ListT+ other-modules: ListT.Prelude build-depends:- mmorph == 1.*,- monad-control >= 0.3 && < 2,- mtl == 2.*,- transformers-base == 0.4.*,- transformers >= 0.3 && < 0.6,- base-prelude < 2,- base < 4.10- default-extensions:- Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, PolyKinds, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples- default-language:- Haskell2010+ , base >=4.11 && <5+ , foldl >=1.2 && <2+ , logict >=0.7 && <0.9+ , mmorph >=1 && <2+ , monad-control >=0.3 && <2+ , mtl >=2 && <3+ , transformers >=0.3 && <0.7+ , transformers-base ^>=0.4 + if impl(ghc <8.0)+ build-depends: semigroups >=0.11 && <0.21 -test-suite tests- type:- exitcode-stdio-1.0- hs-source-dirs:- tests- main-is:- Main.hs+test-suite htf-test+ import: language-settings+ type: exitcode-stdio-1.0+ hs-source-dirs: htf-test+ main-is: Main.hs build-depends:- list-t,- mmorph,- HTF == 0.13.*,- mtl-prelude < 3,- base-prelude- default-extensions:- Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, PolyKinds, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples- default-language:- Haskell2010+ , base-prelude+ , HTF ^>=0.15+ , list-t+ , mmorph+ , mtl-prelude <3
− tests/Main.hs
@@ -1,156 +0,0 @@-{-# OPTIONS_GHC -F -pgmF htfpp #-}--import BasePrelude hiding (toList)-import MTLPrelude-import Control.Monad.Morph-import Test.Framework-import qualified ListT as L---main = htfMain $ htf_thisModulesTests----- * MMonad------------------------------ embed lift = id-prop_mmonadLaw1 (l :: [Int]) =- let s = L.fromFoldable l- in runIdentity $ streamsEqual s (embed lift s)---- embed f (lift m) = f m-prop_mmonadLaw2 l =- let s = (L.fromFoldable :: [Int] -> L.ListT Identity Int) l- f = MaybeT . fmap Just- run = runIdentity . L.toList . runMaybeT- in - run (f s) == - run (embed f (lift s))----- * Applicative----------------------------prop_applicativeIdentityLaw (l :: [Int]) =- runIdentity $ streamsEqual (pure id <*> s) s- where- s = L.fromFoldable l--prop_applicativeBehavesLikeList =- \(ns :: [Int]) ->- let a = fs <*> ns- b = runIdentity (toList $ L.fromFoldable fs <*> L.fromFoldable ns)- in a == b- where- fs = [(+1), (+3), (+5)]----- * Monad----------------------------test_monadLaw1 =- assertBool =<< streamsEqual (return a >>= k) (k a)- where- a = 2- k a = return $ chr a--test_monadLaw2 =- assertBool =<< streamsEqual (m >>= return) m- where- m = L.fromFoldable ['a'..'z']--test_monadLaw3 =- assertBool =<< streamsEqual (m >>= (\x -> k x >>= h)) ((m >>= k) >>= h)- where- m = L.fromFoldable ['a'..'z']- k a = return $ ord a- h a = return $ a + 1--test_monadLaw4 =- assertBool =<< streamsEqual (fmap f xs) (xs >>= return . f)- where- f = ord- xs = L.fromFoldable ['a'..'z']----- * Monoid----------------------------test_mappend =- assertBool =<< - streamsEqual - (L.fromFoldable [0..7]) - (L.fromFoldable [0..3] <> L.fromFoldable [4..7])--test_mappendAndTake =- assertBool =<< - streamsEqual - (L.fromFoldable [0..5]) - (L.take 6 $ L.fromFoldable [0..3] <> L.fromFoldable [4..7])--test_mappendDoesntCauseTraversal =- do- ref <- newIORef 0- (flip runReaderT) ref (toList $ L.take 5 $ stream <> stream)- assertEqual 5 =<< readIORef ref- where- stream =- do- ref <- lift $ ask- x <- L.fromFoldable [0..4]- liftIO $ modifyIORef ref (+1)- return x----- * Other----------------------------test_repeat =- assertEqual [2,2,2] =<< do- toList $ L.take 3 $ L.repeat (2 :: Int)--test_traverseDoesntCauseTraversal =- do- ref <- newIORef 0- (flip runReaderT) ref (toList stream3)- assertEqual 3 =<< readIORef ref- where- stream1 =- do- ref <- lift $ ask- x <- L.fromFoldable ['a'..'z']- liftIO $ modifyIORef ref (+1)- return x- stream2 =- L.traverse (return . toUpper) stream1- stream3 =- L.take 3 stream2--test_takeDoesntCauseTraversal =- do- ref <- newIORef 0- (flip runReaderT) ref (toList $ L.take 3 $ L.take 7 $ stream)- assertEqual 3 =<< readIORef ref- where- stream =- do- ref <- lift $ ask- x <- L.fromFoldable [0..10]- liftIO $ modifyIORef ref (+1)- return x--test_drop =- assertEqual [3, 4] =<< do- toList $ L.drop 2 $ L.fromFoldable [1 .. 4]- -test_slice =- assertEqual ["abc", "def", "gh"] =<< do- toList $ L.slice (fromJust $ L.positive 3) $ L.fromFoldable ("abcdefgh" :: [Char])---toList :: Monad m => L.ListT m a -> m [a]-toList = L.toList--streamsEqual :: (Applicative m, Monad m, Eq a) => L.ListT m a -> L.ListT m a -> m Bool-streamsEqual a b =- (==) <$> L.toList a <*> L.toList b