{-# LANGUAGE ScopedTypeVariables #-}
module Main where
import qualified Test.Tasty as Tasty
import Test.Tasty.HUnit (testCase, (@=?))
import qualified Test.Tasty.Runners as Tasty
import Test.Tasty.SmallCheck (forAll, testProperty)
import Control.Exception (throwIO)
import Control.Monad
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.State.Strict (StateT, evalStateT,
runStateT)
import qualified Data.Binary as Bin
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Functor.Identity (runIdentity)
import Data.Maybe
import Lens.Family (view)
import Lens.Family.State.Strict (zoom)
import Pipes
import qualified Pipes.Binary as PBin
import qualified Pipes.Parse as PP
import qualified Pipes.Prelude as P
--------------------------------------------------------------------------------
main :: IO ()
main = Tasty.defaultMainWithIngredients
[ Tasty.consoleTestReporter
, Tasty.listingTests
] tests
tests :: Tasty.TestTree
tests = Tasty.testGroup "root"
[ testFunctorLaws
, testPipesBinary
]
testFunctorLaws :: Tasty.TestTree
testFunctorLaws = Tasty.testGroup "Functor laws (sample test)"
[ testCase "fmap id Nothing = Nothing" $ do
fmap id Nothing @=? (Nothing :: Maybe ())
, testProperty "fmap id = id" $ do
forAll $ \(x :: [Int]) ->
fmap id x == id x
, testCase "fmap (f . g) Nothing = (fmap f . fmap g) Nothing" $ do
fmap (not . not) Nothing @=? (fmap not . fmap not) (Nothing :: Maybe Bool)
, testProperty "fmap (f . g) = fmap f . fmap g" $ do
forAll $ \(x :: [Int]) ->
fmap (odd . succ) x == (fmap odd . fmap succ) x
]
-- Just an arbitrary type that can be generated by SmallCheck.
type FunnyType = (String, (Double, (Int, (Maybe Int, Either Bool Int))))
testPipesBinary :: Tasty.TestTree
testPipesBinary = Tasty.testGroup "pipes-binary"
[ testProperty "Pipes.Binary.encode ~ Data.Binary.encode" $ do
forAll $ \(x :: FunnyType) ->
BL.toStrict (Bin.encode x) == B.concat (P.toList (PBin.encode x))
, testProperty "Pipes.Binary.decodeL ~ Data.Binary.decode" $ do
forAll $ \(x :: FunnyType) ->
let bl = Bin.encode x
bs = BL.toStrict bl
o1 = Bin.decodeOrFail bl
(o2,s2) = fmap (B.concat . P.toList)
(runIdentity $ runStateT PBin.decodeL (yield bs))
in case (o1, o2) of
(Left (s1,n1,_), Left (PBin.DecodingError n2 _)) ->
n1 == n2 && BL.toStrict s1 == s2
(Right (s1,n1,a1), Right (n2,a2)) ->
n1 == n2 && BL.toStrict s1 == s2 && a1 == (a2 :: FunnyType)
_ -> False
, testProperty "Pipes.Binary.decodeL ~ Pipes.Binary.decode" $ do
forAll $ \(x :: FunnyType) ->
let bs = BL.toStrict $ Bin.encode x
o1 = runIdentity $ evalStateT PBin.decodeL (yield bs)
o2 = runIdentity $ evalStateT PBin.decode (yield bs)
in fmap snd o1 == (o2 :: Either PBin.DecodingError FunnyType)
, testProperty "Pipes.Binary.decoded zoom" $ do
forAll $ \amx0 amx1 amx2 amx3 amx4 amx5 amx6 ->
let xs :: [FunnyType] -- I get more tests cases this way.
xs = [amx0, amx1, amx2, amx3, amx4, amx5, amx6] >>= maybe [] id
dec0 :: Monad m => MaybeT (StateT (Producer B.ByteString m a) m) ()
dec0 = do
case xs of
[] -> do
mx0' <- lift $ zoom PBin.decoded PP.draw
guard $ isNothing (mx0' :: Maybe FunnyType)
rest <- lift $ zoom PBin.decoded PP.drawAll
guard $ null (rest :: [FunnyType])
(x0:x1:x2:xrest) -> do
x0x1' <- lift $ zoom (PBin.decoded . PP.splitAt 2) PP.drawAll
guard $ [x0,x1] == x0x1'
ex2' <- lift $ PBin.decode
guard $ Right x2 == ex2'
mx3' <- lift $ zoom PBin.decoded PP.draw
case (mx3', xrest) of
(Nothing, []) -> return ()
(Just x3', (x3:rest))
| x3' == x3 -> do
rest' <- lift $ zoom PBin.decoded PP.drawAll
guard $ rest == rest'
_ -> mzero
(x0:xrest) -> do
mx0' <- lift $ zoom PBin.decoded PP.draw
guard $ Just x0 == mx0'
xrest' <- lift $ zoom PBin.decoded PP.drawAll
guard $ xrest == xrest'
p0 = for (each xs) PBin.encode
in isJust $ runIdentity $ evalStateT (runMaybeT dec0) p0
, testCase "Decoding an empty stream shouldn't fail" (do
let p :: Monad m
=> Producer Int m
(Either (PBin.DecodingError, Producer B.ByteString m ()) ())
p = view PBin.decoded (yield B.empty)
x <- runEffect (p >-> P.print)
case x of
Left (err, _) -> throwIO err
Right r -> return r )
]