streaming 0.1.4.5 → 0.2.0.0
raw patch · 5 files changed
+659/−463 lines, 5 filesdep −monad-controldep −resourcetdep −timedep ~basedep ~mmorphdep ~transformersnew-uploader
Dependencies removed: monad-control, resourcet, time
Dependency ranges changed: base, mmorph, transformers
Files
- src/Data/Functor/Of.hs +83/−0
- src/Streaming.hs +15/−19
- src/Streaming/Internal.hs +359/−173
- src/Streaming/Prelude.hs +173/−238
- streaming.cabal +29/−33
+ src/Data/Functor/Of.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveTraversable, DeriveFoldable,+ DeriveGeneric #-}+module Data.Functor.Of where+import Data.Monoid+import Control.Applicative+import Data.Traversable (Traversable)+import Data.Foldable (Foldable)+#if MIN_VERSION_base(4,8,0)+import Data.Bifunctor+#endif+import Data.Data+import Data.Typeable+import GHC.Generics (Generic, Generic1)+import Data.Functor.Classes++-- | A left-strict pair; the base functor for streams of individual elements.+data Of a b = !a :> b+ deriving (Data, Eq, Foldable, Ord,+ Read, Show, Traversable, Typeable, Generic, Generic1)+infixr 5 :>++instance (Monoid a, Monoid b) => Monoid (Of a b) where+ mempty = mempty :> mempty+ {-#INLINE mempty #-}+ mappend (m :> w) (m' :> w') = mappend m m' :> mappend w w'+ {-#INLINE mappend #-}++instance Functor (Of a) where+ fmap f (a :> x) = a :> f x+ {-#INLINE fmap #-}+ a <$ (b :> x) = b :> a+ {-#INLINE (<$) #-}++#if MIN_VERSION_base(4,8,0)+instance Bifunctor Of where+ bimap f g (a :> b) = f a :> g b+ {-#INLINE bimap #-}+ first f (a :> b) = f a :> b+ {-#INLINE first #-}+ second g (a :> b) = a :> g b+ {-#INLINE second #-}+#endif++instance Monoid a => Applicative (Of a) where+ pure x = mempty :> x+ {-#INLINE pure #-}+ m :> f <*> m' :> x = mappend m m' :> f x+ {-#INLINE (<*>) #-}+ m :> x *> m' :> y = mappend m m' :> y+ {-#INLINE (*>) #-}+ m :> x <* m' :> y = mappend m m' :> x+ {-#INLINE (<*) #-}++instance Monoid a => Monad (Of a) where+ return x = mempty :> x+ {-#INLINE return #-}+ m :> x >> m' :> y = mappend m m' :> y+ {-#INLINE (>>) #-}+ m :> x >>= f = let m' :> y = f x in mappend m m' :> y+ {-#INLINE (>>=) #-}++instance Show a => Show1 (Of a) where+ liftShowsPrec = liftShowsPrec2 showsPrec showList++instance Show2 Of where+ liftShowsPrec2 spa _sla spb _slb p (a :> b) =+ showParen (p > 5) $+ spa 6 a .+ showString " :> " .+ spb 6 b++instance Eq a => Eq1 (Of a) where+ liftEq = liftEq2 (==)++instance Ord a => Ord1 (Of a) where+ liftCompare = liftCompare2 compare++instance Eq2 Of where+ liftEq2 eq1 eq2 (x :> y) (z :> w) = eq1 x z && eq2 y w++instance Ord2 Of where+ liftCompare2 comp1 comp2 (x :> y) (z :> w) =+ comp1 x z `mappend` comp2 y w
src/Streaming.hs view
@@ -1,4 +1,6 @@-{-#LANGUAGE RankNTypes, CPP, Trustworthy #-}+{-# LANGUAGE RankNTypes #-}++{-# OPTIONS_GHC -Wall #-} module Streaming ( -- * An iterable streaming monad transformer@@ -19,8 +21,12 @@ -- * Transforming streams maps,+ mapsPost, mapsM,+ mapsMPost, mapped,+ mappedPost,+ hoistUnexposed, distribute, groups, @@ -40,12 +46,15 @@ -- * Zipping, unzipping, separating and unseparating streams zipsWith,+ zipsWith', zips, unzips, interleaves, separate, unseparate, decompose,+ expand,+ expandPost, -- * Eliminating a 'Stream'@@ -61,10 +70,6 @@ lazily, strictly, - -- * ResourceT help-- bracketStream,- -- * re-exports MFunctor(..), MMonad(..),@@ -74,14 +79,7 @@ Sum(..), Identity(..), Alternative((<|>)),- MonadThrow(..),- MonadResource(..),- MonadBase(..),- ResourceT(..),- runResourceT,-#if MIN_VERSION_base(4,8,0) Bifunctor(..),-#endif join, liftM,@@ -102,13 +100,9 @@ import Data.Functor.Compose import Data.Functor.Sum import Data.Functor.Identity--import Control.Monad.Base-import Control.Monad.Trans.Resource-#if MIN_VERSION_base(4,8,0) import Data.Bifunctor-#endif + {- $stream The 'Stream' data type can be used to represent any effectful@@ -133,7 +127,10 @@ > chunksOf :: Int -> Stream f m r -> Stream (Stream f m) m r > splitsAt :: Int -> Stream f m r -> Stream f m (Stream f m r)-> zipsWith :: (forall x y. f x -> g y -> h (x, y)) -> Stream f m r -> Stream g m r -> Stream h m r+> zipsWith :: (forall x y. f x -> g y -> h (x, y))+ -> Stream f m r -> Stream g m r -> Stream h m r+> zipsWith' :: (forall x y p. (x -> y -> p) -> f x -> g y -> h p)+ -> Stream f m r -> Stream g m r -> Stream h m r > intercalates :: Stream f m () -> Stream (Stream f m) m r -> Stream f m r > unzips :: Stream (Compose f g) m r -> Stream f (Stream g m) r > separate :: Stream (Sum f g) m r -> Stream f (Stream g) m r -- cp. partitionEithers@@ -160,7 +157,6 @@ -} {-| Map a stream to its church encoding; compare @Data.List.foldr@- This is the @safe_destroy@ exported by the @Internal@ module. Typical @FreeT@ operators can be defined in terms of @destroy@ e.g.
src/Streaming/Internal.hs view
@@ -1,6 +1,15 @@-{-# LANGUAGE RankNTypes, StandaloneDeriving,DeriveDataTypeable, BangPatterns #-}-{-# LANGUAGE UndecidableInstances, CPP, FlexibleInstances, MultiParamTypeClasses #-}-{-#LANGUAGE Trustworthy #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wall #-} module Streaming.Internal ( -- * The free monad transformer -- $stream@@ -34,6 +43,9 @@ -- * Transforming streams , maps , mapsM+ , mapsPost+ , mapsMPost+ , hoistUnexposed , decompose , mapsM_ , run@@ -51,24 +63,23 @@ -- * Zipping and unzipping streams , zipsWith+ , zipsWith' , zips , unzips , interleaves , separate , unseparate+ , expand+ , expandPost -- * Assorted Data.Functor.x help- , switch - -- * ResourceT help- - , bracketStream- -- * For use in implementation , unexposed , hoistExposed+ , hoistExposedPost , mapsExposed , mapsMExposed , destroyExposed@@ -77,29 +88,19 @@ import Control.Monad import Control.Monad.Trans-import Control.Monad.Trans.Class import Control.Monad.Reader.Class-import Control.Monad.Writer.Class import Control.Monad.State.Class import Control.Monad.Error.Class-import Control.Monad.Cont.Class import Control.Applicative-import Data.Foldable ( Foldable(..) )-import Data.Traversable+import Data.Function ( on ) import Control.Monad.Morph import Data.Monoid (Monoid (..), (<>))-import Data.Functor.Identity-import Data.Data ( Data, Typeable )+import Data.Data (Typeable) import Prelude hiding (splitAt) import Data.Functor.Compose import Data.Functor.Sum+import Data.Functor.Classes import Control.Concurrent (threadDelay)-import Control.Monad.Base-import Control.Monad.Trans.Resource-import Control.Monad.Catch (MonadCatch (..))-import Control.Monad.Trans.Control-- {- $stream The 'Stream' data type is equivalent to @FreeT@ and can represent any effectful@@ -127,26 +128,103 @@ #if __GLASGOW_HASKELL__ >= 710 deriving (Typeable) #endif-deriving instance (Show r, Show (m (Stream f m r))- , Show (f (Stream f m r))) => Show (Stream f m r)-deriving instance (Eq r, Eq (m (Stream f m r))- , Eq (f (Stream f m r))) => Eq (Stream f m r)-#if __GLASGOW_HASKELL__ >= 710-deriving instance (Typeable f, Typeable m, Data r, Data (m (Stream f m r))- , Data (f (Stream f m r))) => Data (Stream f m r)-#endif++-- The most obvious approach would probably be+--+-- s1 == s2 = eqUnexposed (unexposed s1) (unexposed s2)+--+-- but that seems to actually be rather hard (especially if performance+-- matters even a little bit). Using `inspect` instead+-- is nice and simple. The main downside is the rather weird-looking+-- constraint it imposes. We *could* write+--+-- instance (Monad m, Eq r, Eq1 m, Eq1 f) => Eq (Stream f m r)+--+-- but there are an awful lot more Eq instances in the wild than+-- Eq1 instances. Maybe some day soon we'll have implication constraints+-- and everything will be beautiful.+instance (Monad m, Eq (m (Either r (f (Stream f m r)))))+ => Eq (Stream f m r) where+ s1 == s2 = inspect s1 == inspect s2++-- See the notes on Eq.+instance (Monad m, Ord (m (Either r (f (Stream f m r)))))+ => Ord (Stream f m r) where+ compare = compare `on` inspect+ (<) = (<) `on` inspect+ (>) = (>) `on` inspect+ (<=) = (<=) `on` inspect+ (>=) = (>=) `on` inspect++-- We could avoid a Show1 constraint for our Show1 instance by sneakily+-- mapping everything to a single known type, but there's really no way+-- to do that for Eq1 or Ord1.+instance (Monad m, Functor f, Eq1 m, Eq1 f) => Eq1 (Stream f m) where+ liftEq eq xs ys = liftEqExposed (unexposed xs) (unexposed ys)+ where+ liftEqExposed (Return x) (Return y) = eq x y+ liftEqExposed (Effect m) (Effect n) = liftEq liftEqExposed m n+ liftEqExposed (Step f) (Step g) = liftEq liftEqExposed f g+ liftEqExposed _ _ = False++instance (Monad m, Functor f, Ord1 m, Ord1 f) => Ord1 (Stream f m) where+ liftCompare cmp xs ys = liftCmpExposed (unexposed xs) (unexposed ys)+ where+ liftCmpExposed (Return x) (Return y) = cmp x y+ liftCmpExposed (Effect m) (Effect n) = liftCompare liftCmpExposed m n+ liftCmpExposed (Step f) (Step g) = liftCompare liftCmpExposed f g+ liftCmpExposed (Return _) _ = LT+ liftCmpExposed _ (Return _) = GT+ liftCmpExposed _ _ = error "liftCmpExposed: stream was exposed!"++-- We could get a much less scary implementation using Show1, but+-- Show1 instances aren't nearly as common as Show instances.+--+-- How does this+-- funny-looking instance work?+--+-- We 'inspect' the stream to produce @m (Either r (Stream f m r))@.+-- Then we work under @m@ to produce @m ShowSWrapper@. That's almost+-- like producing @m String@, except that a @ShowSWrapper@ can be+-- shown at any precedence. So the 'Show' instance for @m@ can show+-- the contents at the correct precedence.+instance (Monad m, Show r, Show (m ShowSWrapper), Show (f (Stream f m r)))+ => Show (Stream f m r) where+ showsPrec p xs = showParen (p > 10) $+ showString "Effect " . (showsPrec 11 $+ flip fmap (inspect xs) $ \front ->+ SS $ \d -> showParen (d > 10) $+ case front of+ Left r -> showString "Return " . showsPrec 11 r+ Right f -> showString "Step " . showsPrec 11 f)++instance (Monad m, Functor f, Show (m ShowSWrapper), Show (f ShowSWrapper))+ => Show1 (Stream f m) where+ liftShowsPrec sp sl p xs = showParen (p > 10) $+ showString "Effect " . (showsPrec 11 $+ flip fmap (inspect xs) $ \front ->+ SS $ \d -> showParen (d > 10) $+ case front of+ Left r -> showString "Return " . sp 11 r+ Right f -> showString "Step " .+ showsPrec 11 (fmap (SS . (\str i -> liftShowsPrec sp sl i str)) f))++newtype ShowSWrapper = SS (Int -> ShowS)+instance Show ShowSWrapper where+ showsPrec p (SS s) = s p+ instance (Functor f, Monad m) => Functor (Stream f m) where fmap f = loop where loop stream = case stream of Return r -> Return (f r) Effect m -> Effect (do {stream' <- m; return (loop stream')})- Step f -> Step (fmap loop f)+ Step g -> Step (fmap loop g) {-# INLINABLE fmap #-} a <$ stream0 = loop stream0 where loop stream = case stream of- Return r -> Return a- Effect m -> Effect (do {stream' <- m; return (loop stream')})- Step f -> Step (fmap loop f)+ Return _ -> Return a+ Effect m -> Effect (do {stream' <- m; return (loop stream')})+ Step f -> Step (fmap loop f) {-# INLINABLE (<$) #-} instance (Functor f, Monad m) => Monad (Stream f m) where@@ -155,7 +233,7 @@ stream1 >> stream2 = loop stream1 where loop stream = case stream of Return _ -> stream2- Effect m -> Effect (liftM loop m)+ Effect m -> Effect (fmap loop m) Step f -> Step (fmap loop f) {-# INLINABLE (>>) #-} -- (>>=) = _bind@@ -165,7 +243,7 @@ loop stream where loop stream0 = case stream0 of Step fstr -> Step (fmap loop fstr)- Effect m -> Effect (liftM loop m)+ Effect m -> Effect (fmap loop m) Return r -> f r {-# INLINABLE (>>=) #-} @@ -214,7 +292,7 @@ empty = never {-#INLINE empty #-} - str <|> str' = zipsWith (liftA2 (,)) str str'+ str <|> str' = zipsWith' liftA2 str str' {-#INLINE (<|>) #-} instance (Functor f, Monad m, Monoid w) => Monoid (Stream f m w) where@@ -228,17 +306,18 @@ mplus = (<|>) instance Functor f => MonadTrans (Stream f) where- lift = Effect . liftM Return+ lift = Effect . fmap Return {-# INLINE lift #-} instance Functor f => MFunctor (Stream f) where hoist trans = loop where loop stream = case stream of Return r -> Return r- Effect m -> Effect (trans (liftM loop m))+ Effect m -> Effect (trans (fmap loop m)) Step f -> Step (fmap loop f) {-# INLINABLE hoist #-} + instance Functor f => MMonad (Stream f) where embed phi = loop where loop stream = case stream of@@ -248,58 +327,15 @@ {-# INLINABLE embed #-} instance (MonadIO m, Functor f) => MonadIO (Stream f m) where- liftIO = Effect . liftM Return . liftIO+ liftIO = Effect . fmap Return . liftIO {-# INLINE liftIO #-} -instance (MonadBase b m, Functor f) => MonadBase b (Stream f m) where- liftBase = effect . fmap return . liftBase- {-#INLINE liftBase #-}--instance (MonadThrow m, Functor f) => MonadThrow (Stream f m) where- throwM = lift . throwM- {-#INLINE throwM #-}--instance (MonadCatch m, Functor f) => MonadCatch (Stream f m) where- catch str f = go str- where- go p = case p of- Step f -> Step (fmap go f)- Return r -> Return r- Effect m -> Effect (catch (do- p' <- m- return (go p'))- (\e -> return (f e)) )- {-#INLINABLE catch #-}- -instance (MonadResource m, Functor f) => MonadResource (Stream f m) where- liftResourceT = lift . liftResourceT- {-#INLINE liftResourceT #-}-- instance (Functor f, MonadReader r m) => MonadReader r (Stream f m) where ask = lift ask {-# INLINE ask #-} local f = hoist (local f) {-# INLINE local #-}---- instance (Functor f, MonadWriter w m) => MonadWriter w (Stream f m) where--- tell = lift . tell--- {-# INLINE tell #-}--- -- listen (FreeT m) = FreeT $ liftM concat' $ listen (fmap listen `liftM` m)--- where--- concat' (Pure x, w) = Pure (x, w)--- concat' (Free y, w) = Free $ fmap (second (w <>)) <$> y--- pass m = FreeT . pass' . runFreeT . hoist clean $ listen m--- where--- clean = pass . liftM (\x -> (x, const mempty))--- pass' = join . liftM g--- g (Pure ((x, f), w)) = tell (f w) >> return (Pure x)--- g (Free f) = return . Free . fmap (FreeT . pass' . runFreeT) $ f--- #if MIN_VERSION_mtl(2,1,1)--- writer w = lift (writer w)--- {-# INLINE writer #-}--- #endif---+ instance (Functor f, MonadState s m) => MonadState s (Stream f m) where get = lift get {-# INLINE get #-}@@ -314,36 +350,29 @@ throwError = lift . throwError {-# INLINE throwError #-} str `catchError` f = loop str where- loop str = case str of+ loop x = case x of Return r -> Return r- Effect m -> Effect $ liftM loop m `catchError` (return . f)- Step f -> Step (fmap loop f)+ Effect m -> Effect $ fmap loop m `catchError` (return . f)+ Step g -> Step (fmap loop g) {-# INLINABLE catchError #-} -bracketStream :: (Functor f, MonadResource m) =>- IO a -> (a -> IO ()) -> (a -> Stream f m b) -> Stream f m b-bracketStream alloc free inside = do- (key, seed) <- lift (allocate alloc free)- clean key (inside seed)- where- clean key = loop where- loop str = case str of- Return r -> Effect (release key >> return (Return r))- Effect m -> Effect (liftM loop m)- Step f -> Step (fmap loop f)-{-#INLINABLE bracketStream #-}-+{-| Map a stream to its church encoding; compare @Data.List.foldr@.+ 'destroyExposed' may be more efficient in some cases when+ applicable, but it is less safe. -{-| Map a stream directly to its church encoding; compare @Data.List.foldr@+ @+ destroy s construct eff done+ = eff . iterT (return . construct . fmap eff) . fmap done $ s+ @ -} destroy :: (Functor f, Monad m) => Stream f m r -> (f b -> b) -> (m b -> b) -> (r -> b) -> b-destroy stream0 construct effect done = loop stream0 where+destroy stream0 construct theEffect done = theEffect (loop stream0) where loop stream = case stream of- Return r -> done r- Effect m -> effect (liftM loop m)- Step fs -> construct (fmap loop fs)+ Return r -> return (done r)+ Effect m -> m >>= loop+ Step fs -> return (construct (fmap (theEffect . loop) fs)) {-# INLINABLE destroy #-} @@ -368,16 +397,20 @@ (f (Stream g m a) -> g (Stream g m a)) -> Stream f m a -> Stream g m a -- maps ->>> :t \f -> streamFold return effect (effect . liftM wrap . f)+>>> :t \f -> streamFold return effect (effect . fmap wrap . f) (Monad m, Functor f, Functor g) => (f (Stream g m a) -> m (g (Stream g m a))) -> Stream f m a -> Stream g m a -- mapped +@+ streamFold done eff construct+ = eff . iterT (return . construct . fmap eff) . fmap done+@ -} streamFold :: (Functor f, Monad m) => (r -> b) -> (m b -> b) -> (f b -> b) -> Stream f m r -> b-streamFold done effect construct stream = destroy stream construct effect done+streamFold done theEffect construct stream = destroy stream construct theEffect done {-#INLINE streamFold #-} {- | Reflect a church-encoded stream; cp. @GHC.Exts.build@@@ -397,7 +430,7 @@ > unfold inspect = id > Streaming.Prelude.unfoldr StreamingPrelude.next = id -}-inspect :: (Functor f, Monad m) =>+inspect :: Monad m => Stream f m r -> m (Either r (f (Stream f m r))) inspect = loop where loop stream = case stream of@@ -438,13 +471,13 @@ maps phi = loop where loop stream = case stream of Return r -> Return r- Effect m -> Effect (liftM loop m)+ Effect m -> Effect (fmap loop m) Step f -> Step (phi (fmap loop f)) {-# INLINABLE maps #-} -{- | Map layers of one functor to another with a transformation involving the base monad- @maps@ is more fundamental than @mapsM@, which is best understood as a convenience+{- | Map layers of one functor to another with a transformation involving the base monad.+ 'maps' is more fundamental than @mapsM@, which is best understood as a convenience for effecting this frequent composition: > mapsM phi = decompose . maps (Compose . phi)@@ -457,11 +490,58 @@ mapsM phi = loop where loop stream = case stream of Return r -> Return r- Effect m -> Effect (liftM loop m)- Step f -> Effect (liftM Step (phi (fmap loop f)))+ Effect m -> Effect (fmap loop m)+ Step f -> Effect (fmap Step (phi (fmap loop f))) {-# INLINABLE mapsM #-} +{- | Map layers of one functor to another with a transformation. Compare+ hoist, which has a similar effect on the 'monadic' parameter. +> mapsPost id = id+> mapsPost f . mapsPost g = mapsPost (f . g)+> mapsPost f = mapsPost f+++ @mapsPost@ is essentially the same as 'maps', but it imposes a 'Functor' constraint on+ its target functor rather than its source functor. It should be preferred if 'fmap'+ is cheaper for the target functor than for the source functor.+-}+mapsPost :: forall m f g r. (Monad m, Functor g)+ => (forall x. f x -> g x)+ -> Stream f m r -> Stream g m r+mapsPost phi = loop where+ loop :: Stream f m r -> Stream g m r+ loop stream = case stream of+ Return r -> Return r+ Effect m -> Effect (fmap loop m)+ Step f -> Step $ fmap loop $ phi f+{-# INLINABLE mapsPost #-}++{- | Map layers of one functor to another with a transformation involving the base monad.+ @mapsMPost@ is essentially the same as 'mapsM', but it imposes a 'Functor' constraint on+ its target functor rather than its source functor. It should be preferred if 'fmap'+ is cheaper for the target functor than for the source functor.++ @mapsPost@ is more fundamental than @mapsMPost@, which is best understood as a convenience+ for effecting this frequent composition:++> mapsMPost phi = decompose . mapsPost (Compose . phi)++ The streaming prelude exports the same function under the better name @mappedPost@,+ which overlaps with the lens libraries.++-}+mapsMPost :: forall m f g r. (Monad m, Functor g)+ => (forall x. f x -> m (g x))+ -> Stream f m r -> Stream g m r+mapsMPost phi = loop where+ loop :: Stream f m r -> Stream g m r+ loop stream = case stream of+ Return r -> Return r+ Effect m -> Effect (fmap loop m)+ Step f -> Effect $ fmap (Step . fmap loop) (phi f)+{-# INLINABLE mapsMPost #-}+ {-| Rearrange a succession of layers of the form @Compose m (f x)@. we could as well define @decompose@ by @mapsM@:@@ -483,7 +563,7 @@ decompose = loop where loop stream = case stream of Return r -> Return r- Effect m -> Effect (liftM loop m)+ Effect m -> Effect (fmap loop m) Step (Compose mstr) -> Effect $ do str <- mstr return (Step (fmap loop str))@@ -519,20 +599,21 @@ Return r -> return r Effect m -> lift m >>= go0 Step fstr -> do- f' <- fstr- go1 f'+ f' <- fstr+ go1 f' go1 f = case f of Return r -> return r Effect m -> lift m >>= go1 Step fstr -> do- sep- f' <- fstr- go1 f'+ _ <- sep+ f' <- fstr+ go1 f' {-# INLINABLE intercalates #-} {-| Specialized fold following the usage of @Control.Monad.Trans.Free@ > iterTM alg = streamFold return (join . lift)+> iterTM alg = iterT alg . hoist lift -} iterTM :: (Functor f, Monad m, MonadTrans t,@@ -544,6 +625,7 @@ {-| Specialized fold following the usage of @Control.Monad.Trans.Free@ > iterT alg = streamFold return join alg+> iterT alg = runIdentityT . iterTM (IdentityT . alg . fmap runIdentityT) -} iterT :: (Functor f, Monad m) => (f (m a) -> m a) -> Stream f m a -> m a@@ -557,8 +639,8 @@ concats = loop where loop stream = case stream of Return r -> return r- Effect m -> join $ lift (liftM loop m)- Step fs -> join (fmap loop fs)+ Effect m -> lift m >>= loop+ Step fs -> fs >>= loop {-# INLINE concats #-} {-| Split a succession of layers after some number, returning a streaming or@@ -590,7 +672,7 @@ | n <= 0 = Return stream | otherwise = case stream of Return r -> Return (Return r)- Effect m -> Effect (liftM (loop n) m)+ Effect m -> Effect (fmap (loop n) m) Step fs -> case n of 0 -> Return (Step fs) _ -> Step (fmap (loop (n-1)) fs)@@ -637,7 +719,7 @@ chunksOf n0 = loop where loop stream = case stream of Return r -> Return r- Effect m -> Effect (liftM loop m)+ Effect m -> Effect (fmap loop m) Step fs -> Step (Step (fmap (fmap loop . splitsAt (n0-1)) fs)) {-# INLINABLE chunksOf #-} @@ -681,45 +763,78 @@ cycles :: (Monad m, Functor f) => Stream f m () -> Stream f m r cycles = forever +-- | A less-efficient version of 'hoist' that works properly even when its+-- argument is not a monad morphism.+--+-- > hoistUnexposed = hoist . unexposed+hoistUnexposed :: (Monad m, Functor f)+ => (forall a. m a -> n a)+ -> Stream f m r -> Stream f n r+hoistUnexposed trans = loop where+ loop = Effect . trans . inspectC (return . Return) (return . Step . fmap loop)+{-# INLINABLE hoistUnexposed #-} +-- A version of 'inspect' that takes explicit continuations.+inspectC :: Monad m => (r -> m a) -> (f (Stream f m r) -> m a) -> Stream f m r -> m a+inspectC f g = loop where+ loop (Return r) = f r+ loop (Step x) = g x+ loop (Effect m) = m >>= loop+{-# INLINE inspectC #-} +-- | The same as 'hoist', but explicitly named to indicate that it+-- is not entirely safe. In particular, its argument must be a monad+-- morphism.+hoistExposed :: (Functor m, Functor f) => (forall b. m b -> n b) -> Stream f m a -> Stream f n a hoistExposed trans = loop where loop stream = case stream of Return r -> Return r- Effect m -> Effect (trans (liftM loop m))+ Effect m -> Effect (trans (fmap loop m)) Step f -> Step (fmap loop f)+{-# INLINABLE hoistExposed #-} +-- | The same as 'hoistExposed', but with a 'Functor' constraint on+-- the target rather than the source. This must be used only with+-- a monad morphism.+hoistExposedPost :: (Functor n, Functor f) => (forall b. m b -> n b) -> Stream f m a -> Stream f n a+hoistExposedPost trans = loop where+ loop stream = case stream of+ Return r -> Return r+ Effect m -> Effect (fmap loop (trans m))+ Step f -> Step (fmap loop f)+{-# INLINABLE hoistExposedPost #-}++{-# DEPRECATED mapsExposed "Use maps instead." #-} mapsExposed :: (Monad m, Functor f) => (forall x . f x -> g x) -> Stream f m r -> Stream g m r-mapsExposed phi = loop where- loop stream = case stream of- Return r -> Return r- Effect m -> Effect (liftM loop m)- Step f -> Step (phi (fmap loop f))+mapsExposed = maps {-# INLINABLE mapsExposed #-} -mapsMExposed phi = loop where- loop stream = case stream of- Return r -> Return r- Effect m -> Effect (liftM loop m)- Step f -> Effect (liftM Step (phi (fmap loop f)))+{-# DEPRECATED mapsMExposed "Use mapsM instead." #-}+mapsMExposed :: (Monad m, Functor f)+ => (forall x . f x -> m (g x)) -> Stream f m r -> Stream g m r+mapsMExposed = mapsM {-# INLINABLE mapsMExposed #-} --- Map a stream directly to its church encoding; compare @Data.List.foldr@--- It permits distinctions that should be hidden, as can be seen from--- e.g.------ isPure stream = destroy (const True) (const False) (const True)------ and similar nonsense. The crucial--- constraint is that the @m x -> x@ argument is an /Eilenberg-Moore algebra/.--- See Atkey "Reasoning about Stream Processing with Effects"+{-| Map a stream directly to its church encoding; compare @Data.List.foldr@+ It permits distinctions that should be hidden, as can be seen from+ e.g. + @isPure stream = destroyExposed (const True) (const False) (const True)@ -destroyExposed stream0 construct effect done = loop stream0 where+ and similar nonsense. The crucial+ constraint is that the @m x -> x@ argument is an /Eilenberg-Moore algebra/.+ See Atkey, "Reasoning about Stream Processing with Effects"++ When in doubt, use 'destroy' instead.+-}+destroyExposed+ :: (Functor f, Monad m) =>+ Stream f m r -> (f b -> b) -> (m b -> b) -> (r -> b) -> b+destroyExposed stream0 construct theEffect done = loop stream0 where loop stream = case stream of Return r -> done r- Effect m -> effect (liftM loop m)+ Effect m -> theEffect (fmap loop m) Step fs -> construct (fmap loop fs) {-# INLINABLE destroyExposed #-} @@ -793,31 +908,72 @@ yields fr = Step (fmap Return fr) {-#INLINE yields #-} +{-+Note that if the first stream produces Return, we don't inspect+(and potentially run effects from) the second stream. We used to+do that. Aside from being (arguably) a bit strange, this also runs+into a bit of trouble with MonadPlus laws. Most MonadPlus instances+try to satisfy either left distribution or left catch. Let's first+consider left distribution: -zipsWith :: (Monad m, Functor f, Functor g, Functor h)+(x <|> y) >>= k = (x >>= k) <|> (y >>= k)++[xy_1, xy_2, xy_3, ..., xy_o | r_xy] >>= k+=+[x_1, x_2, x_3, ..., x_m | r_x] >>= k+<|>+[y_1, y_2, y_3, ..., y_n | r_y] >>= k++x and y may have different lengths, and k may produce an utterly+arbitrary stream from each result, so left distribution seems+quite hopeless.++Now let's consider left catch:++zipsWith' liftA2 (return a) b = return a++To satisfy this, we can't run any effects from the second stream+if the first is finished.+-}++-- | Zip two streams together. The 'zipsWith'' function should generally+-- be preferred for efficiency.+zipsWith :: forall f g h m r. (Monad m, Functor h) => (forall x y . f x -> g y -> h (x,y)) -> Stream f m r -> Stream g m r -> Stream h m r-zipsWith phi s t = loop (s,t) where- loop (s1, s2) = Effect (go s1 s2)- go s1 s2 = do - e <- inspect s1- e' <- inspect s2- case (e,e') of- (Left r, _) -> return (Return r)- (_, Left r) -> return (Return r)- (Right fstr, Right gstr) -> return $ Step $ fmap loop (phi fstr gstr)-{-# INLINABLE zipsWith #-} +zipsWith phi = zipsWith' $ \xyp fx gy -> (\(x,y) -> xyp x y) <$> phi fx gy+{-# INLINABLE zipsWith #-}+-- Somewhat surprisingly, GHC is *much* more willing to specialize+-- zipsWith if it's defined in terms of zipsWith'. Fortunately, zipsWith'+-- seems like a better function anyway, so I guess that's not a big problem. +-- | Zip two streams together.+zipsWith' :: forall f g h m r. Monad m+ => (forall x y p . (x -> y -> p) -> f x -> g y -> h p)+ -> Stream f m r -> Stream g m r -> Stream h m r+zipsWith' phi = loop+ where+ loop :: Stream f m r -> Stream g m r -> Stream h m r+ loop s t = case s of+ Return r -> Return r+ Step fs -> case t of+ Return r -> Return r+ Step gs -> Step $ phi loop fs gs+ Effect n -> Effect $ fmap (loop s) n+ Effect m -> Effect $ fmap (flip loop t) m+{-# INLINABLE zipsWith' #-}+ zips :: (Monad m, Functor f, Functor g) => Stream f m r -> Stream g m r -> Stream (Compose f g) m r-zips = zipsWith go where- go fx gy = Compose (fmap (\x -> fmap (\y -> (x,y)) gy) fx)+zips = zipsWith' go where+ go p fx gy = Compose (fmap (\x -> fmap (\y -> p x y) gy) fx) {-# INLINE zips #-} {-| Interleave functor layers, with the effects of the first preceding- the effects of the second.+ the effects of the second. When the first stream runs out, any remaining+ effects in the second are ignored. > interleaves = zipsWith (liftA2 (,)) @@ -831,7 +987,7 @@ interleaves :: (Monad m, Applicative h) => Stream h m r -> Stream h m r -> Stream h m r-interleaves = zipsWith (liftA2 (,))+interleaves = zipsWith' liftA2 {-# INLINE interleaves #-} @@ -916,7 +1072,36 @@ return {-#INLINABLE unseparate #-} +-- | If 'Of' had a @Comonad@ instance, then we'd have+--+-- @copy = expand extend@+--+-- See 'expandPost' for a version that requires a @Functor g@+-- instance instead.+expand :: (Monad m, Functor f)+ => (forall a b. (g a -> b) -> f a -> h b)+ -> Stream f m r -> Stream g (Stream h m) r+expand ext = loop where+ loop (Return r) = Return r+ loop (Step f) = Effect $ Step $ ext (Return . Step) (fmap loop f)+ loop (Effect m) = Effect $ Effect $ fmap (Return . loop) m+{-# INLINABLE expand #-} +-- | If 'Of' had a @Comonad@ instance, then we'd have+--+-- @copy = expandPost extend@+--+-- See 'expand' for a version that requires a @Functor f@ instance+-- instead.+expandPost :: (Monad m, Functor g)+ => (forall a b. (g a -> b) -> f a -> h b)+ -> Stream f m r -> Stream g (Stream h m) r+expandPost ext = loop where+ loop (Return r) = Return r+ loop (Step f) = Effect $ Step $ ext (Return . Step . fmap loop) f+ loop (Effect m) = Effect $ Effect $ fmap (Return . loop) m+{-# INLINABLE expandPost #-}+ unzips :: (Monad m, Functor f, Functor g) => Stream (Compose f g) m r -> Stream f (Stream g m) r unzips str = destroyExposed@@ -944,24 +1129,23 @@ cleanL :: (Monad m, Functor f, Functor g) => Stream (Sum f g) m r -> Stream f m (Stream (Sum f g) m r)- cleanL = loop where- loop s = do+ cleanL = go where+ go s = do e <- lift $ inspect s case e of Left r -> return (return r)- Right (InL fstr) -> wrap (fmap loop fstr)+ Right (InL fstr) -> wrap (fmap go fstr) Right (InR gstr) -> return (wrap (InR gstr)) cleanR :: (Monad m, Functor f, Functor g) => Stream (Sum f g) m r -> Stream g m (Stream (Sum f g) m r)--- cleanR = fmap (maps switch) . cleanL . maps switch- cleanR = loop where- loop s = do+ cleanR = go where+ go s = do e <- lift $ inspect s case e of Left r -> return (return r) Right (InL fstr) -> return (wrap (InL fstr))- Right (InR gstr) -> wrap (fmap loop gstr)+ Right (InR gstr) -> wrap (fmap go gstr) {-#INLINABLE groups #-} -- groupInL :: (Monad m, Functor f, Functor g)@@ -1036,7 +1220,7 @@ So, for example, we might write >>> let justFour str = if length str == 4 then Just str else Nothing->>> let four = untilJust (liftM justFour getLine)+>>> let four = untilJust (fmap justFour getLine) >>> run four one<Enter> two<Enter>@@ -1052,7 +1236,9 @@ -} never :: (Monad m, Applicative f) => Stream f m r-never = let loop = Effect $ return $ Step $ pure loop in loop+-- The Monad m constraint should really be an Applicative one,+-- but we still support old versions of base.+never = let loop = Step $ pure (Effect (return loop)) in loop {-#INLINABLE never #-} @@ -1074,7 +1260,7 @@ -- then return s -- else case s of -- Return r -> Return (Return r)--- Effect m -> Effect (liftM loop m)+-- Effect m -> Effect (fmap loop m) -- Step f -> Step (fmap loop f) -- loop str -- where@@ -1099,7 +1285,7 @@ -- then loop (addUTCTime cutoff utc) stream -- else case stream of -- Return r -> Return r--- Effect m -> Effect $ liftM (loop final) m+-- Effect m -> Effect $ fmap (loop final) m -- Step fstr -> Step $ fmap (periods seconds) (cutoff_ final (Step fstr)) -- -- -- do@@ -1109,7 +1295,7 @@ -- -- then return s -- -- else case s of -- -- Return r -> Return (Return r)--- -- Effect m -> Effect (liftM sloop m)+-- -- Effect m -> Effect (fmap sloop m) -- -- Step f -> Step (fmap sloop f) -- -- Step (Step (fmap (fmap (periods seconds) . sloop) fstr)) -- -- str <- m@@ -1131,7 +1317,7 @@ -- then Return s -- else case s of -- Return r -> Return (Return r)--- Effect m -> Effect (liftM loop m)+-- Effect m -> Effect (fmap loop m) -- Step f -> Step (fmap loop f) -- loop str @@ -1150,7 +1336,7 @@ cutoff :: (Monad m, Functor f) => Int -> Stream f m r -> Stream f m (Maybe r) cutoff = loop where- loop 0 str = return Nothing+ loop 0 _ = return Nothing loop n str = do e <- lift $ inspect str case e of
src/Streaming/Prelude.hs view
@@ -47,9 +47,18 @@ > -------------------------------------------------------------------------------------------------------------------- > -}-{-# LANGUAGE RankNTypes, BangPatterns, DeriveDataTypeable, TypeFamilies,- DeriveFoldable, DeriveFunctor, DeriveTraversable, CPP, Trustworthy #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wall #-}+ module Streaming.Prelude ( -- * Types Of (..)@@ -61,7 +70,6 @@ , stdinLn , readLn , fromHandle- , readFile , iterate , iterateM , repeat@@ -72,7 +80,6 @@ , replicateM , enumFrom , enumFromThen- , seconds , unfoldr @@ -84,7 +91,6 @@ , mapM_ , print , toHandle- , writeFile , effects , erase , drained@@ -95,7 +101,9 @@ , map , mapM , maps+ , mapsPost , mapped+ , mappedPost , for , with , subst@@ -106,6 +114,7 @@ , sequence , filter , filterM+ , mapMaybeM , delay , intersperse , take@@ -231,12 +240,10 @@ -- * Basic Type , Stream- ) where import Streaming.Internal import Control.Monad hiding (filterM, mapM, mapM_, foldM, foldM_, replicateM, sequence)-import Data.Data ( Data, Typeable ) import Data.Functor.Identity import Data.Functor.Sum import Control.Monad.Trans@@ -244,8 +251,6 @@ import Data.Functor (Functor (..), (<$)) import qualified Prelude as Prelude-import Data.Foldable (Foldable)-import Data.Traversable (Traversable) import qualified Data.Foldable as Foldable import qualified Data.Sequence as Seq import Text.Read (readMaybe)@@ -254,7 +259,7 @@ , takeWhile, enumFrom, enumFromTo, enumFromThen, length , print, zipWith, zip, zipWith3, zip3, unzip, seq, show, read , readLn, sequence, concat, span, break, readFile, writeFile- , minimum, maximum, elem, notElem, intersperse, all, any, head+ , minimum, maximum, elem, notElem, all, any, head , last) import qualified GHC.IO.Exception as G@@ -262,66 +267,9 @@ import Foreign.C.Error (Errno(Errno), ePIPE) import Control.Exception (throwIO, try) import Data.Monoid (Monoid (mappend, mempty))-import Data.String (IsString (..)) import Control.Concurrent (threadDelay)-import Data.Time (getCurrentTime, diffUTCTime, picosecondsToDiffTime)-import Data.Functor.Classes import Data.Functor.Compose-import Control.Monad.Trans.Resource--import GHC.Magic-#if MIN_VERSION_base(4,8,0)-import Data.Bifunctor-#endif---- | A left-strict pair; the base functor for streams of individual elements.-data Of a b = !a :> b- deriving (Data, Eq, Foldable, Ord,- Read, Show, Traversable, Typeable)-infixr 5 :>--instance (Monoid a, Monoid b) => Monoid (Of a b) where- mempty = mempty :> mempty- {-#INLINE mempty #-}- mappend (m :> w) (m' :> w') = mappend m m' :> mappend w w'- {-#INLINE mappend #-}--instance Functor (Of a) where- fmap f (a :> x) = a :> f x- {-#INLINE fmap #-}- a <$ (b :> x) = b :> a- {-#INLINE (<$) #-}--#if MIN_VERSION_base(4,8,0)-instance Bifunctor Of where- bimap f g (a :> b) = f a :> g b- {-#INLINE bimap #-}- first f (a :> b) = f a :> b- {-#INLINE first #-}- second g (a :> b) = a :> g b- {-#INLINE second #-}-#endif--instance Monoid a => Applicative (Of a) where- pure x = mempty :> x- {-#INLINE pure #-}- m :> f <*> m' :> x = mappend m m' :> f x- {-#INLINE (<*>) #-}- m :> x *> m' :> y = mappend m m' :> y- {-#INLINE (*>) #-}- m :> x <* m' :> y = mappend m m' :> x- {-#INLINE (<*) #-}--instance Monoid a => Monad (Of a) where- return x = mempty :> x- {-#INLINE return #-}- m :> x >> m' :> y = mappend m m' :> y- {-#INLINE (>>) #-}- m :> x >>= f = let m' :> y = f x in mappend m m' :> y- {-#INLINE (>>=) #-}--instance (r ~ (), Monad m, f ~ Of Char) => IsString (Stream f m r) where- fromString = each+import Data.Functor.Of -- instance (Eq a) => Eq1 (Of a) where eq1 = (==) -- instance (Ord a) => Ord1 (Of a) where compare1 = compare@@ -388,10 +336,10 @@ -} fst' :: Of a b -> a-fst' (a :> b) = a+fst' (a :> _) = a {-#INLINE fst' #-} snd' :: Of a b -> b-snd' (a :> b) = b+snd' (_ :> b) = b {-#INLINE snd' #-} {-| Map a function over the first element of an @Of@ pair@@ -441,7 +389,7 @@ all_ :: Monad m => (a -> Bool) -> Stream (Of a) m r -> m Bool all_ thus = loop True where loop b str = case str of- Return r -> return b+ Return _ -> return b Effect m -> m >>= loop b Step (a :> rest) -> if thus a then loop True rest@@ -464,7 +412,7 @@ any_ :: Monad m => (a -> Bool) -> Stream (Of a) m r -> m Bool any_ thus = loop False where loop b str = case str of- Return r -> return b+ Return _ -> return b Effect m -> m >>= loop b Step (a :> rest) -> if thus a then return True@@ -485,11 +433,11 @@ break :: Monad m => (a -> Bool) -> Stream (Of a) m r -> Stream (Of a) m (Stream (Of a) m r)-break pred = loop where+break thePred = loop where loop str = case str of Return r -> Return (Return r)- Effect m -> Effect $ liftM loop m- Step (a :> rest) -> if (pred a)+ Effect m -> Effect $ fmap loop m+ Step (a :> rest) -> if (thePred a) then Return (Step (a :> rest)) else Step (a :> loop rest) {-# INLINABLE break #-}@@ -514,18 +462,18 @@ -} breakWhen :: Monad m => (x -> a -> x) -> x -> (x -> b) -> (b -> Bool) -> Stream (Of a) m r -> Stream (Of a) m (Stream (Of a) m r)-breakWhen step begin done pred = loop0 begin+breakWhen step begin done thePred = loop0 begin where loop0 x stream = case stream of Return r -> return (return r)- Effect mn -> Effect $ liftM (loop0 x) mn+ Effect mn -> Effect $ fmap (loop0 x) mn Step (a :> rest) -> loop a (step x a) rest loop a !x stream = do- if pred (done x)+ if thePred (done x) then return (yield a >> stream) else case stream of Return r -> yield a >> return (return r)- Effect mn -> Effect $ liftM (loop a x) mn+ Effect mn -> Effect $ fmap (loop a x) mn Step (a' :> rest) -> do yield a loop a' (step x a') rest@@ -571,7 +519,7 @@ chain f = loop where loop str = case str of Return r -> return r- Effect mn -> Effect (liftM loop mn)+ Effect mn -> Effect (fmap loop mn) Step (a :> rest) -> Effect $ do f a return (Step (a :> loop rest))@@ -683,8 +631,8 @@ > takeWhile' thus = S.drained . S.span thus -}-drained :: (Monad m, Monad (t m), Functor (t m), MonadTrans t) => t m (Stream (Of a) m r) -> t m r-drained = join . fmap (lift . effects)+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 #-} -- ---------------@@ -714,10 +662,10 @@ drop n str | n <= 0 = str drop n str = loop n str where loop 0 stream = stream- loop n stream = case stream of+ loop m stream = case stream of Return r -> Return r- Effect ma -> Effect (liftM (loop n) ma)- Step (a :> as) -> loop (n-1) as+ Effect ma -> Effect (fmap (loop m) ma)+ Step (_ :> as) -> loop (m-1) as {-# INLINABLE drop #-} -- ---------------@@ -738,11 +686,11 @@ -} dropWhile :: Monad m => (a -> Bool) -> Stream (Of a) m r -> Stream (Of a) m r-dropWhile pred = loop where+dropWhile thePred = loop where loop stream = case stream of Return r -> Return r- Effect ma -> Effect (liftM loop ma)- Step (a :> as) -> if pred a+ Effect ma -> Effect (fmap loop ma)+ Step (a :> as) -> if thePred a then loop as else Step (a :> as) {-# INLINABLE dropWhile #-}@@ -799,21 +747,21 @@ elem :: (Monad m, Eq a) => a -> Stream (Of a) m r -> m (Of Bool r) elem a' = loop False where- loop True str = liftM (True :>) (effects str)+ loop True str = fmap (True :>) (effects str) loop False str = case str of Return r -> return (False :> r) Effect m -> m >>= loop False Step (a:> rest) -> if a == a'- then liftM (True :>) (effects rest)+ then fmap (True :>) (effects rest) else loop False rest {-#INLINABLE elem #-} elem_ :: (Monad m, Eq a) => a -> Stream (Of a) m r -> m Bool elem_ a' = loop False where- loop True str = return True+ loop True _ = return True loop False str = case str of- Return r -> return False+ Return _ -> return False Effect m -> m >>= loop False Step (a:> rest) -> if a == a'@@ -875,8 +823,8 @@ erase = loop where loop str = case str of Return r -> Return r- Effect m -> Effect (liftM loop m)- Step (a:>rest) -> Step (Identity (loop rest))+ Effect m -> Effect (fmap loop m)+ Step (_:>rest) -> Step (Identity (loop rest)) {-# INLINABLE erase #-} -- ---------------@@ -885,13 +833,13 @@ -- | Skip elements of a stream that fail a predicate filter :: (Monad m) => (a -> Bool) -> Stream (Of a) m r -> Stream (Of a) m r-filter pred = loop where+filter thePred = loop where loop str = case str of Return r -> Return r- Effect m -> Effect (liftM loop m)- Step (a :> as) -> if pred a- then Step (a :> loop as)- else loop as+ Effect m -> Effect (fmap loop m)+ Step (a :> as) -> if thePred a+ then Step (a :> loop as)+ else loop as {-# INLINE filter #-} -- ~ 10% faster than INLINABLE in simple bench @@ -901,12 +849,12 @@ -- | Skip elements of a stream that fail a monadic test filterM :: (Monad m) => (a -> m Bool) -> Stream (Of a) m r -> Stream (Of a) m r-filterM pred = loop where+filterM thePred = loop where loop str = case str of Return r -> Return r- Effect m -> Effect $ liftM loop m+ Effect m -> Effect $ fmap loop m Step (a :> as) -> Effect $ do- bool <- pred a+ bool <- thePred a if bool then return $ Step (a :> loop as) else return $ loop as@@ -985,7 +933,7 @@ > Control.Foldl.purely fold :: Monad m => Fold a b -> Stream (Of a) m () -> m b -} fold_ :: Monad m => (x -> a -> x) -> x -> (x -> b) -> Stream (Of a) m r -> m b-fold_ step begin done = liftM (\(a:>rest) -> a) . fold step begin done+fold_ step begin done = fmap (\(a :> _) -> a) . fold step begin done {-#INLINE fold_ #-} {-| Strict fold of a 'Stream' of elements that preserves the return value.@@ -1037,7 +985,7 @@ foldM_ :: Monad m => (x -> a -> m x) -> m x -> (x -> m b) -> Stream (Of a) m r -> m b-foldM_ step begin done = liftM (\(a :> rest) -> a) . foldM step begin done+foldM_ step begin done = fmap (\(a :> _) -> a) . foldM step begin done {-#INLINE foldM_ #-} {-| Strict, monadic fold of the elements of a 'Stream (Of a)'@@ -1123,10 +1071,8 @@ for str0 act = loop str0 where loop str = case str of Return r -> Return r- Effect m -> Effect $ liftM loop m- Step (a :> rest) -> do- act a- loop rest+ Effect m -> Effect $ fmap loop m+ Step (a :> rest) -> act a *> loop rest {-# INLINABLE for #-} -- -| Group layers of any functor by comparisons on a preliminary annotation@@ -1145,11 +1091,11 @@ -- fmap loop (Step $ Compose (a :> fmap (span' (equals a)) p')) -- span' :: (Monad m, Functor f) => (a -> Bool) -> Stream (Compose (Of a) f) m r -- -> Stream (Compose (Of a) f) m (Stream (Compose (Of a) f) m r)--- span' pred = loop where+-- span' thePred = loop where -- loop str = case str of -- Return r -> Return (Return r)--- Effect m -> Effect $ liftM loop m--- Step s@(Compose (a :> rest)) -> case pred a of+-- Effect m -> Effect $ fmap loop m+-- Step s@(Compose (a :> rest)) -> case thePred a of -- True -> Step (Compose (a :> fmap loop rest)) -- False -> Return (Step s) -- {-# INLINABLE groupedBy #-}@@ -1204,20 +1150,20 @@ head_ :: Monad m => Stream (Of a) m r -> m (Maybe a) head_ str = case str of- Return r -> return Nothing- Effect m -> m >>= head_- Step (a :> rest) -> effects rest >> return (Just a)+ Return _ -> return Nothing+ Effect m -> m >>= head_+ Step (a :> _) -> return (Just a) {-#INLINABLE head_ #-} intersperse :: Monad m => a -> Stream (Of a) m r -> Stream (Of a) m r intersperse x str = case str of Return r -> Return r- Effect m -> Effect (liftM (intersperse x) m)+ Effect m -> Effect (fmap (intersperse x) m) Step (a :> rest) -> loop a rest where- loop !a str = case str of+ loop !a theStr = case theStr of Return r -> Step (a :> Return r)- Effect m -> Effect (liftM (loop a) m)+ Effect m -> Effect (fmap (loop a) m) Step (b :> rest) -> Step (a :> Step (x :> loop b rest)) {-#INLINABLE intersperse #-} @@ -1250,11 +1196,11 @@ last :: Monad m => Stream (Of a) m r -> m (Of (Maybe a) r) last = loop Nothing_ where- loop m str = case str of- Return r -> case m of+ loop mb str = case str of+ Return r -> case mb of Nothing_ -> return (Nothing :> r) Just_ a -> return (Just a :> r)- Effect m -> m >>= last+ Effect m -> m >>= loop mb Step (a :> rest) -> loop (Just_ a) rest {-#INLINABLE last #-} @@ -1262,14 +1208,15 @@ last_ :: Monad m => Stream (Of a) m r -> m (Maybe a) last_ = loop Nothing_ where- loop m str = case str of- Return r -> case m of+ loop mb str = case str of+ Return _ -> case mb of Nothing_ -> return Nothing Just_ a -> return (Just a)- Effect m -> m >>= last_- Step (a :> rest) -> loop (Just_ a) rest+ Effect m -> m >>= loop mb+ Step (a :> rest) -> loop (Just_ a) rest {-#INLINABLE last_ #-} + -- --------------- -- length -- ---------------@@ -1313,7 +1260,7 @@ -- loop where -- -- loop stream = case stream of -- Return r -> Return r- -- Effect m -> Effect (liftM loop m)+ -- Effect m -> Effect (fmap loop m) -- Step (a :> as) -> Step (f a :> loop as) {-# INLINABLE map #-} -- {-# NOINLINE [1] map #-}@@ -1336,7 +1283,7 @@ mapM f = loop where loop str = case str of Return r -> Return r- Effect m -> Effect (liftM loop m)+ Effect m -> Effect (fmap loop m) Step (a :> as) -> Effect $ do a' <- f a return (Step (a' :> loop as) )@@ -1363,11 +1310,9 @@ mapM_ :: Monad m => (a -> m b) -> Stream (Of a) m r -> m r mapM_ f = loop where loop str = case str of- Return r -> return r- Effect m -> m >>= loop- Step (a :> as) -> do- f a- loop as+ Return r -> return r+ Effect m -> m >>= loop+ Step (a :> as) -> f a *> loop as {-# INLINABLE mapM_ #-} @@ -1386,8 +1331,8 @@ > mapped return = id > maps f . maps g = maps (f . g) > mapped f . mapped g = mapped (f <=< g)-> maps f . mapped g = mapped (liftM f . g)-> mapped f . maps g = mapped (f <=< liftM g)+> maps f . mapped g = mapped (fmap f . g)+> mapped f . maps g = mapped (f <=< fmap g) @maps@ is more fundamental than @mapped@, which is best understood as a convenience for effecting this frequent composition:@@ -1401,7 +1346,15 @@ mapped = mapsM {-#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+ functor is cheaper. +-}+mappedPost :: (Monad m, Functor g) => (forall x . f x -> m (g x)) -> Stream f m r -> Stream g m r+mappedPost = mapsMPost+{-# INLINE mappedPost #-}+ {-| Fold streamed items into their monoidal sum >>> S.mconcat $ S.take 2 $ S.map (Data.Monoid.Last . Just) (S.stdinLn)@@ -1458,8 +1411,8 @@ Similarly: -> IOStreams.unfoldM (liftM (either (const Nothing) Just) . next) :: Stream (Of a) IO b -> IO (InputStream a)-> Conduit.unfoldM (liftM (either (const Nothing) Just) . next) :: Stream (Of a) m r -> Source a m r+> IOStreams.unfoldM (fmap (either (const Nothing) Just) . next) :: Stream (Of a) IO b -> IO (InputStream a)+> Conduit.unfoldM (fmap (either (const Nothing) Just) . next) :: Stream (Of a) m r -> Source a m r But see 'uncons', which is better fitted to these @unfoldM@s -}@@ -1478,21 +1431,21 @@ notElem :: (Monad m, Eq a) => a -> Stream (Of a) m r -> m (Of Bool r) notElem a' = loop True where- loop False str = liftM (False :>) (effects str)+ loop False str = fmap (False :>) (effects str) loop True str = case str of Return r -> return (True:> r) Effect m -> m >>= loop True Step (a:> rest) -> if a == a'- then liftM (False :>) (effects rest)+ then fmap (False :>) (effects rest) else loop True rest {-#INLINABLE notElem #-} notElem_ :: (Monad m, Eq a) => a -> Stream (Of a) m r -> m Bool notElem_ a' = loop True where- loop False str = return False+ loop False _ = return False loop True str = case str of- Return r -> return True+ Return _ -> return True Effect m -> m >>= loop True Step (a:> rest) -> if a == a'@@ -1509,7 +1462,7 @@ partition thus = loop where loop str = case str of Return r -> Return r- Effect m -> Effect (liftM loop (lift m))+ Effect m -> Effect (fmap loop (lift m)) Step (a :> rest) -> if thus a then Step (a :> loop rest) else Effect $ do@@ -1541,7 +1494,7 @@ partitionEithers = loop where loop str = case str of Return r -> Return r- Effect m -> Effect (liftM loop (lift m))+ Effect m -> Effect (fmap loop (lift m)) Step (Left a :> rest) -> Step (a :> loop rest) Step (Right b :> rest) -> Effect $ do yield b@@ -1621,7 +1574,7 @@ -- | Repeat an element several times. replicate :: Monad m => Int -> a -> Stream (Of a) m ()-replicate n a | n <= 0 = return ()+replicate n _ | n <= 0 = return () replicate n a = loop n where loop 0 = Return () loop m = Effect (return (Step (a :> loop (m-1))))@@ -1635,12 +1588,12 @@ -} replicateM :: Monad m => Int -> m a -> Stream (Of a) m ()-replicateM n ma | n <= 0 = return ()+replicateM n _ | n <= 0 = return () replicateM n ma = loop n where loop 0 = Return ()- loop n = Effect $ do+ loop m = Effect $ do a <- ma- return (Step (a :> loop (n-1)))+ return (Step (a :> loop (m-1))) {-# INLINABLE replicateM #-} {-| Read an @IORef (Maybe a)@ or a similar device until it reads @Nothing@.@@ -1684,7 +1637,7 @@ loop !acc stream = do case stream of Return r -> Return r- Effect m -> Effect (liftM (loop acc) m)+ Effect m -> Effect (fmap (loop acc) m) Step (a :> rest) -> let !acc' = step acc a in Step (done acc' :> loop acc' rest)@@ -1745,7 +1698,7 @@ loop !m !x stream = do case stream of Return r -> return r- Effect mn -> Effect $ liftM (loop m x) mn+ Effect mn -> Effect $ fmap (loop m x) mn Step (a :> rest) -> do case m of Nothing' -> do@@ -1783,22 +1736,6 @@ -} -seconds :: Stream (Of Double) IO r-seconds = do- e <- lift $ next preseconds- case e of- Left r -> return r- Right (t, rest) -> do- yield 0- map (subtract t) rest- where- preseconds :: Stream (Of Double) IO r- preseconds = do- utc <- liftIO getCurrentTime- map ((/1000000000) . nice utc) (repeatM getCurrentTime)- where- nice u u' = fromIntegral $ truncate (1000000000 * diffUTCTime u' u)- -- --------------- -- sequence -- ---------------@@ -1817,7 +1754,7 @@ sequence = loop where loop stream = case stream of Return r -> Return r- Effect m -> Effect $ liftM loop m+ Effect m -> Effect $ fmap loop m Step (ma :> rest) -> Effect $ do a <- ma return (Step (a :> loop rest))@@ -1870,11 +1807,11 @@ -- | Stream elements until one fails the condition, return the rest. span :: Monad m => (a -> Bool) -> Stream (Of a) m r -> Stream (Of a) m (Stream (Of a) m r)-span pred = loop where+span thePred = loop where loop str = case str of Return r -> Return (Return r)- Effect m -> Effect $ liftM loop m- Step (a :> rest) -> if pred a+ Effect m -> Effect $ fmap loop m+ Step (a :> rest) -> if thePred a then Step (a :> loop rest) else Return (Step (a :> rest)) {-# INLINABLE span #-}@@ -1894,7 +1831,7 @@ split t = loop where loop stream = case stream of Return r -> Return r- Effect m -> Effect (liftM loop m)+ Effect m -> Effect (fmap loop m) Step (a :> rest) -> if a /= t then Step (fmap loop (yield a >> break (== t) rest))@@ -1902,9 +1839,9 @@ {-#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--- @Streaming@ module, but since this module is imported qualified, it can--- usurp a Prelude name. It specializes to:+ effectful pair. This function is the same as the 'splitsAt' exported by the+ @Streaming@ module, but since this module is imported qualified, it can+ usurp a Prelude name. It specializes to: > splitAt :: (Monad m, Functor f) => Int -> Stream (Of a) m r -> Stream (Of a) m (Stream (Of a) m r) @@ -1929,7 +1866,7 @@ subst f s = loop s where loop str = case str of Return r -> Return r- Effect m -> Effect (liftM loop m)+ Effect m -> Effect (fmap loop m) Step (a :> rest) -> Step (loop rest <$ f a) {-#INLINABLE subst #-} -- ---------------@@ -1954,13 +1891,14 @@ -} take :: (Monad m, Functor f) => Int -> Stream f m r -> Stream f m ()-take n0 str | n0 <= 0 = return ()+take n0 _ | n0 <= 0 = return () take n0 str = loop n0 str where- loop 0 p = return ()+ loop 0 _ = return () loop n p =- case p of Step fas -> Step (fmap (loop (n-1)) fas)- Effect m -> Effect (liftM (loop n) m)- Return r -> Return ()+ case p of+ Step fas -> Step (fmap (loop (n-1)) fas)+ Effect m -> Effect (fmap (loop n) m)+ Return _ -> Return () {-# INLINABLE take #-} -- ---------------@@ -1983,22 +1921,22 @@ -} takeWhile :: Monad m => (a -> Bool) -> Stream (Of a) m r -> Stream (Of a) m ()-takeWhile pred = loop where+takeWhile thePred = loop where loop str = case str of- Step (a :> as) -> when (pred a) (Step (a :> loop as))- Effect m -> Effect (liftM loop m)- Return r -> Return ()+ Step (a :> as) -> when (thePred a) (Step (a :> loop as))+ Effect m -> Effect (fmap loop m)+ Return _ -> Return () {-# INLINE takeWhile #-} {-| Like 'takeWhile', but takes a monadic predicate. -} takeWhileM :: Monad m => (a -> m Bool) -> Stream (Of a) m r -> Stream (Of a) m ()-takeWhileM pred = loop where+takeWhileM thePred = loop where loop str = case str of Step (a :> as) -> do- b <- lift (pred a)+ b <- lift (thePred a) when b (Step (a :> loop as))- Effect m -> Effect (liftM loop m)- Return r -> Return ()+ Effect m -> Effect (fmap loop m)+ Return _ -> Return () {-# INLINE takeWhileM #-} @@ -2046,10 +1984,10 @@ > Conduit.unfoldM uncons :: Stream (Of a) m r -> Conduit.Source m a -}-uncons :: Monad m => Stream (Of a) m () -> m (Maybe (a, Stream (Of a) m ()))+uncons :: Monad m => Stream (Of a) m r -> m (Maybe (a, Stream (Of a) m r)) uncons = loop where loop stream = case stream of- Return () -> return Nothing+ Return _ -> return Nothing Effect m -> m >>= loop Step (a :> rest) -> return (Just (a,rest)) {-# INLINABLE uncons #-}@@ -2127,7 +2065,7 @@ with s f = loop s where loop str = case str of Return r -> Return r- Effect m -> Effect (liftM loop m)+ Effect m -> Effect (fmap loop m) Step (a :> rest) -> Step (loop rest <$ f a) {-#INLINABLE with #-} @@ -2177,10 +2115,10 @@ where loop str0 str1 = case str0 of Return r -> Return r- Effect m -> Effect $ liftM (\str -> loop str str1) m+ Effect m -> Effect $ fmap (\str -> loop str str1) m Step (a :> rest0) -> case str1 of Return r -> Return r- Effect m -> Effect $ liftM (loop str0) m+ Effect m -> Effect $ fmap (loop str0) m Step (b :> rest1) -> Step (f a b :>loop rest0 rest1) {-# INLINABLE zipWith #-} @@ -2264,11 +2202,14 @@ -} readLn :: (MonadIO m, Read a) => Stream (Of a) m ()-readLn = do- str <- liftIO getLine- case readMaybe str of- Nothing -> readLn- Just n -> yield n >> readLn+readLn = loop where + loop = do+ eof <- liftIO IO.isEOF+ unless eof $ do+ str <- liftIO getLine+ case readMaybe str of+ Nothing -> readLn+ Just n -> yield n >> loop {-# INLINABLE readLn #-} @@ -2374,44 +2315,7 @@ stdoutLn' :: MonadIO m => Stream (Of String) m r -> m r stdoutLn' = toHandle IO.stdout -{-| Read the lines of a file as Haskell 'String's ->>> runResourceT $ S.writeFile "lines.txt" $ S.take 2 S.stdinLn-hello<Enter>-world<Enter>->>> runResourceT $ S.print $ S.readFile "lines.txt"-"hello"-"world"-- 'runResourceT', as it is used here, means something like 'closing_all_handles'.- It makes it possible to write convenient, fairly sensible versions of- 'readFile', 'writeFile' and 'appendFile'. @IO.withFile IO.ReadMode ...@- is more complicated but is generally to be preferred. Its use is explained- <https://www.fpcomplete.com/user/snoyberg/library-documentation/resourcet here>.---}--readFile :: MonadResource m => FilePath -> Stream (Of String) m ()-readFile f = bracketStream (IO.openFile f IO.ReadMode) (IO.hClose) fromHandle--{-| Write a series of strings as lines to a file. The handle is- managed with 'ResourceT' (see the remarks on 'readFile'):-->>> runResourceT $ S.writeFile "lines.txt" $ S.take 2 S.stdinLn-hello<Enter>-world<Enter>->>> runResourceT $ S.stdoutLn $ S.readFile "lines.txt"-hello-world---}-writeFile :: MonadResource m => FilePath -> Stream (Of String) m r -> m r-writeFile f str = do- (key, handle) <- allocate (IO.openFile f IO.WriteMode) (IO.hClose)- r <- toHandle handle str- release key- return r- -- -- * Producers -- -- $producers -- stdinLn --@@ -2662,6 +2566,18 @@ >>> (S.toList . mapped S.toList . chunksOf 4) $ (S.toList . mapped S.toList . chunksOf 3) $ S.copy $ (S.toList . mapped S.toList . chunksOf 2) $ S.copy $ each [1..12] [[1,2,3,4],[5,6,7,8],[9,10,11,12]] :> ([[1,2,3],[4,5,6],[7,8,9],[10,11,12]] :> ([[1,2],[3,4],[5,6],[7,8],[9,10],[11,12]] :> ())) ++@copy@ can be considered a special case of 'expand':++@+ copy = 'expand' $ \p (a :> as) -> a :> p (a :> as)+@++If 'Of' were an instance of 'Control.Comonad.Comonad', then one could write++@+ copy = 'expand' extend+@ -} copy :: Monad m =>@@ -2669,7 +2585,7 @@ copy = Effect . return . loop where loop str = case str of Return r -> Return r- Effect m -> Effect (liftM loop (lift m))+ Effect m -> Effect (fmap loop (lift m)) Step (a :> rest) -> Effect (Step (a :> Return (Step (a :> loop rest)))) {-#INLINABLE copy#-} @@ -2725,12 +2641,18 @@ >>> S.toList $ S.toList $ S.unzip (S.each xs) ["1","2","3","4","5"] :> ([1,2,3,4,5] :> ()) +'unzip' can be considered a special case of either 'unzips' or 'expand':++@+ unzip = 'unzips' . 'maps' (\((a,b) :> x) -> Compose (a :> b :> x))+ unzip = 'expand' $ \p ((a,b) :> abs) -> b :> p (a :> abs)+@ -} unzip :: Monad m => Stream (Of (a,b)) m r -> Stream (Of a) (Stream (Of b) m) r unzip = loop where loop str = case str of Return r -> Return r- Effect m -> Effect (liftM loop (lift m))+ Effect m -> Effect (fmap loop (lift m)) Step ((a,b):> rest) -> Step (a :> Effect (Step (b :> Return (loop rest)))) {-#INLINABLE unzip #-} @@ -2749,7 +2671,7 @@ catMaybes = loop where loop stream = case stream of Return r -> Return r- Effect m -> Effect (liftM loop m)+ Effect m -> Effect (fmap loop m) Step (ma :> snext) -> case ma of Nothing -> loop snext Just a -> Step (a :> loop snext)@@ -2764,7 +2686,7 @@ mapMaybe phi = loop where loop stream = case stream of Return r -> Return r- Effect m -> Effect (liftM loop m)+ Effect m -> Effect (fmap loop m) Step (a :> snext) -> case phi a of Nothing -> loop snext Just b -> Step (b :> loop snext)@@ -2798,9 +2720,22 @@ setup 0 !sequ str = do yield sequ window (Seq.drop 1 sequ) str - setup n sequ str = do + setup m sequ str = do e <- lift $ next str case e of Left r -> yield sequ >> return r- Right (x,rest) -> setup (n-1) (sequ Seq.|> x) rest+ Right (x,rest) -> setup (m-1) (sequ Seq.|> x) rest {-#INLINABLE slidingWindow #-}++-- | Map monadically over a stream, producing a new stream+-- only containing the 'Just' values.+mapMaybeM :: Monad m => (a -> m (Maybe b)) -> Stream (Of a) m r -> Stream (Of b) m r+mapMaybeM phi = loop where+ loop stream = case stream of+ Return r -> Return r+ Effect m -> Effect (fmap loop m)+ Step (a :> snext) -> Effect $ do+ flip fmap (phi a) $ \x -> case x of+ Nothing -> loop snext+ Just b -> Step (b :> loop snext)+{-#INLINABLE mapMaybeM #-}
streaming.cabal view
@@ -1,5 +1,5 @@ name: streaming-version: 0.1.4.5+version: 0.2.0.0 cabal-version: >=1.10 build-type: Simple synopsis: an elementary streaming prelude and general stream type.@@ -186,45 +186,41 @@ license: BSD3 license-file: LICENSE author: michaelt-maintainer: what_is_it_to_do_anything@yahoo.com+maintainer: andrew.thaddeus@gmail.com, what_is_it_to_do_anything@yahoo.com stability: Experimental-homepage: https://github.com/michaelt/streaming-bug-reports: https://github.com/michaelt/streaming/issues+homepage: https://github.com/haskell-streaming/streaming+bug-reports: https://github.com/haskell-streaming/streaming/issues category: Data, Pipes, Streaming extra-source-files: README.md source-repository head type: git- location: https://github.com/michaelt/streaming-+ location: https://github.com/haskell-streaming/streaming library- exposed-modules: Streaming,- Streaming.Prelude,- Streaming.Internal-- -- other-modules:- other-extensions: RankNTypes, CPP,- StandaloneDeriving, FlexibleContexts,- DeriveDataTypeable, DeriveFoldable,- DeriveFunctor, DeriveTraversable,- UndecidableInstances-- build-depends: base >=4.6 && <5- , mtl >=2.1 && <2.3- , mmorph >=1.0 && <1.1- , transformers >=0.4 && <0.6- , transformers-base < 0.5- , resourcet > 1.1.0 && < 1.2- , exceptions > 0.5 && < 0.9- , monad-control >=0.3.1 && <1.1- , time- , ghc-prim- , containers-+ exposed-modules:+ Streaming+ , Streaming.Prelude+ , Streaming.Internal+ , Data.Functor.Of+ other-extensions:+ RankNTypes+ , CPP+ , StandaloneDeriving+ , FlexibleContexts+ , DeriveDataTypeable+ , DeriveFoldable+ , DeriveFunctor+ , DeriveTraversable+ , UndecidableInstances+ build-depends:+ base >=4.8 && <5+ , mtl >=2.1 && <2.3+ , mmorph >=1.0 && <1.2+ , transformers >=0.5 && <0.6+ , transformers-base < 0.5+ , exceptions > 0.5 && < 0.9+ , ghc-prim+ , containers hs-source-dirs: src default-language: Haskell2010----