1{-# LANGUAGE ScopedTypeVariables #-} 2{-# LANGUAGE GeneralizedNewtypeDeriving #-} 3{-# LANGUAGE RankNTypes #-} 4{-# LANGUAGE ViewPatterns #-} 5{-# LANGUAGE TupleSections #-} 6{-# LANGUAGE TypeFamilies #-} 7{-# LANGUAGE CPP #-} 8{-# OPTIONS_GHC -fno-warn-orphans #-} 9module StreamSpec where 10 11import Control.Arrow (first) 12import Control.Applicative 13import qualified Control.Monad 14import Control.Monad (liftM) 15import Control.Monad.Identity (Identity, runIdentity) 16import Control.Monad.State (StateT(..), get, put) 17import Data.Conduit 18import Data.Conduit.Combinators 19import Data.Conduit.Combinators.Stream 20import Data.Conduit.Internal.Fusion 21import Data.Conduit.Internal.List.Stream (takeS, sourceListS, mapS) 22import qualified Data.List 23import Data.MonoTraversable 24import Data.Monoid (Monoid(..)) 25import qualified Data.NonNull as NonNull 26import Data.Sequence (Seq) 27import qualified Data.Sequences as Seq 28import Data.Vector (Vector) 29import qualified Prelude 30import Prelude 31 ((.), ($), (>>=), (=<<), return, id, Maybe(..), Either(..), Monad, 32 Bool(..), Int, Eq, Show, String, Functor, fst, snd, either) 33import qualified Safe 34import qualified System.IO as IO 35import System.IO.Unsafe 36import Test.Hspec 37import Test.QuickCheck 38import Data.Semigroup (Semigroup (..)) 39 40spec :: Spec 41spec = do 42 describe "Comparing list function to" $ do 43 qit "yieldMany" $ 44 \(mono :: Seq Int) -> 45 yieldMany mono `checkProducer` 46 otoList mono 47 qit "sourceListS" $ 48 \(mono :: Seq Int) -> 49 yieldManyS mono `checkStreamProducer` 50 otoList mono 51 qit "repeatM" $ 52 \(getBlind -> (f :: M Int)) -> 53 repeatM f `checkInfiniteProducerM` 54 repeatML f 55 qit "repeatMS" $ 56 \(getBlind -> (f :: M Int)) -> 57 repeatMS f `checkInfiniteStreamProducerM` 58 repeatML f 59 qit "repeatWhileM" $ 60 \(getBlind -> (f :: M Int), getBlind -> g) -> 61 repeatWhileM f g `checkInfiniteProducerM` 62 repeatWhileML f g 63 qit "repeatWhileMS" $ 64 \(getBlind -> (f :: M Int), getBlind -> g) -> 65 repeatWhileMS f g `checkInfiniteStreamProducerM` 66 repeatWhileML f g 67 qit "foldl1" $ 68 \(getBlind -> f) -> 69 foldl1 f `checkConsumer` 70 foldl1L f 71 qit "foldl1S" $ 72 \(getBlind -> f) -> 73 foldl1S f `checkStreamConsumer` 74 foldl1L f 75 qit "all" $ 76 \(getBlind -> f) -> 77 all f `checkConsumer` 78 Prelude.all f 79 qit "allS" $ 80 \(getBlind -> f) -> 81 allS f `checkStreamConsumer` 82 Prelude.all f 83 qit "any" $ 84 \(getBlind -> f) -> 85 any f `checkConsumer` 86 Prelude.any f 87 qit "anyS" $ 88 \(getBlind -> f) -> 89 anyS f `checkStreamConsumer` 90 Prelude.any f 91 qit "last" $ 92 \() -> 93 last `checkConsumer` 94 Safe.lastMay 95 qit "lastS" $ 96 \() -> 97 lastS `checkStreamConsumer` 98 Safe.lastMay 99 qit "lastE" $ 100 \(getBlind -> f) -> 101 let g x = Seq.replicate (Prelude.abs (getSmall (f x))) x :: Seq Int 102 in (map g .| lastE) `checkConsumer` 103 (lastEL . Prelude.map g :: [Int] -> Maybe Int) 104 qit "lastES" $ 105 \(getBlind -> f) -> 106 let g x = Seq.replicate (Prelude.abs (getSmall (f x))) x :: Seq Int 107 in (lastES . mapS g) `checkStreamConsumer` 108 (lastEL . Prelude.map g :: [Int] -> Maybe Int) 109 qit "find" $ 110 \(getBlind -> f) -> 111 find f `checkConsumer` 112 Data.List.find f 113 qit "findS" $ 114 \(getBlind -> f) -> 115 findS f `checkStreamConsumer` 116 Data.List.find f 117 qit "concatMap" $ 118 \(getBlind -> (f :: Int -> Seq Int)) -> 119 concatMap f `checkConduit` 120 concatMapL f 121 qit "concatMapS" $ 122 \(getBlind -> (f :: Int -> Seq Int)) -> 123 concatMapS f `checkStreamConduit` 124 concatMapL f 125 qit "concatMapM" $ 126 \(getBlind -> (f :: Int -> M (Seq Int))) -> 127 concatMapM f `checkConduitT` 128 concatMapML f 129 qit "concatMapMS" $ 130 \(getBlind -> (f :: Int -> M (Seq Int))) -> 131 concatMapMS f `checkStreamConduitT` 132 concatMapML f 133 qit "concat" $ 134 \() -> 135 concat `checkConduit` 136 (concatL :: [Seq Int] -> [Int]) 137 qit "concatS" $ 138 \() -> 139 concatS `checkStreamConduit` 140 (concatL :: [Seq Int] -> [Int]) 141 qit "scanl" $ 142 \(getBlind -> (f :: Int -> Int -> Int), initial) -> 143 scanl f initial `checkConduit` 144 Prelude.scanl f initial 145 qit "scanlS" $ 146 \(getBlind -> (f :: Int -> Int -> Int), initial) -> 147 scanlS f initial `checkStreamConduit` 148 Prelude.scanl f initial 149 qit "scanlM" $ 150 \(getBlind -> (f :: Int -> Int -> M Int), initial) -> 151 scanlM f initial `checkConduitT` 152 scanlML f initial 153 qit "scanlMS" $ 154 \(getBlind -> (f :: Int -> Int -> M Int), initial) -> 155 scanlMS f initial `checkStreamConduitT` 156 scanlML f initial 157 qit "mapAccumWhileS" $ 158 \(getBlind -> ( f :: Int -> [Int] -> Either [Int] ([Int], Int)) 159 , initial :: [Int]) -> 160 mapAccumWhileS f initial `checkStreamConduitResult` 161 mapAccumWhileL f initial 162 qit "mapAccumWhileMS" $ 163 \(getBlind -> ( f :: Int -> [Int] -> M (Either [Int] ([Int], Int))) 164 , initial :: [Int]) -> 165 mapAccumWhileMS f initial `checkStreamConduitResultM` 166 mapAccumWhileML f initial 167 qit "intersperse" $ 168 \(sep :: Int) -> 169 intersperse sep `checkConduit` 170 Data.List.intersperse sep 171 qit "intersperseS" $ 172 \(sep :: Int) -> 173 intersperseS sep `checkStreamConduit` 174 Data.List.intersperse sep 175 qit "filterM" $ 176 \(getBlind -> (f :: Int -> M Bool)) -> 177 filterM f `checkConduitT` 178 Control.Monad.filterM f 179 qit "filterMS" $ 180 \(getBlind -> (f :: Int -> M Bool)) -> 181 filterMS f `checkStreamConduitT` 182 Control.Monad.filterM f 183 describe "comparing normal conduit function to" $ do 184 qit "slidingWindowS" $ 185 \(getSmall -> n) -> 186 slidingWindowS n `checkStreamConduit` 187 (\xs -> runConduitPure $ 188 yieldMany xs .| preventFusion (slidingWindow n) .| sinkList 189 :: [Seq Int]) 190 qit "splitOnUnboundedES" $ 191 \(getBlind -> (f :: Int -> Bool)) -> 192 splitOnUnboundedES f `checkStreamConduit` 193 (\xs -> runConduitPure $ 194 yieldMany xs .| preventFusion (splitOnUnboundedE f) .| sinkList 195 :: [Seq Int]) 196 qit "sinkVectorS" $ 197 \() -> checkStreamConsumerM' 198 unsafePerformIO 199 (sinkVectorS :: forall o. StreamConduitT Int o IO.IO (Vector Int)) 200 (\xs -> runConduit $ yieldMany xs .| preventFusion sinkVector) 201 qit "sinkVectorNS" $ 202 \(getSmall . getNonNegative -> n) -> checkStreamConsumerM' 203 unsafePerformIO 204 (sinkVectorNS n :: forall o. StreamConduitT Int o IO.IO (Vector Int)) 205 (\xs -> runConduit $ yieldMany xs .| preventFusion (sinkVectorN n)) 206 207#if !MIN_VERSION_QuickCheck(2,8,2) 208instance Arbitrary a => Arbitrary (Seq a) where 209 arbitrary = Seq.fromList <$> arbitrary 210#endif 211 212repeatML :: Monad m => m a -> m [a] 213repeatML = Prelude.sequence . Prelude.repeat 214 215repeatWhileML :: Monad m => m a -> (a -> Bool) -> m [a] 216repeatWhileML m f = go 217 where 218 go = do 219 x <- m 220 if f x 221 then liftM (x:) go 222 else return [] 223 224foldl1L :: (a -> a -> a) -> [a] -> Maybe a 225foldl1L _ [] = Nothing 226foldl1L f xs = Just $ Prelude.foldl1 f xs 227 228lastEL :: Seq.IsSequence seq 229 => [seq] -> Maybe (Element seq) 230lastEL = Prelude.foldl go Nothing 231 where 232 go _ (NonNull.fromNullable -> Just l) = Just (NonNull.last l) 233 go mlast _ = mlast 234 235concatMapL :: MonoFoldable mono 236 => (a -> mono) -> [a] -> [Element mono] 237concatMapL f = Prelude.concatMap (otoList . f) 238 239concatMapML :: (Monad m, MonoFoldable mono) 240 => (a -> m mono) -> [a] -> m [Element mono] 241concatMapML f = liftM (Prelude.concatMap otoList) . Prelude.mapM f 242 243concatL :: MonoFoldable mono 244 => [mono] -> [Element mono] 245concatL = Prelude.concatMap otoList 246 247scanlML :: Monad m => (a -> b -> m a) -> a -> [b] -> m [a] 248scanlML f = go 249 where 250 go l [] = return [l] 251 go l (r:rs) = do 252 l' <- f l r 253 liftM (l:) (go l' rs) 254 255mapAccumWhileL :: (a -> s -> Either s (s, b)) -> s -> [a] -> ([b], s) 256mapAccumWhileL f = (runIdentity.) . mapAccumWhileML ((return.) . f) 257 258mapAccumWhileML :: Monad m => 259 (a -> s -> m (Either s (s, b))) -> s -> [a] -> m ([b], s) 260mapAccumWhileML f = go 261 where go s [] = return ([], s) 262 go s (a:as) = f a s >>= either 263 (return . ([], )) 264 (\(s', b) -> liftM (first (b:)) $ go s' as) 265 266--FIXME: the following code is directly copied from the conduit test 267--suite. How to share this code?? 268 269qit :: (Arbitrary a, Testable prop, Show a) 270 => String -> (a -> prop) -> Spec 271qit n f = it n $ property $ forAll arbitrary f 272 273-------------------------------------------------------------------------------- 274-- Quickcheck utilities for pure conduits / streams 275 276checkProducer :: (Show a, Eq a) => ConduitT () a Identity () -> [a] -> Property 277checkProducer c l = checkProducerM' runIdentity c (return l) 278 279checkStreamProducer :: (Show a, Eq a) => StreamSource Identity a -> [a] -> Property 280checkStreamProducer s l = checkStreamProducerM' runIdentity s (return l) 281 282checkInfiniteProducer :: (Show a, Eq a) => ConduitT () a Identity () -> [a] -> Property 283checkInfiniteProducer c l = checkInfiniteProducerM' runIdentity c (return l) 284 285checkInfiniteStreamProducer :: (Show a, Eq a) => StreamSource Identity a -> [a] -> Property 286checkInfiniteStreamProducer s l = checkInfiniteStreamProducerM' runIdentity s (return l) 287 288checkConsumer :: (Show b, Eq b) => ConduitT Int Void Identity b -> ([Int] -> b) -> Property 289checkConsumer c l = checkConsumerM' runIdentity c (return . l) 290 291checkStreamConsumer :: (Show b, Eq b) => StreamConduitT Int o Identity b -> ([Int] -> b) -> Property 292checkStreamConsumer c l = checkStreamConsumerM' runIdentity c (return . l) 293 294checkConduit :: (Show a, Arbitrary a, Show b, Eq b) => ConduitT a b Identity () -> ([a] -> [b]) -> Property 295checkConduit c l = checkConduitT' runIdentity c (return . l) 296 297checkStreamConduit :: (Show a, Arbitrary a, Show b, Eq b) => StreamConduit a Identity b -> ([a] -> [b]) -> Property 298checkStreamConduit c l = checkStreamConduitT' runIdentity c (return . l) 299 300-- checkConduitResult :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => ConduitT a b Identity r -> ([a] -> ([b], r)) -> Property 301-- checkConduitResult c l = checkConduitResultM' runIdentity c (return . l) 302 303checkStreamConduitResult :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => StreamConduitT a b Identity r -> ([a] -> ([b], r)) -> Property 304checkStreamConduitResult c l = checkStreamConduitResultM' runIdentity c (return . l) 305 306-------------------------------------------------------------------------------- 307-- Quickcheck utilities for conduits / streams in the M monad. 308 309checkProducerM :: (Show a, Eq a) => ConduitT () a M () -> M [a] -> Property 310checkProducerM = checkProducerM' runM 311 312checkStreamProducerM :: (Show a, Eq a) => StreamSource M a -> M [a] -> Property 313checkStreamProducerM = checkStreamProducerM' runM 314 315checkInfiniteProducerM :: (Show a, Eq a) => ConduitT () a M () -> M [a] -> Property 316checkInfiniteProducerM = checkInfiniteProducerM' (fst . runM) 317 318checkInfiniteStreamProducerM :: (Show a, Eq a) => StreamSource M a -> M [a] -> Property 319checkInfiniteStreamProducerM = checkInfiniteStreamProducerM' (fst . runM) 320 321checkConsumerM :: (Show b, Eq b) => ConduitT Int Void M b -> ([Int] -> M b) -> Property 322checkConsumerM = checkConsumerM' runM 323 324checkStreamConsumerM :: (Show b, Eq b) => StreamConduitT Int o M b -> ([Int] -> M b) -> Property 325checkStreamConsumerM = checkStreamConsumerM' runM 326 327checkConduitT :: (Show a, Arbitrary a, Show b, Eq b) => ConduitT a b M () -> ([a] -> M [b]) -> Property 328checkConduitT = checkConduitT' runM 329 330checkStreamConduitT :: (Show a, Arbitrary a, Show b, Eq b) => StreamConduitT a b M () -> ([a] -> M [b]) -> Property 331checkStreamConduitT = checkStreamConduitT' runM 332 333-- checkConduitResultM :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => ConduitT a b M r -> ([a] -> M ([b], r)) -> Property 334-- checkConduitResultM = checkConduitResultM' runM 335 336checkStreamConduitResultM :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => StreamConduitT a b M r -> ([a] -> M ([b], r)) -> Property 337checkStreamConduitResultM = checkStreamConduitResultM' runM 338 339-------------------------------------------------------------------------------- 340-- Quickcheck utilities for monadic streams / conduits 341-- These are polymorphic in which Monad is used. 342 343checkProducerM' :: (Show a, Monad m, Show b, Eq b) 344 => (m [a] -> b) 345 -> ConduitT () a m () 346 -> m [a] 347 -> Property 348checkProducerM' f c l = 349 f (runConduit $ preventFusion c .| sinkList) 350 === 351 f l 352 353checkStreamProducerM' :: (Show a, Monad m, Show b, Eq b) 354 => (m [a] -> b) 355 -> StreamConduitT () a m () 356 -> m [a] 357 -> Property 358checkStreamProducerM' f s l = 359 f (liftM fst $ evalStream $ s emptyStream) 360 === 361 f l 362 363checkInfiniteProducerM' :: (Show a, Monad m, Show b, Eq b) 364 => (m [a] -> b) 365 -> ConduitT () a m () 366 -> m [a] 367 -> Property 368checkInfiniteProducerM' f s l = 369 checkProducerM' f 370 (preventFusion s .| take 10) 371 (liftM (Prelude.take 10) l) 372 373checkInfiniteStreamProducerM' :: (Show a, Monad m, Show b, Eq b) 374 => (m [a] -> b) 375 -> StreamConduitT () a m () 376 -> m [a] 377 -> Property 378checkInfiniteStreamProducerM' f s l = 379 f (liftM snd $ evalStream $ takeS 10 $ s emptyStream) 380 === 381 f (liftM (Prelude.take 10) l) 382 383checkConsumerM' :: (Show a, Monad m, Show b, Eq b) 384 => (m a -> b) 385 -> ConduitT Int Void m a 386 -> ([Int] -> m a) 387 -> Property 388checkConsumerM' f c l = forAll arbitrary $ \xs -> 389 f (runConduit $ yieldMany xs .| preventFusion c) 390 === 391 f (l xs) 392 393checkStreamConsumerM' :: (Show a, Monad m, Show b, Eq b) 394 => (m a -> b) 395 -> StreamConduitT Int o m a 396 -> ([Int] -> m a) 397 -> Property 398checkStreamConsumerM' f s l = forAll (arbitrary) $ \xs -> 399 f (liftM snd $ evalStream $ s $ sourceListS xs emptyStream) 400 === 401 f (l xs) 402 403checkConduitT' :: (Show a, Arbitrary a, Monad m, Show c, Eq c) 404 => (m [b] -> c) 405 -> ConduitT a b m () 406 -> ([a] -> m [b]) 407 -> Property 408checkConduitT' f c l = forAll arbitrary $ \xs -> 409 f (runConduit $ yieldMany xs .| preventFusion c .| sinkList) 410 === 411 f (l xs) 412 413checkStreamConduitT' :: (Show a, Arbitrary a, Monad m, Show c, Eq c) 414 => (m [b] -> c) 415 -> StreamConduit a m b 416 -> ([a] -> m [b]) 417 -> Property 418checkStreamConduitT' f s l = forAll arbitrary $ \xs -> 419 f (liftM fst $ evalStream $ s $ sourceListS xs emptyStream) 420 === 421 f (l xs) 422 423-- TODO: Fixing this would allow comparing conduit sinkListrs against 424-- their list versions. 425-- 426-- checkConduitResultM' :: (Show a, Arbitrary a, Monad m, Show c, Eq c) 427-- => (m ([b], r) -> c) 428-- -> ConduitT a b m r 429-- -> ([a] -> m ([b], r)) 430-- -> Property 431-- checkConduitResultM' f c l = FIXME forAll arbitrary $ \xs -> 432-- f (runConduit $ yieldMany xs .| preventFusion c .| sinkList) 433-- === 434-- f (l xs) 435 436checkStreamConduitResultM' :: (Show a, Arbitrary a, Monad m, Show c, Eq c) 437 => (m ([b], r) -> c) 438 -> StreamConduitT a b m r 439 -> ([a] -> m ([b], r)) 440 -> Property 441checkStreamConduitResultM' f s l = forAll arbitrary $ \xs -> 442 f (evalStream $ s $ sourceListS xs emptyStream) 443 === 444 f (l xs) 445 446emptyStream :: Monad m => Stream m () () 447emptyStream = Stream (\_ -> return $ Stop ()) (return ()) 448 449evalStream :: Monad m => Stream m o r -> m ([o], r) 450evalStream (Stream step s0) = go =<< s0 451 where 452 go s = do 453 res <- step s 454 case res of 455 Stop r -> return ([], r) 456 Skip s' -> go s' 457 Emit s' x -> liftM (\(l, r) -> (x:l, r)) (go s') 458 459-------------------------------------------------------------------------------- 460-- Misc utilities 461 462-- Prefer this to creating an orphan instance for Data.Monoid.Sum: 463 464newtype Sum a = Sum a 465 deriving (Eq, Show, Arbitrary) 466 467instance Prelude.Num a => Semigroup (Sum a) where 468 Sum x <> Sum y = Sum $ x Prelude.+ y 469instance Prelude.Num a => Monoid (Sum a) where 470 mempty = Sum 0 471 mappend (Sum x) (Sum y) = Sum $ x Prelude.+ y 472 473preventFusion :: a -> a 474preventFusion = id 475{-# INLINE [0] preventFusion #-} 476 477newtype M a = M (StateT Int Identity a) 478 deriving (Functor, Applicative, Monad) 479 480instance Arbitrary a => Arbitrary (M a) where 481 arbitrary = do 482 f <- arbitrary 483 return $ do 484 s <- M get 485 let (x, s') = f s 486 M (put s') 487 return x 488 489runM :: M a -> (a, Int) 490runM (M m) = runIdentity $ runStateT m 0 491 492-------------------------------------------------------------------------------- 493-- Utilities from QuickCheck-2.7 (absent in earlier versions) 494 495#if !MIN_VERSION_QuickCheck(2,7,0) 496getBlind :: Blind a -> a 497getBlind (Blind x) = x 498 499-- | @Small x@: generates values of @x@ drawn from a small range. 500-- The opposite of 'Large'. 501newtype Small a = Small {getSmall :: a} 502 deriving (Prelude.Ord, Prelude.Eq, Prelude.Enum, Prelude.Show, Prelude.Num) 503 504instance Prelude.Integral a => Arbitrary (Small a) where 505 arbitrary = Prelude.fmap Small arbitrarySizedIntegral 506 shrink (Small x) = Prelude.map Small (shrinkIntegral x) 507 508(===) :: (Show a, Eq a) => a -> a -> Property 509x === y = whenFail 510 (Prelude.fail $ Prelude.show x Prelude.++ " should match " Prelude.++ Prelude.show y) 511 (x Prelude.== y) 512#endif 513