conduit-1.3.0.1: test/StreamSpec.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module StreamSpec where

import           Control.Arrow (first)
import           Control.Applicative
import qualified Control.Monad
import           Control.Monad (liftM)
import           Control.Monad.Identity (Identity, runIdentity)
import           Control.Monad.State (StateT(..), get, put)
import           Data.Conduit
import           Data.Conduit.Combinators
import           Data.Conduit.Combinators.Stream
import           Data.Conduit.Internal.Fusion
import           Data.Conduit.Internal.List.Stream (takeS, sourceListS, mapS)
import qualified Data.List
import           Data.MonoTraversable
import           Data.Monoid (Monoid(..))
import qualified Data.NonNull as NonNull
import           Data.Sequence (Seq)
import qualified Data.Sequences as Seq
import           Data.Vector (Vector)
import qualified Prelude
import           Prelude
    ((.), ($), (>>=), (=<<), return, id, Maybe(..), Either(..), Monad,
     Bool(..), Int, Eq, Show, String, Functor, fst, snd, either)
import qualified Safe
import qualified System.IO as IO
import           System.IO.Unsafe
import           Test.Hspec
import           Test.QuickCheck
import           Data.Semigroup (Semigroup (..))

spec :: Spec
spec = do
    describe "Comparing list function to" $ do
        qit "yieldMany" $
            \(mono :: Seq Int) ->
                yieldMany mono `checkProducer`
                otoList mono
        qit "sourceListS" $
            \(mono :: Seq Int) ->
                yieldManyS mono `checkStreamProducer`
                otoList mono
        qit "repeatM" $
            \(getBlind -> (f :: M Int)) ->
                repeatM f `checkInfiniteProducerM`
                repeatML f
        qit "repeatMS" $
            \(getBlind -> (f :: M Int)) ->
                repeatMS f `checkInfiniteStreamProducerM`
                repeatML f
        qit "repeatWhileM" $
            \(getBlind -> (f :: M Int), getBlind -> g) ->
                repeatWhileM f g `checkInfiniteProducerM`
                repeatWhileML f g
        qit "repeatWhileMS" $
            \(getBlind -> (f :: M Int), getBlind -> g) ->
                repeatWhileMS f g `checkInfiniteStreamProducerM`
                repeatWhileML f g
        qit "foldl1" $
            \(getBlind -> f) ->
                foldl1 f `checkConsumer`
                foldl1L f
        qit "foldl1S" $
            \(getBlind -> f) ->
                foldl1S f `checkStreamConsumer`
                foldl1L f
        qit "all" $
            \(getBlind -> f) ->
                all f `checkConsumer`
                Prelude.all f
        qit "allS" $
            \(getBlind -> f) ->
                allS f `checkStreamConsumer`
                Prelude.all f
        qit "any" $
            \(getBlind -> f) ->
                any f `checkConsumer`
                Prelude.any f
        qit "anyS" $
            \(getBlind -> f) ->
                anyS f `checkStreamConsumer`
                Prelude.any f
        qit "last" $
            \() ->
                last `checkConsumer`
                Safe.lastMay
        qit "lastS" $
            \() ->
                lastS `checkStreamConsumer`
                Safe.lastMay
        qit "lastE" $
            \(getBlind -> f) ->
                let g x = Seq.replicate (Prelude.abs (getSmall (f x))) x :: Seq Int
                 in (map g .| lastE) `checkConsumer`
                    (lastEL . Prelude.map g :: [Int] -> Maybe Int)
        qit "lastES" $
            \(getBlind -> f) ->
                let g x = Seq.replicate (Prelude.abs (getSmall (f x))) x :: Seq Int
                 in (lastES . mapS g) `checkStreamConsumer`
                    (lastEL . Prelude.map g :: [Int] -> Maybe Int)
        qit "find" $
            \(getBlind -> f) ->
                find f `checkConsumer`
                Data.List.find f
        qit "findS" $
            \(getBlind -> f) ->
                findS f `checkStreamConsumer`
                Data.List.find f
        qit "concatMap" $
            \(getBlind -> (f :: Int -> Seq Int)) ->
                concatMap f `checkConduit`
                concatMapL f
        qit "concatMapS" $
            \(getBlind -> (f :: Int -> Seq Int)) ->
                concatMapS f `checkStreamConduit`
                concatMapL f
        qit "concatMapM" $
            \(getBlind -> (f :: Int -> M (Seq Int))) ->
                concatMapM f `checkConduitT`
                concatMapML f
        qit "concatMapMS" $
            \(getBlind -> (f :: Int -> M (Seq Int))) ->
                concatMapMS f `checkStreamConduitT`
                concatMapML f
        qit "concat" $
            \() ->
                concat `checkConduit`
                (concatL :: [Seq Int] -> [Int])
        qit "concatS" $
            \() ->
                concatS `checkStreamConduit`
                (concatL :: [Seq Int] -> [Int])
        qit "scanl" $
            \(getBlind -> (f :: Int -> Int -> Int), initial) ->
                scanl f initial `checkConduit`
                Prelude.scanl f initial
        qit "scanlS" $
            \(getBlind -> (f :: Int -> Int -> Int), initial) ->
                scanlS f initial `checkStreamConduit`
                Prelude.scanl f initial
        qit "scanlM" $
            \(getBlind -> (f :: Int -> Int -> M Int), initial) ->
                scanlM f initial `checkConduitT`
                scanlML f initial
        qit "scanlMS" $
            \(getBlind -> (f :: Int -> Int -> M Int), initial) ->
                scanlMS f initial `checkStreamConduitT`
                scanlML f initial
        qit "mapAccumWhileS" $
            \(getBlind -> ( f :: Int -> [Int] -> Either [Int] ([Int], Int))
                          , initial :: [Int]) ->
                mapAccumWhileS f initial `checkStreamConduitResult`
                mapAccumWhileL f initial
        qit "mapAccumWhileMS" $
            \(getBlind -> ( f :: Int -> [Int] -> M (Either [Int] ([Int], Int)))
                          , initial :: [Int]) ->
                mapAccumWhileMS f initial `checkStreamConduitResultM`
                mapAccumWhileML f initial
        qit "intersperse" $
            \(sep :: Int) ->
                intersperse sep `checkConduit`
                Data.List.intersperse sep
        qit "intersperseS" $
            \(sep :: Int) ->
                intersperseS sep `checkStreamConduit`
                Data.List.intersperse sep
        qit "filterM" $
            \(getBlind -> (f :: Int -> M Bool)) ->
                filterM f `checkConduitT`
                Control.Monad.filterM f
        qit "filterMS" $
            \(getBlind -> (f :: Int -> M Bool)) ->
                filterMS f `checkStreamConduitT`
                Control.Monad.filterM f
    describe "comparing normal conduit function to" $ do
        qit "slidingWindowS" $
            \(getSmall -> n) ->
                slidingWindowS n `checkStreamConduit`
                (\xs -> runConduitPure $
                    yieldMany xs .| preventFusion (slidingWindow n) .| sinkList
                    :: [Seq Int])
        qit "splitOnUnboundedES" $
            \(getBlind -> (f :: Int -> Bool)) ->
                splitOnUnboundedES f `checkStreamConduit`
                (\xs -> runConduitPure $
                    yieldMany xs .| preventFusion (splitOnUnboundedE f) .| sinkList
                    :: [Seq Int])
        qit "sinkVectorS" $
            \() -> checkStreamConsumerM'
                unsafePerformIO
                (sinkVectorS :: forall o. StreamConduitT Int o IO.IO (Vector Int))
                (\xs -> runConduit $ yieldMany xs .| preventFusion sinkVector)
        qit "sinkVectorNS" $
            \(getSmall . getNonNegative -> n) -> checkStreamConsumerM'
                unsafePerformIO
                (sinkVectorNS n :: forall o. StreamConduitT Int o IO.IO (Vector Int))
                (\xs -> runConduit $ yieldMany xs .| preventFusion (sinkVectorN n))

