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