11d8d6d · streamly · git.iko.soy

git.iko.soy/streamly

Fix foldable/traversable instances

1) Define the instances manually instead of deriving. Deriving picks up incorrect implementations of methods that have been redefined in the newtypes. 2) Fix the Traversable instance. 3) Define the instances only for Serial stream types. Other streams cannot be instantiated for Foldable monads. 4) Add test cases 5) add benchmarks

commit11d8d6dc669750198bec08b5ec0bc0d8a73f0ca1 authorHarendra Kumar <harendra.kumar@gmail.com> dateMon 19 Nov 2018, 08:50 (8 years ago) parent9e114ff

13 files changed+102−54

compare with master

unifiedsplit

benchmark/Linear.hs+12−1 benchmark/LinearOps.hs+14−1 src/Streamly/Prelude.hs+2−4 src/Streamly/Streams/Ahead.hs+1−2 src/Streamly/Streams/Async.hs+2−3 src/Streamly/Streams/Instances.hs+19 src/Streamly/Streams/Parallel.hs+1−2 src/Streamly/Streams/Prelude.hs+16−3 src/Streamly/Streams/Serial.hs+11−4 src/Streamly/Streams/StreamD.hs−15 src/Streamly/Streams/StreamK.hs−15 src/Streamly/Streams/Zip.hs+7−3 test/PureStreams.hs+17−1

benchmark/Linear.hs+12−1

@@ -44,6 +44,13 @@ benchPure name src f = bench name $ nfIO $ randomRIO (1,1) >>= return . f . src

4444benchPureSink :: NFData b => String -> (SerialT Identity Int -> b) -> Benchmark

4545benchPureSink name f = benchPure name Ops.sourceUnfoldr f

4646