#if !MIN_VERSION_QuickCheck(2,8,2)
instance Arbitrary a => Arbitrary (Seq a) where
    arbitrary = Seq.fromList <$> arbitrary
#endif

repeatML :: Monad m => m a -> m [a]
repeatML = Prelude.sequence . Prelude.repeat

repeatWhileML :: Monad m => m a -> (a -> Bool) -> m [a]
repeatWhileML m f = go
  where
    go = do
        x <- m
        if f x
           then liftM (x:) go
           else return []

foldl1L :: (a -> a -> a) -> [a] -> Maybe a
foldl1L _ [] = Nothing
foldl1L f xs = Just $ Prelude.foldl1 f xs

lastEL :: Seq.IsSequence seq
       => [seq] -> Maybe (Element seq)
lastEL = Prelude.foldl go Nothing
  where
    go _ (NonNull.fromNullable -> Just l) = Just (NonNull.last l)
    go mlast _ = mlast

concatMapL :: MonoFoldable mono
           => (a -> mono) -> [a] -> [Element mono]
concatMapL f = Prelude.concatMap (otoList . f)

concatMapML :: (Monad m, MonoFoldable mono)
             => (a -> m mono) -> [a] -> m [Element mono]
concatMapML f = liftM (Prelude.concatMap otoList) . Prelude.mapM f

