diff --git a/src/Streaming/ListT.hs b/src/Streaming/ListT.hs new file mode 100644 index 0000000..a94f2de --- /dev/null +++ b/src/Streaming/ListT.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wall #-} + +module Streaming.ListT + ( ListT(..) + --, runListT + ) where + +import Streaming.Internal +import Data.Functor.Of +import qualified Streaming.Prelude as S + +import Control.Applicative (Applicative (..)) --, Alternative (..)) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Morph +import Control.Monad.Error.Class +import Control.Monad.Reader.Class +import Control.Monad.State.Class +import Control.Monad.Writer.Class +import Control.Monad.Zip +import Data.Functor (Functor (..)) +--import Data.Semigroup (Semigroup ((<>))) + +newtype ListT m a = Select { enumerate :: Stream (Of a) m () } + +instance Monad m => Functor (ListT m) where + fmap f (Select p) = Select (S.map f p) + {-# INLINE fmap #-} + +instance Monad m => Applicative (ListT m) where + pure a = Select (S.yield a) + {-# INLINE pure #-} + mf <*> mx = Select + ( S.for (enumerate mf) (\f -> + S.for (enumerate mx) (\x -> + S.yield (f x))) + ) + +instance Monad m => Monad (ListT m) where + return = pure + {-# INLINE return #-} + m >>= f = Select (S.for (enumerate m) (\a -> enumerate (f a))) + {-# INLINE (>>=) #-} + +instance (Monad m, Foldable m) => Foldable (ListT m) where + foldMap f (Select p) = foldMap id (S.foldMap_ f p) + +instance (Monad m, Traversable m) => Traversable (ListT m) where + traverse k (Select p) = fmap Select (t_ p) + where + t_ x = case x of + Return () -> pure (Return ()) + Effect m -> fmap Effect (traverse t_ m) + Step (a :> rest) -> (\a_ rest_ -> Step (a_ :> rest_)) <$> k a <*> t_ rest + +instance MonadTrans ListT where + lift m = Select (do + a <- lift m + S.yield a) + +instance MonadIO m => MonadIO (ListT m) where + liftIO m = lift (liftIO m) + {-# INLINE liftIO #-} + +-- what should this be? +--instance Monad m => Alternative (ListT m) where + +--instance Monad m => MonadPlus (ListT m) where +-- mzero = empty +-- {-# INLINE mzero #-} +-- mplus = (<|>) +-- {-# INLINE mplus #-} + +instance MFunctor ListT where + hoist morph = Select . hoist morph . enumerate + {-# INLINE hoist #-} + +instance MMonad ListT where + embed f (Select p0) = Select (loop p0) + where + loop x = case x of + Return () -> Return () + Effect m -> S.for (enumerate (fmap loop (f m))) id + Step (a :> rest) -> Step (a :> loop rest) + {-# INLINE embed #-} + +instance (MonadState s m) => MonadState s (ListT m) where + get = lift get + {-# INLINE get #-} + + put s = lift (put s) + {-# INLINE put #-} + + state f = lift (state f) + {-# INLINE state #-} + +instance (MonadWriter w m) => MonadWriter w (ListT m) where + writer = lift . writer + {-# INLINE writer #-} + + tell w = lift (tell w) + {-# INLINE tell #-} + + listen l = Select (go (enumerate l) mempty) + where + go p w = case p of + Return () -> Return () + Effect m -> Effect (do + (p', w') <- listen m + pure (go p' $! mappend w w') ) + Step (a :> rest) -> Step ((a,w) :> go rest w) + + pass l = Select (go (enumerate l) mempty) + where + go p w = case p of + Return () -> Return () + Effect m -> Effect (do + (p', w') <- listen m + pure (go p' $! mappend w w')) + Step ((b,f) :> rest) -> Effect (pass (pure + (Step (b :> (go rest (f w))), \_ -> f w) )) + +instance (MonadReader i m) => MonadReader i (ListT m) where + ask = lift ask + {-# INLINE ask #-} + + local f l = Select (local f (enumerate l)) + {-# INLINE local #-} + + reader f = lift (reader f) + {-# INLINE reader #-} + +instance (MonadError e m) => MonadError e (ListT m) where + throwError e = lift (throwError e) + {-# INLINE throwError #-} + + catchError l k = Select (catchError (enumerate l) (\e -> enumerate (k e))) + {-# INLINE catchError #-} + +{- These instances require a dependency on `exceptions`. +instance MonadThrow m => MonadThrow (ListT m) where + throwM = Select . throwM + {-# INLINE throwM #-} + +instance MonadCatch m => MonadCatch (ListT m) where + catch l k = Select (Control.Monad.Catch.catch (enumerate l) (\e -> enumerate (k e))) + {-# INLINE catch #-} +-} + +instance Monad m => MonadZip (ListT m) where + mzipWith f (Select p) (Select p') = Select (S.zipWith f p p') + +-- no MonadPlus instance yet +--runListT :: Monad m => ListT m a -> m () +--runListT l = S.effects (enumerate (l >> mzero)) +--{-# INLINABLE runListT #-} \ No newline at end of file diff --git a/src/Streaming/Prelude.hs b/src/Streaming/Prelude.hs index 4446a8e..f0a7fb8 100644 --- a/src/Streaming/Prelude.hs +++ b/src/Streaming/Prelude.hs @@ -256,19 +256,31 @@ module Streaming.Prelude ( -- * Basic Type , Stream ) where + import Streaming.Internal +import Control.Applicative (Applicative (..)) +import Control.Concurrent (threadDelay) +import Control.Exception (throwIO, try) import Control.Monad hiding (filterM, mapM, mapM_, foldM, foldM_, replicateM, sequence) -import Data.Functor.Identity -import Data.Functor.Sum import Control.Monad.Trans -import Control.Applicative (Applicative (..)) import Data.Functor (Functor (..), (<$)) - -import qualified Prelude as Prelude +import Data.Functor.Compose +import Data.Functor.Identity +import Data.Functor.Of +import Data.Functor.Sum +import Data.Monoid (Monoid (mappend, mempty)) +import Data.Ord (Ordering (..), comparing) +import Foreign.C.Error (Errno(Errno), ePIPE) +import Text.Read (readMaybe) import qualified Data.Foldable as Foldable +import qualified Data.IntSet as IntSet import qualified Data.Sequence as Seq -import Text.Read (readMaybe) +import qualified Data.Set as Set +import qualified GHC.IO.Exception as G +import qualified Prelude as Prelude +import qualified System.IO as IO + import Prelude hiding (map, mapM, mapM_, filter, drop, dropWhile, take, mconcat , sum, product, iterate, repeat, cycle, replicate, splitAt , takeWhile, enumFrom, enumFromTo, enumFromThen, length @@ -277,17 +289,6 @@ import Prelude hiding (map, mapM, mapM_, filter, drop, dropWhile, take, mconcat , minimum, maximum, elem, notElem, all, any, head , last, foldMap) -import qualified GHC.IO.Exception as G -import qualified System.IO as IO -import Foreign.C.Error (Errno(Errno), ePIPE) -import Control.Exception (throwIO, try) -import Data.Monoid (Monoid (mappend, mempty)) -import Control.Concurrent (threadDelay) -import Data.Functor.Compose -import Data.Functor.Of -import qualified Data.Set as Set -import qualified Data.IntSet as IntSet -import Data.Ord (Ordering (..), comparing) -- instance (Eq a) => Eq1 (Of a) where eq1 = (==) -- instance (Ord a) => Ord1 (Of a) where compare1 = compare @@ -355,10 +356,10 @@ strictly = \(a,b) -> a :> b fst' :: Of a b -> a fst' (a :> _) = a -{-#INLINE fst' #-} +{-# INLINE fst' #-} snd' :: Of a b -> b snd' (_ :> b) = b -{-#INLINE snd' #-} +{-# INLINE snd' #-} {-| Map a function over the first element of an @Of@ pair @@ -380,7 +381,7 @@ False :> "hi" mapOf :: (a -> b) -> Of a r -> Of b r mapOf f (a:> b) = (f a :> b) -{-#INLINE mapOf #-} +{-# INLINE mapOf #-} {-| A lens into the first element of a left-strict pair -} _first :: Functor f => (a -> f a') -> Of a b -> f (Of a' b) @@ -390,7 +391,7 @@ _first afb (a:>b) = fmap (\c -> (c:>b)) (afb a) {-| A lens into the second element of a left-strict pair -} _second :: Functor f => (b -> f b') -> Of a b -> f (Of a b') _second afb (a:>b) = fmap (\c -> (a:>c)) (afb b) -{-#INLINABLE _second #-} +{-# INLINABLE _second #-} all :: Monad m => (a -> Bool) -> Stream (Of a) m r -> m (Of Bool r) all thus = loop True where @@ -402,7 +403,7 @@ all thus = loop True where else do r <- effects rest return (False :> r) -{-#INLINABLE all #-} +{-# INLINABLE all #-} all_ :: Monad m => (a -> Bool) -> Stream (Of a) m r -> m Bool all_ thus = loop True where @@ -412,7 +413,7 @@ all_ thus = loop True where Step (a :> rest) -> if thus a then loop True rest else return False -{-#INLINABLE all_ #-} +{-# INLINABLE all_ #-} any :: Monad m => (a -> Bool) -> Stream (Of a) m r -> m (Of Bool r) @@ -425,7 +426,7 @@ any thus = loop False where r <- effects rest return (True :> r) else loop False rest -{-#INLINABLE any #-} +{-# INLINABLE any #-} any_ :: Monad m => (a -> Bool) -> Stream (Of a) m r -> m Bool any_ thus = loop False where @@ -435,7 +436,7 @@ any_ thus = loop False where Step (a :> rest) -> if thus a then return True else loop False rest -{-#INLINABLE any_ #-} +{-# INLINABLE any_ #-} {-| Break a sequence upon meeting element falls under a predicate, keeping it and the rest of the stream as the return value. @@ -520,7 +521,7 @@ breaks thus = loop where if not (thus a) then Step $ fmap loop (yield a >> break thus p') else loop p' -{-#INLINABLE breaks #-} +{-# INLINABLE breaks #-} {-| Apply an action to all values, re-yielding each @@ -616,7 +617,7 @@ False cycle :: (Monad m, Functor f) => Stream f m r -> Stream f m s cycle str = loop where loop = str >> loop -{-#INLINABLE cycle #-} +{-# INLINABLE cycle #-} {-| Interpolate a delay of n seconds between yields. @@ -632,7 +633,7 @@ delay seconds = loop where yield a liftIO $ threadDelay pico loop rest -{-#INLINABLE delay #-} +{-# INLINABLE delay #-} @@ -661,7 +662,7 @@ delay seconds = loop where -} drained :: (Monad m, Monad (t m), MonadTrans t) => t m (Stream (Of a) m r) -> t m r drained tms = tms >>= lift . effects -{-#INLINE drained #-} +{-# INLINE drained #-} -- --------------- -- drop @@ -767,7 +768,7 @@ effects = loop where Return r -> return r Effect m -> m >>= loop Step (_ :> rest) -> loop rest -{-#INLINABLE effects #-} +{-# INLINABLE effects #-} {-| Exhaust a stream remembering only whether @a@ was an element. @@ -783,7 +784,7 @@ elem a' = loop False where if a == a' then fmap (True :>) (effects rest) else loop False rest -{-#INLINABLE elem #-} +{-# INLINABLE elem #-} elem_ :: (Monad m, Eq a) => a -> Stream (Of a) m r -> m Bool elem_ a' = loop False where @@ -795,7 +796,7 @@ elem_ a' = loop False where if a == a' then return True else loop False rest -{-#INLINABLE elem_ #-} +{-# INLINABLE elem_ #-} -- ----- -- enumFrom @@ -962,7 +963,7 @@ filterM thePred = loop where -} fold_ :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Stream (Of a) m r -> m b fold_ step begin done = fmap (\(a :> _) -> a) . fold step begin done -{-#INLINE fold_ #-} +{-# INLINE fold_ #-} {-| Strict fold of a 'Stream' of elements that preserves the return value. The third parameter will often be 'id' where a fold is written by hand: @@ -1014,7 +1015,7 @@ foldM_ :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> Stream (Of a) m r -> m b foldM_ step begin done = fmap (\(a :> _) -> a) . foldM step begin done -{-#INLINE foldM_ #-} +{-# INLINE foldM_ #-} {-| Strict, monadic fold of the elements of a 'Stream (Of a)' @@ -1055,7 +1056,7 @@ foldM step begin done str = do -- b <- done x' -- return (b :> r) -- where seq = Prelude.seq --- {-#INLINE foldM #-} +-- {-# INLINE foldM #-} {-| A natural right fold for consuming a stream of elements. See also the more general 'iterTM' in the 'Streaming' module @@ -1166,7 +1167,7 @@ groupBy equals = loop where -} group :: (Monad m, Eq a) => Stream (Of a) m r -> Stream (Stream (Of a) m) m r group = groupBy (==) -{-#INLINE group #-} +{-# INLINE group #-} head :: Monad m => Stream (Of a) m r -> m (Of (Maybe a) r) @@ -1174,14 +1175,14 @@ head str = case str of Return r -> return (Nothing :> r) Effect m -> m >>= head Step (a :> rest) -> effects rest >>= \r -> return (Just a :> r) -{-#INLINABLE head #-} +{-# INLINABLE head #-} head_ :: Monad m => Stream (Of a) m r -> m (Maybe a) head_ str = case str of Return _ -> return Nothing Effect m -> m >>= head_ Step (a :> _) -> return (Just a) -{-#INLINABLE head_ #-} +{-# INLINABLE head_ #-} intersperse :: Monad m => a -> Stream (Of a) m r -> Stream (Of a) m r intersperse x str = case str of @@ -1193,7 +1194,7 @@ intersperse x str = case str of Return r -> Step (a :> Return r) Effect m -> Effect (fmap (loop a) m) Step (b :> rest) -> Step (a :> Step (x :> loop b rest)) -{-#INLINABLE intersperse #-} +{-# INLINABLE intersperse #-} @@ -1230,7 +1231,7 @@ last = loop Nothing_ where Just_ a -> return (Just a :> r) Effect m -> m >>= loop mb Step (a :> rest) -> loop (Just_ a) rest -{-#INLINABLE last #-} +{-# INLINABLE last #-} @@ -1242,7 +1243,7 @@ last_ = loop Nothing_ where Just_ a -> return (Just a) Effect m -> m >>= loop mb Step (a :> rest) -> loop (Just_ a) rest -{-#INLINABLE last_ #-} +{-# INLINABLE last_ #-} -- --------------- @@ -1257,7 +1258,7 @@ last_ = loop Nothing_ where -} length_ :: Monad m => Stream (Of a) m r -> m Int length_ = fold_ (\n _ -> n + 1) 0 id -{-#INLINE length_#-} +{-# INLINE length_#-} {-| Run a stream, keeping its length and its return value. @@ -1271,7 +1272,7 @@ length_ = fold_ (\n _ -> n + 1) 0 id length :: Monad m => Stream (Of a) m r -> m (Of Int r) length = fold (\n _ -> n + 1) 0 id -{-#INLINE length #-} +{-# INLINE length #-} -- --------------- -- map -- --------------- @@ -1372,7 +1373,7 @@ mapM_ f = loop where mapped :: (Monad m, Functor f) => (forall x . f x -> m (g x)) -> Stream f m r -> Stream g m r mapped = mapsM -{-#INLINE mapped #-} +{-# INLINE mapped #-} {-| A version of 'mapped' that imposes a 'Functor' constraint on the target functor rather than the source functor. This version should be preferred if 'fmap' on the target @@ -1426,19 +1427,19 @@ minimum_ :: (Monad m, Ord a) => Stream (Of a) m r -> m (Maybe a) minimum_ = fold_ (\m a -> case m of Nothing_ -> Just_ a ; Just_ a' -> Just_ (min a a')) Nothing_ (\m -> case m of Nothing_ -> Nothing; Just_ r -> Just r) -{-#INLINE minimum_ #-} +{-# INLINE minimum_ #-} maximum :: (Monad m, Ord a) => Stream (Of a) m r -> m (Of (Maybe a) r) maximum = fold (\m a -> case m of Nothing_ -> Just_ a ; Just_ a' -> Just_ (max a a')) Nothing_ (\m -> case m of Nothing_ -> Nothing; Just_ r -> Just r) -{-#INLINE maximum #-} +{-# INLINE maximum #-} maximum_ :: (Monad m, Ord a) => Stream (Of a) m r -> m (Maybe a) maximum_ = fold_ (\m a -> case m of Nothing_ -> Just_ a ; Just_ a' -> Just_ (max a a')) Nothing_ (\m -> case m of Nothing_ -> Nothing; Just_ r -> Just r) -{-#INLINE maximum_ #-} +{-# INLINE maximum_ #-} {-| The standard way of inspecting the first item in a stream of elements, if the stream is still \'running\'. The @Right@ case contains a @@ -1484,7 +1485,7 @@ notElem a' = loop True where if a == a' then fmap (False :>) (effects rest) else loop True rest -{-#INLINABLE notElem #-} +{-# INLINABLE notElem #-} notElem_ :: (Monad m, Eq a) => a -> Stream (Of a) m r -> m Bool notElem_ a' = loop True where @@ -1496,7 +1497,7 @@ notElem_ a' = loop True where if a == a' then return False else loop True rest -{-#INLINABLE notElem_ #-} +{-# INLINABLE notElem_ #-} {-| Remove repeated elements from a Stream. 'nubOrd' of course accumulates a 'Data.Set.Set' of @@ -1731,7 +1732,7 @@ scan step begin done str = Step (done begin :> loop begin str) Step (a :> rest) -> let !acc' = step acc a in Step (done acc' :> loop acc' rest) -{-#INLINABLE scan #-} +{-# INLINABLE scan #-} {-| Strict left scan, accepting a monadic function. It can be used with 'FoldM's from @Control.Foldl@ using 'impurely'. Here we yield @@ -1926,7 +1927,7 @@ split t = loop where if a /= t then Step (fmap loop (yield a >> break (== t) rest)) else loop rest -{-#INLINABLE split #-} +{-# INLINABLE split #-} {-| Split a succession of layers after some number, returning a streaming or effectful pair. This function is the same as the 'splitsAt' exported by the @@ -1958,7 +1959,7 @@ subst f s = loop s where Return r -> Return r Effect m -> Effect (fmap loop m) Step (a :> rest) -> Step (loop rest <$ f a) -{-#INLINABLE subst #-} +{-# INLINABLE subst #-} -- --------------- -- take -- --------------- @@ -2130,7 +2131,7 @@ untilRight act = Effect loop where case e of Right r -> return (Return r) Left a -> return (Step (a :> Effect loop)) -{-#INLINABLE untilRight #-} +{-# INLINABLE untilRight #-} -- --------------------------------------- -- with @@ -2157,7 +2158,7 @@ with s f = loop s where Return r -> Return r Effect m -> Effect (fmap loop m) Step (a :> rest) -> Step (loop rest <$ f a) -{-#INLINABLE with #-} +{-# INLINABLE with #-} -- --------------------------------------- -- yield @@ -2506,31 +2507,31 @@ stdoutLn' = toHandle IO.stdout distinguish :: (a -> Bool) -> Of a r -> Sum (Of a) (Of a) r distinguish predicate (a :> b) = if predicate a then InR (a :> b) else InL (a :> b) -{-#INLINE distinguish #-} +{-# INLINE distinguish #-} sumToEither ::Sum (Of a) (Of b) r -> Of (Either a b) r sumToEither s = case s of InL (a :> r) -> Left a :> r InR (b :> r) -> Right b :> r -{-#INLINE sumToEither #-} +{-# INLINE sumToEither #-} eitherToSum :: Of (Either a b) r -> Sum (Of a) (Of b) r eitherToSum s = case s of Left a :> r -> InL (a :> r) Right b :> r -> InR (b :> r) -{-#INLINE eitherToSum #-} +{-# INLINE eitherToSum #-} composeToSum :: Compose (Of Bool) f r -> Sum f f r composeToSum x = case x of Compose (True :> f) -> InR f Compose (False :> f) -> InL f -{-#INLINE composeToSum #-} +{-# INLINE composeToSum #-} sumToCompose :: Sum f f r -> Compose (Of Bool) f r sumToCompose x = case x of InR f -> Compose (True :> f) InL f -> Compose (False :> f) -{-#INLINE sumToCompose #-} +{-# INLINE sumToCompose #-} {-| Store the result of any suitable fold over a stream, keeping the stream for further manipulation. @store f = f . copy@ : @@ -2612,7 +2613,7 @@ store :: Monad m => (Stream (Of a) (Stream (Of a) m) r -> t) -> Stream (Of a) m r -> t store f x = f (copy x) -{-#INLINE store #-} +{-# INLINE store #-} {-| Duplicate the content of stream, so that it can be acted on twice in different ways, but without breaking streaming. Thus, with @each [1,2]@ I might do: @@ -2703,13 +2704,13 @@ copy = Effect . return . loop where Return r -> Return r Effect m -> Effect (fmap loop (lift m)) Step (a :> rest) -> Effect (Step (a :> Return (Step (a :> loop rest)))) -{-#INLINABLE copy#-} +{-# INLINABLE copy#-} duplicate :: Monad m => Stream (Of a) m r -> Stream (Of a) (Stream (Of a) m) r duplicate = copy -{-#INLINE duplicate #-} +{-# INLINE duplicate #-} {-| The type @@ -2770,7 +2771,7 @@ unzip = loop where Return r -> Return r Effect m -> Effect (fmap loop (lift m)) Step ((a,b):> rest) -> Step (a :> Effect (Step (b :> Return (loop rest)))) -{-#INLINABLE unzip #-} +{-# INLINABLE unzip #-} @@ -2857,7 +2858,7 @@ catMaybes = loop where Step (ma :> snext) -> case ma of Nothing -> loop snext Just a -> Step (a :> loop snext) -{-#INLINABLE catMaybes #-} +{-# INLINABLE catMaybes #-} {-| The 'mapMaybe' function is a version of 'map' which can throw out elements. In particular, the functional argument returns something of type @'Maybe' b@. If this is 'Nothing', no element @@ -2872,7 +2873,7 @@ mapMaybe phi = loop where Step (a :> snext) -> case phi a of Nothing -> loop snext Just b -> Step (b :> loop snext) -{-#INLINABLE mapMaybe #-} +{-# INLINABLE mapMaybe #-} {-| 'slidingWindow' accumulates the first @n@ elements of a stream, update thereafter to form a sliding window of length @n@. @@ -2907,7 +2908,7 @@ slidingWindow n = setup (max 1 n :: Int) mempty case e of Left r -> yield sequ >> return r Right (x,rest) -> setup (m-1) (sequ Seq.|> x) rest -{-#INLINABLE slidingWindow #-} +{-# INLINABLE slidingWindow #-} -- | Map monadically over a stream, producing a new stream -- only containing the 'Just' values. @@ -2920,4 +2921,4 @@ mapMaybeM phi = loop where flip fmap (phi a) $ \x -> case x of Nothing -> loop snext Just b -> Step (b :> loop snext) -{-#INLINABLE mapMaybeM #-} +{-# INLINABLE mapMaybeM #-} diff --git a/streaming.cabal b/streaming.cabal index cfc3a13..bf5a475 100644 --- a/streaming.cabal +++ b/streaming.cabal @@ -202,6 +202,7 @@ library Streaming , Streaming.Prelude , Streaming.Internal + , Streaming.ListT , Data.Functor.Of other-extensions: RankNTypes