47+{-# INLINE benchPureSinkIO #-}

48+benchPureSinkIO

49+ :: NFData b

50+ => String -> (SerialT Identity Int -> IO b) -> Benchmark

51+benchPureSinkIO name f =

52+ bench name $ nfIO $ randomRIO (1, 1) >>= f . Ops.sourceUnfoldr

53+

4754{-# INLINE benchPureSrc #-}

4855benchPureSrc :: String -> (Int -> SerialT Identity a) -> Benchmark

4956benchPureSrc name src = benchPure name src (runIdentity . runStream)

@@ -53,7 +60,8 @@ main =

5360 defaultMain

5461 [ bgroup "serially"

5562 [ bgroup "pure"

56− [ benchPureSink "eqBy" Ops.eqBy

63+ [ benchPureSink "id" id

64+ , benchPureSink "eqBy" Ops.eqBy

5765 , benchPureSink "==" Ops.eqInstance

5866 , benchPureSink "/=" Ops.eqInstanceNotEq

5967 , benchPureSink "cmpBy" Ops.cmpBy

@@ -67,6 +75,9 @@ main =

6775 , benchPureSink "showsPrec" Ops.showInstance

6876 , benchPure "showsPrecList" (\n -> S.fromList [1..n :: Int])

6977 Ops.showInstanceList

78+ , benchPureSink "foldable-foldl'" Ops.foldableFoldl'

79+ , benchPureSink "foldable-sum" Ops.foldableSum

80+ , benchPureSinkIO "traversable-mapM" Ops.traversableMapM

7081 ]

7182 , bgroup "generation"

7283 [ -- Most basic, barely stream continuations running

benchmark/LinearOps.hs+14−1

@@ -17,8 +17,9 @@ import Data.Maybe (fromJust)

1717import Prelude

1818 (Monad, Int, (+), ($), (.), return, fmap, even, (>), (<=), (==), (<=),

1919 subtract, undefined, Maybe(..), odd, Bool, not, (>>=), mapM_, curry,

20− maxBound, div)

20+ maxBound, div, IO)

2121import qualified Prelude as P

22+import qualified Data.Foldable as F

2223import qualified GHC.Exts as GHC

2324

2425import qualified Streamly as S

@@ -451,3 +452,15 @@ readInstance src =

451452 in case r of

452453 [(x,"")] -> src S.<> x

453454 _ -> P.error "readInstance: no parse"

455+

456+{-# INLINE foldableFoldl' #-}

457+foldableFoldl' :: Stream Identity Int -> Int

458+foldableFoldl' = F.foldl' (+) 0

459+

460+{-# INLINE foldableSum #-}

461+foldableSum :: Stream Identity Int -> Int

462+foldableSum = P.sum

463+

464+{-# INLINE traversableMapM #-}

465+traversableMapM :: Stream Identity Int -> IO (Stream Identity Int)

466+traversableMapM = P.mapM return

src/Streamly/Prelude.hs+2−4

@@ -508,7 +508,7 @@ fromHandle h = fromStream go

508508-- @since 0.2.0

509509{-# INLINE foldrM #-}

510510foldrM :: Monad m => (a -> b -> m b) -> b -> SerialT m a -> m b

511−foldrM step acc m = S.foldrM step acc $ toStreamS m

511+foldrM = P.foldrM

512512

513513-- | Lazy right associative fold. For example, to fold a stream into a list:

514514--

@@ -520,9 +520,7 @@ foldrM step acc m = S.foldrM step acc $ toStreamS m

520520-- @since 0.1.0

521521{-# INLINE foldr #-}

522522foldr :: Monad m => (a -> b -> b) -> b -> SerialT m a -> m b

523−-- XXX somehow this definition does not perform well, need to investigate

524−-- foldr step acc m = S.foldr step acc $ S.fromStreamK (toStream m)

525−foldr f = foldrM (\a b -> return (f a b))

523+foldr = P.foldr

526524

527525-- | Right fold, for non-empty streams, using first element as the starting

528526-- value. Returns 'Nothing' if the stream is empty.

src/Streamly/Streams/Ahead.hs+1−2

@@ -1,6 +1,5 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DeriveTraversable #-}

43{-# LANGUAGE FlexibleContexts #-}

54{-# LANGUAGE FlexibleInstances #-}

65{-# LANGUAGE GeneralizedNewtypeDeriving#-}

@@ -620,7 +619,7 @@ consMAhead m r = K.yieldM m `aheadS` r

620619--

621620-- @since 0.3.0

622621newtype AheadT m a = AheadT {getAheadT :: Stream m a}

623− deriving (MonadTrans, Foldable, Traversable)

622+ deriving (MonadTrans)

624623

625624-- | A serial IO stream of elements of type @a@ with concurrent lookahead. See

626625-- 'AheadT' documentation for more details.

src/Streamly/Streams/Async.hs+2−3

@@ -1,6 +1,5 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DeriveTraversable #-}

43{-# LANGUAGE FlexibleContexts #-}

54{-# LANGUAGE FlexibleInstances #-}

65{-# LANGUAGE GeneralizedNewtypeDeriving#-}

@@ -636,7 +635,7 @@ consMAsync m r = K.yieldM m `asyncS` r

636635--

637636-- @since 0.1.0

638637newtype AsyncT m a = AsyncT {getAsyncT :: Stream m a}

639− deriving (MonadTrans, Foldable, Traversable)

638+ deriving (MonadTrans)

640639

641640-- | A demand driven left biased parallely composing IO stream of elements of

642641-- type @a@. See 'AsyncT' documentation for more details.

@@ -763,7 +762,7 @@ wAsync m1 m2 = fromStream $ Stream $ \st stp sng yld ->

763762--

764763-- @since 0.2.0

765764newtype WAsyncT m a = WAsyncT {getWAsyncT :: Stream m a}

766− deriving (MonadTrans, Foldable, Traversable)

765+ deriving (MonadTrans)

767766

768767-- | A round robin parallely composing IO stream of elements of type @a@.

769768-- See 'WAsyncT' documentation for more details.

src/Streamly/Streams/Instances.hs+19

@@ -101,3 +101,22 @@ instance NFData a => NFData (STREAM Identity a) where { rnf = rnf1 }; \

101101instance NFData1 (STREAM Identity) where { \

102102 {-# INLINE liftRnf #-}; \

103103 liftRnf r = runIdentity . P.foldl' (\_ x -> r x) () }

104+

105+-------------------------------------------------------------------------------

106+-- Foldable

107+-------------------------------------------------------------------------------

108+

109+#define FOLDABLE_INSTANCE(STREAM) \

110+instance (Foldable m, Monad m) => Foldable (STREAM m) where { \

111+ {-# INLINE foldMap #-}; \

112+ foldMap f = fold . P.foldr mappend mempty . fmap f }

113+

114+-------------------------------------------------------------------------------

115+-- Traversable

116+-------------------------------------------------------------------------------

117+

118+#define TRAVERSABLE_INSTANCE(STREAM) \

119+instance Traversable (STREAM Identity) where { \

120+ {-# INLINE traverse #-}; \

121+ traverse f s = runIdentity $ P.foldr consA (pure mempty) s \

122+ where { consA x ys = liftA2 (K.cons) (f x) ys }}

src/Streamly/Streams/Parallel.hs+1−2

@@ -1,6 +1,5 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DeriveTraversable #-}

43{-# LANGUAGE FlexibleContexts #-}

54{-# LANGUAGE FlexibleInstances #-}

65{-# LANGUAGE GeneralizedNewtypeDeriving#-}

@@ -326,7 +325,7 @@ x |&. f = f |$. x

326325--

327326-- @since 0.1.0

328327newtype ParallelT m a = ParallelT {getParallelT :: Stream m a}

329− deriving (MonadTrans, Foldable, Traversable)

328+ deriving (MonadTrans)

330329

331330-- | A parallely composing IO stream of elements of type @a@.

332331-- See 'ParallelT' documentation for more details.

src/Streamly/Streams/Prelude.hs+16−3

@@ -27,6 +27,8 @@ module Streamly.Streams.Prelude

2727 , toList

2828

2929 -- * Fold operations

30+ , foldrM

31+ , foldr

3032 , foldl'

3133

3234 -- * Zip style operations

@@ -40,6 +42,9 @@ module Streamly.Streams.Prelude

4042 )

4143where

4244

45+import Prelude hiding (foldr)

46+import qualified Prelude

47+

4348#ifdef USE_STREAMK_ONLY

4449import qualified Streamly.Streams.StreamK as S

4550#else

@@ -89,6 +94,14 @@ toList m = S.toList $ toStreamS m

8994-- Folds

9095------------------------------------------------------------------------------

9196

97+{-# INLINE foldrM #-}

98+foldrM :: (Monad m, IsStream t) => (a -> b -> m b) -> b -> t m a -> m b

99+foldrM step acc m = S.foldrM step acc $ toStreamS m

100+

101+{-# INLINE foldr #-}

102+foldr :: (Monad m, IsStream t) => (a -> b -> b) -> b -> t m a -> m b

103+foldr f = foldrM (\a b -> return (f a b))

104+

92105-- | Strict left associative fold.

93106--

94107-- @since 0.2.0

@@ -129,7 +142,7 @@ cmpBy f m1 m2 = D.cmpBy f (D.toStreamD m1) (D.toStreamD m2)

129142{-# INLINABLE foldWith #-}

130143foldWith :: (IsStream t, Foldable f)

131144 => (t m a -> t m a -> t m a) -> f (t m a) -> t m a

132−foldWith f = foldr f K.nil

145+foldWith f = Prelude.foldr f K.nil

133146

134147-- | A variant of 'foldMap' that allows you to map a monadic streaming action

135148-- on a 'Foldable' container and then fold it using the specified stream sum

@@ -141,7 +154,7 @@ foldWith f = foldr f K.nil

141154{-# INLINABLE foldMapWith #-}

142155foldMapWith :: (IsStream t, Foldable f)

143156 => (t m b -> t m b -> t m b) -> (a -> t m b) -> f a -> t m b

144−foldMapWith f g = foldr (f . g) K.nil

157+foldMapWith f g = Prelude.foldr (f . g) K.nil

145158

146159-- | Like 'foldMapWith' but with the last two arguments reversed i.e. the

147160-- monadic streaming function is the last argument.

@@ -150,4 +163,4 @@ foldMapWith f g = foldr (f . g) K.nil

150163{-# INLINABLE forEachWith #-}

151164forEachWith :: (IsStream t, Foldable f)

152165 => (t m b -> t m b -> t m b) -> f a -> (a -> t m b) -> t m b

153−forEachWith f xs g = foldr (f . g) K.nil xs

166+forEachWith f xs g = Prelude.foldr (f . g) K.nil xs

src/Streamly/Streams/Serial.hs+11−4

@@ -1,6 +1,5 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DeriveTraversable #-}

43{-# LANGUAGE FlexibleContexts #-}

54{-# LANGUAGE FlexibleInstances #-}

65{-# LANGUAGE GeneralizedNewtypeDeriving#-}

@@ -43,6 +42,7 @@ module Streamly.Streams.Serial

4342 )

4443where

4544

45+import Control.Applicative (liftA2)

4646import Control.DeepSeq (NFData(..), NFData1(..), rnf1)

4747import Control.Monad (ap)

4848import Control.Monad.Base (MonadBase(..), liftBaseDefault)

@@ -52,7 +52,8 @@ import Control.Monad.IO.Class (MonadIO(..))

5252import Control.Monad.Reader.Class (MonadReader(..))

5353import Control.Monad.State.Class (MonadState(..))

5454import Control.Monad.Trans.Class (MonadTrans(lift))

55−import Data.Functor.Identity (Identity, runIdentity)

55+import Data.Functor.Identity (Identity(..), runIdentity)

56+import Data.Foldable (fold)

5657import Data.Semigroup (Semigroup(..))

5758import GHC.Exts (IsList(..), IsString(..))

5859import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec,

@@ -129,7 +130,7 @@ import qualified Streamly.Streams.StreamD as D

129130--

130131-- @since 0.2.0

131132newtype SerialT m a = SerialT {getSerialT :: Stream m a}

132− deriving (Semigroup, Monoid, MonadTrans, Foldable, Traversable)

133+ deriving (Semigroup, Monoid, MonadTrans)

133134

134135-- | A serial IO stream of elements of type @a@. See 'SerialT' documentation

135136-- for more details.

@@ -249,7 +250,7 @@ MONAD_COMMON_INSTANCES(SerialT,)

249250--

250251-- @since 0.2.0

251252newtype WSerialT m a = WSerialT {getWSerialT :: Stream m a}

252− deriving (MonadTrans, Foldable, Traversable)

253+ deriving (MonadTrans)

253254

254255-- | An interleaving serial IO stream of elements of type @a@. See 'WSerialT'

255256-- documentation for more details.

@@ -353,3 +354,9 @@ MONAD_COMMON_INSTANCES(WSerialT,)

353354

354355LIST_INSTANCES(SerialT)

355356LIST_INSTANCES(WSerialT)

357+

358+FOLDABLE_INSTANCE(SerialT)

359+FOLDABLE_INSTANCE(WSerialT)

360+

361+TRAVERSABLE_INSTANCE(SerialT)

362+TRAVERSABLE_INSTANCE(WSerialT)

src/Streamly/Streams/StreamD.hs−15

@@ -134,7 +134,6 @@ import Prelude

134134

135135import Streamly.SVar (MonadAsync, State(..), defState, rstState)

136136

137−import qualified Data.Foldable as F

138137import qualified Streamly.Streams.StreamK as K

139138

140139------------------------------------------------------------------------------

@@ -157,20 +156,6 @@ instance Functor (Step s) where

157156-- current state, and the current state.

158157data Stream m a = forall s. Stream (State K.Stream m a -> s -> m (Step s a)) s

159158

160−instance (Foldable m, Monad m) => Foldable (Stream m) where

161− {-# INLINE foldMap #-}

162− foldMap f = F.fold . toFoldable . map f

163− where

164− toFoldable :: (Monad m, Monoid a) => Stream m a -> m a

165− toFoldable = foldr mappend mempty

166−

167−instance (Traversable m, Monad m) => Traversable (Stream m) where

168− {-# INLINE traverse #-}

169− traverse f = sequenceA . fmap f

170−

171− {-# INLINE sequenceA #-}

172− sequenceA = traverse id

173−

174159------------------------------------------------------------------------------

175160-- Construction

176161------------------------------------------------------------------------------

src/Streamly/Streams/StreamK.hs−15

@@ -153,7 +153,6 @@ import Prelude

153153 take, filter, all, any, takeWhile, drop, dropWhile, minimum,

154154 maximum, elem, notElem, null, head, tail, init, zipWith, lookup,

155155 foldr1)

156−import qualified Data.Foldable as F

157156import qualified Prelude

158157

159158import Streamly.SVar

@@ -189,20 +188,6 @@ newtype Stream m a =

189188 -> m r

190189 }

191190

192−instance (Foldable m, Monad m) => Foldable (Stream m) where

193− {-# INLINE foldMap #-}

194− foldMap f = F.fold . toFoldable . map f

195− where

196− toFoldable :: (Monad m, Monoid a) => Stream m a -> m a

197− toFoldable = foldr mappend mempty

198−

199−instance (Traversable m, Monad m) => Traversable (Stream m) where

200− {-# INLINE traverse #-}

201− traverse f = sequenceA . fmap f

202−

203− {-# INLINE sequenceA #-}

204− sequenceA = traverse id

205−

206191-- XXX make this the default "unStream"

207192-- | unwraps the Stream type producing the stream function that can be run with

208193-- continuations.

src/Streamly/Streams/Zip.hs+7−3

@@ -1,6 +1,5 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DeriveTraversable #-}

43{-# LANGUAGE FlexibleContexts #-}

54{-# LANGUAGE FlexibleInstances #-}

65{-# LANGUAGE GeneralizedNewtypeDeriving#-}

@@ -39,8 +38,10 @@ module Streamly.Streams.Zip

3938 )

4039where

4140

41+import Control.Applicative (liftA2)

4242import Control.DeepSeq (NFData(..), NFData1(..), rnf1)

4343import Data.Functor.Identity (Identity, runIdentity)

44+import Data.Foldable (fold)

4445import Data.Semigroup (Semigroup(..))

4546import GHC.Exts (IsList(..), IsString(..))

4647import Text.Read (Lexeme(Ident), lexP, parens, prec, readPrec, readListPrec,

@@ -80,7 +81,7 @@ import qualified Streamly.Streams.StreamK as K

8081--

8182-- @since 0.2.0

8283newtype ZipSerialM m a = ZipSerialM {getZipSerialM :: Stream m a}

83− deriving (Semigroup, Monoid, Foldable, Traversable)

84+ deriving (Semigroup, Monoid)

8485

8586-- |

8687-- @since 0.1.0

@@ -128,6 +129,9 @@ instance Monad m => Applicative (ZipSerialM m) where

128129 pure = ZipSerialM . K.repeat

129130 m1 <*> m2 = fromStream $ K.zipWith id (toStream m1) (toStream m2)

130131

132+FOLDABLE_INSTANCE(ZipSerialM)

133+TRAVERSABLE_INSTANCE(ZipSerialM)

134+

131135------------------------------------------------------------------------------

132136-- Parallel Zipping

133137------------------------------------------------------------------------------

@@ -176,7 +180,7 @@ zipAsyncWithM f m1 m2 = fromStream $ Stream $ \st stp sng yld -> do

176180--

177181-- @since 0.2.0

178182newtype ZipAsyncM m a = ZipAsyncM {getZipAsyncM :: Stream m a}

179− deriving (Semigroup, Monoid, Foldable, Traversable)

183+ deriving (Semigroup, Monoid)

180184

181185-- | An IO stream whose applicative instance zips streams wAsyncly.

182186--

test/PureStreams.hs+17−1

@@ -59,9 +59,13 @@ main = hspec $ do

5959 [(x,y) | x <- [1..2], y <- [1..2]] `shouldBe`

6060 ([(1,1), (1,2), (2,1), (2,2)] :: SerialT Identity (Int, Int))

6161

62− it "Foldable (sum)" $ sum (S.fromList [1..3] :: SerialT Identity Int)

62+ it "Foldable (sum)" $ sum ([1..3] :: SerialT Identity Int)

6363 `shouldBe` 6

6464

65+ it "Traversable (mapM)" $

66+ mapM return ([1..10] :: SerialT Identity Int)

67+ `shouldReturn` [1..10]

68+

6569 describe "OverloadedStrings for 'SerialT Identity' type" $ do

6670 it "overloaded strings" $ do

6771 ("hello" :: SerialT Identity Char) `shouldBe` S.fromList "hello"

@@ -131,12 +135,20 @@ main = hspec $ do

131135

132136 it "Foldable (sum)" $ sum ([1..3] :: List Int) `shouldBe` 6

133137

138+ it "Traversable (mapM)" $

139+ mapM return ([1..10] :: List Int)

140+ `shouldReturn` [1..10]

141+

134142 describe "OverloadedStrings for List type" $ do

135143 it "overloaded strings" $ do

136144 ("hello" :: List Char) `shouldBe` GHC.fromList "hello"

137145

138146 it "pattern matches" $ do

147+#if __GLASGOW_HASKELL__ >= 802

139148 case "" of

149+#else

150+ case "" :: List Char of

151+#endif

140152 Nil -> return ()

141153 _ -> expectationFailure "not reached"

142154

@@ -201,6 +213,10 @@ main = hspec $ do

201213

202214 it "Foldable (sum)" $ sum ([1..3] :: ZipList Int) `shouldBe` 6

203215

216+ it "Traversable (mapM)" $

217+ mapM return ([1..10] :: ZipList Int)

218+ `shouldReturn` [1..10]

219+

204220 it "Applicative Zip" $ do

205221 (,) <$> "abc" <*> [1..3] `shouldBe`

206222 ([('a',1),('b',2),('c',3)] :: ZipList (Char, Int))