concatL :: MonoFoldable mono
        => [mono] -> [Element mono]
concatL = Prelude.concatMap otoList

scanlML :: Monad m => (a -> b -> m a) -> a -> [b] -> m [a]
scanlML f = go
  where
    go l [] = return [l]
    go l (r:rs) = do
        l' <- f l r
        liftM (l:) (go l' rs)

mapAccumWhileL :: (a -> s -> Either s (s, b)) -> s -> [a] -> ([b], s)
mapAccumWhileL f = (runIdentity.) . mapAccumWhileML ((return.) . f)

mapAccumWhileML :: Monad m =>
    (a -> s -> m (Either s (s, b))) -> s -> [a] -> m ([b], s)
mapAccumWhileML f = go
    where go s []     = return ([], s)
          go s (a:as) = f a s >>= either
              (return . ([], ))
              (\(s', b) -> liftM (first (b:)) $ go s' as)

--FIXME: the following code is directly copied from the conduit test
--suite.  How to share this code??

qit :: (Arbitrary a, Testable prop, Show a)
     => String -> (a -> prop) -> Spec
qit n f = it n $ property $ forAll arbitrary f

--------------------------------------------------------------------------------
-- Quickcheck utilities for pure conduits / streams

checkProducer :: (Show a, Eq a) => ConduitT () a Identity () -> [a] -> Property
checkProducer c l  = checkProducerM' runIdentity c (return l)

checkStreamProducer :: (Show a, Eq a) => StreamSource Identity a -> [a] -> Property
checkStreamProducer s l = checkStreamProducerM' runIdentity s (return l)

checkInfiniteProducer :: (Show a, Eq a) => ConduitT () a Identity () -> [a] -> Property
checkInfiniteProducer c l = checkInfiniteProducerM' runIdentity c (return l)

checkInfiniteStreamProducer :: (Show a, Eq a) => StreamSource Identity a -> [a] -> Property
checkInfiniteStreamProducer s l = checkInfiniteStreamProducerM' runIdentity s (return l)

checkConsumer :: (Show b, Eq b) => ConduitT Int Void Identity b -> ([Int] -> b) -> Property
checkConsumer c l = checkConsumerM' runIdentity c (return . l)

checkStreamConsumer :: (Show b, Eq b) => StreamConduitT Int o Identity b -> ([Int] -> b) -> Property
checkStreamConsumer c l = checkStreamConsumerM' runIdentity c (return . l)

checkConduit :: (Show a, Arbitrary a, Show b, Eq b) => ConduitT a b Identity () -> ([a] -> [b]) -> Property
checkConduit c l = checkConduitT' runIdentity c (return . l)

checkStreamConduit :: (Show a, Arbitrary a, Show b, Eq b) => StreamConduit a Identity b -> ([a] -> [b]) -> Property
checkStreamConduit c l = checkStreamConduitT' runIdentity c (return . l)

-- checkConduitResult :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => ConduitT a b Identity r -> ([a] -> ([b], r)) -> Property
-- checkConduitResult c l = checkConduitResultM' runIdentity c (return . l)

checkStreamConduitResult :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => StreamConduitT a b Identity r -> ([a] -> ([b], r)) -> Property
checkStreamConduitResult c l = checkStreamConduitResultM' runIdentity c (return . l)

--------------------------------------------------------------------------------
-- Quickcheck utilities for conduits / streams in the M monad.

checkProducerM :: (Show a, Eq a) => ConduitT () a M () -> M [a] -> Property
checkProducerM = checkProducerM' runM

checkStreamProducerM :: (Show a, Eq a) => StreamSource M a -> M [a] -> Property
checkStreamProducerM = checkStreamProducerM' runM

checkInfiniteProducerM :: (Show a, Eq a) => ConduitT () a M () -> M [a] -> Property
checkInfiniteProducerM = checkInfiniteProducerM' (fst . runM)

checkInfiniteStreamProducerM :: (Show a, Eq a) => StreamSource M a -> M [a] -> Property
checkInfiniteStreamProducerM = checkInfiniteStreamProducerM' (fst . runM)

checkConsumerM :: (Show b, Eq b) => ConduitT Int Void M b -> ([Int] -> M b) -> Property
checkConsumerM  = checkConsumerM' runM

checkStreamConsumerM :: (Show b, Eq b) => StreamConduitT Int o M b -> ([Int] -> M b) -> Property
checkStreamConsumerM  = checkStreamConsumerM' runM

checkConduitT :: (Show a, Arbitrary a, Show b, Eq b) => ConduitT a b M () -> ([a] -> M [b]) -> Property
checkConduitT = checkConduitT' runM

checkStreamConduitT :: (Show a, Arbitrary a, Show b, Eq b) => StreamConduitT a b M () -> ([a] -> M [b]) -> Property
checkStreamConduitT = checkStreamConduitT' runM

-- checkConduitResultM :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => ConduitT a b M r -> ([a] -> M ([b], r)) -> Property
-- checkConduitResultM = checkConduitResultM' runM

checkStreamConduitResultM :: (Show a, Arbitrary a, Show b, Eq b, Show r, Eq r) => StreamConduitT a b M r -> ([a] -> M ([b], r)) -> Property
checkStreamConduitResultM = checkStreamConduitResultM' runM

--------------------------------------------------------------------------------
-- Quickcheck utilities for monadic streams / conduits
-- These are polymorphic in which Monad is used.

checkProducerM' :: (Show a, Monad m, Show b, Eq b)
                => (m [a] -> b)
                -> ConduitT () a m ()
                -> m [a]
                -> Property
checkProducerM' f c l =
    f (runConduit $ preventFusion c .| sinkList)
    ===
    f l

checkStreamProducerM' :: (Show a, Monad m, Show b, Eq b)
                      => (m [a] -> b)
                      -> StreamConduitT () a m ()
                      -> m [a]
                      -> Property
checkStreamProducerM' f s l =
    f (liftM fst $ evalStream $ s emptyStream)
    ===
    f l

checkInfiniteProducerM' :: (Show a, Monad m, Show b, Eq b)
                        => (m [a] -> b)
                        -> ConduitT () a m ()
                        -> m [a]
                        -> Property
checkInfiniteProducerM' f s l =
    checkProducerM' f
        (preventFusion s .| take 10)
        (liftM (Prelude.take 10) l)

checkInfiniteStreamProducerM' :: (Show a, Monad m, Show b, Eq b)
                              => (m [a] -> b)
                              -> StreamConduitT () a m ()
                              -> m [a]
                              -> Property
checkInfiniteStreamProducerM' f s l =
    f (liftM snd $ evalStream $ takeS 10 $ s emptyStream)
    ===
    f (liftM (Prelude.take 10) l)

checkConsumerM' :: (Show a, Monad m, Show b, Eq b)
                => (m a -> b)
                -> ConduitT Int Void m a
                -> ([Int] -> m a)
                -> Property
checkConsumerM' f c l = forAll arbitrary $ \xs ->
    f (runConduit $ yieldMany xs .| preventFusion c)
    ===
    f (l xs)

checkStreamConsumerM' :: (Show a, Monad m, Show b, Eq b)
                      => (m a -> b)
                      -> StreamConduitT Int o m a
                      -> ([Int] -> m a)
                      -> Property
checkStreamConsumerM' f s l = forAll (arbitrary) $ \xs ->
    f (liftM snd $ evalStream $ s $ sourceListS xs emptyStream)
    ===
    f (l xs)

checkConduitT' :: (Show a, Arbitrary a, Monad m, Show c, Eq c)
               => (m [b] -> c)
               -> ConduitT a b m ()
               -> ([a] -> m [b])
               -> Property
checkConduitT' f c l = forAll arbitrary $ \xs ->
    f (runConduit $ yieldMany xs .| preventFusion c .| sinkList)
    ===
    f (l xs)

checkStreamConduitT' :: (Show a, Arbitrary a, Monad m, Show c, Eq c)
                     =>  (m [b] -> c)
                     -> StreamConduit a m b
                     -> ([a] -> m [b])
                     -> Property
checkStreamConduitT' f s l = forAll arbitrary $ \xs ->
    f (liftM fst $ evalStream $ s $ sourceListS xs emptyStream)
    ===
    f (l xs)

-- TODO: Fixing this would allow comparing conduit sinkListrs against
-- their list versions.
--
-- checkConduitResultM' :: (Show a, Arbitrary a, Monad m, Show c, Eq c)
--                      => (m ([b], r) -> c)
--                      -> ConduitT a b m r
--                      -> ([a] -> m ([b], r))
--                      -> Property
-- checkConduitResultM' f c l = FIXME forAll arbitrary $ \xs ->
--     f (runConduit $ yieldMany xs .| preventFusion c .| sinkList)
--     ===
--     f (l xs)

checkStreamConduitResultM' :: (Show a, Arbitrary a, Monad m, Show c, Eq c)
                           =>  (m ([b], r) -> c)
                           -> StreamConduitT a b m r
                           -> ([a] -> m ([b], r))
                           -> Property
checkStreamConduitResultM' f s l = forAll arbitrary $ \xs ->
    f (evalStream $ s $ sourceListS xs emptyStream)
    ===
    f (l xs)

emptyStream :: Monad m => Stream m () ()
emptyStream = Stream (\_ -> return $ Stop ()) (return ())

evalStream :: Monad m => Stream m o r -> m ([o], r)
evalStream (Stream step s0) = go =<< s0
  where
    go s = do
        res <- step s
        case res of
            Stop r -> return ([], r)
            Skip s' -> go s'
            Emit s' x -> liftM (\(l, r) -> (x:l, r)) (go s')

--------------------------------------------------------------------------------
-- Misc utilities

-- Prefer this to creating an orphan instance for Data.Monoid.Sum:

newtype Sum a = Sum a
  deriving (Eq, Show, Arbitrary)

instance Prelude.Num a => Semigroup (Sum a) where
  Sum x <> Sum y = Sum $ x Prelude.+ y
instance Prelude.Num a => Monoid (Sum a) where
  mempty = Sum 0
  mappend (Sum x) (Sum y) = Sum $ x Prelude.+ y

preventFusion :: a -> a
preventFusion = id
{-# INLINE [0] preventFusion #-}

newtype M a = M (StateT Int Identity a)
  deriving (Functor, Applicative, Monad)

instance Arbitrary a => Arbitrary (M a) where
    arbitrary = do
        f <- arbitrary
        return $ do
            s <- M get
            let (x, s') = f s
            M (put s')
            return x

runM :: M a -> (a, Int)
runM (M m) = runIdentity $ runStateT m 0

--------------------------------------------------------------------------------
-- Utilities from QuickCheck-2.7 (absent in earlier versions)

#if !MIN_VERSION_QuickCheck(2,7,0)
getBlind :: Blind a -> a
getBlind (Blind x) = x

-- | @Small x@: generates values of @x@ drawn from a small range.
-- The opposite of 'Large'.
newtype Small a = Small {getSmall :: a}
    deriving (Prelude.Ord, Prelude.Eq, Prelude.Enum, Prelude.Show, Prelude.Num)

instance Prelude.Integral a => Arbitrary (Small a) where
    arbitrary = Prelude.fmap Small arbitrarySizedIntegral
    shrink (Small x) = Prelude.map Small (shrinkIntegral x)

(===) :: (Show a, Eq a) => a -> a -> Property
x === y = whenFail
    (Prelude.fail $ Prelude.show x Prelude.++ " should match " Prelude.++ Prelude.show y)
    (x Prelude.== y)
#endif