{-# LANGUAGE ScopedTypeVariables
,RankNTypes
,ExistentialQuantification
,MultiParamTypeClasses
,FunctionalDependencies
,FlexibleInstances
,UndecidableInstances
,FlexibleContexts #-}
{-
Copyright (C) 2007 John Goerzen <jgoerzen@complete.org>
All rights reserved.
For license and copyright information, see the file COPYRIGHT
-}
module TestInfrastructure where
import Test.QuickCheck
import Test.QuickCheck.Test
import qualified Data.ListLike as LL
import Data.ListLike.Text
import Data.ListLike.Vector
import qualified Data.Foldable as F
import qualified Data.Vector as V
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Unboxed as VU
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import System.Random
import System.IO
import qualified Test.HUnit as HU
import Text.Printf
import Data.Word
import Data.List
import Data.Monoid
instance Arbitrary (T.Text) where
arbitrary = sized (\n -> choose (0, n) >>= myVector)
where myVector n =
do arblist <- vector n
return (LL.fromList arblist)
shrink = map LL.fromList . shrink . LL.toList
instance CoArbitrary (T.Text) where
coarbitrary l = coarbitrary (LL.toList l)
instance Arbitrary (TL.Text) where
arbitrary = sized (\n -> choose (0, n) >>= myVector)
where myVector n =
do arblist <- vector n
return (LL.fromList arblist)
shrink = map LL.fromList . shrink . LL.toList
instance CoArbitrary (TL.Text) where
coarbitrary l = coarbitrary (LL.toList l)
instance Arbitrary i => Arbitrary (V.Vector i) where
arbitrary = sized (\n -> choose (0, n) >>= myVector)
where myVector n =
do arblist <- vector n
return (LL.fromList arblist)
shrink = map LL.fromList . shrink . LL.toList
instance (CoArbitrary i) => CoArbitrary (V.Vector i) where
coarbitrary l = coarbitrary (LL.toList l)
instance (Arbitrary i, VS.Storable i) => Arbitrary (VS.Vector i) where
arbitrary = sized (\n -> choose (0, n) >>= myVector)
where myVector n =
do arblist <- vector n
return (LL.fromList arblist)
shrink = map LL.fromList . shrink . LL.toList
instance (CoArbitrary i, VS.Storable i) => CoArbitrary (VS.Vector i) where
coarbitrary l = coarbitrary (LL.toList l)
instance (Arbitrary i, VU.Unbox i) => Arbitrary (VU.Vector i) where
arbitrary = sized (\n -> choose (0, n) >>= myVector)
where myVector n =
do arblist <- vector n
return (LL.fromList arblist)
shrink = map LL.fromList . shrink . LL.toList
instance (CoArbitrary i, VU.Unbox i) => CoArbitrary (VU.Vector i) where
coarbitrary l = coarbitrary (LL.toList l)
class (Show b, Arbitrary a, Show a, Eq a, Eq b, LL.ListLike a b) => TestLL a b where
llcmp :: a -> [b] -> Property
llcmp f l = (putStrLn ("Expected: " ++ show l ++ "\nGot: " ++ show f))
`whenFail` (l == (LL.toList f))
checkLengths :: a -> [b] -> Bool
checkLengths f l = (LL.length f) == length l
instance (Arbitrary a, Show a, Eq a) => TestLL [a] a where
instance TestLL T.Text Char where
instance TestLL TL.Text Char where
instance (Arbitrary a, Show a, Eq a) => TestLL (V.Vector a) a where
instance (Arbitrary a, Show a, Eq a, VS.Storable a) => TestLL (VS.Vector a) a where
instance (Arbitrary a, Show a, Eq a, VU.Unbox a) => TestLL (VU.Vector a) a where
mapRemoveDups :: (Eq k1) => [(k1, v1)] -> [(k1, v1)]
mapRemoveDups = nubBy (\(k1, _) (k2, _) -> k1 == k2)
mkTest msg test = HU.TestLabel msg $ HU.TestCase (quickCheck test)
-- Modified from HUnit
runVerbTestText :: HU.PutText st -> HU.Test -> IO (HU.Counts, st)
runVerbTestText (HU.PutText put us) t = do
(counts, us') <- HU.performTest reportStart reportError reportFailure us t
us'' <- put (HU.showCounts counts) True us'
return (counts, us'')
where
reportStart ss us = do hPrintf stderr "\rTesting %-68s\n" (HU.showPath (HU.path ss))
put (HU.showCounts (HU.counts ss)) False us
reportError = reportProblem "Error:" "Error in: "
reportFailure = reportProblem "Failure:" "Failure in: "
reportProblem p0 p1 msg ss us = put line True us
where line = "### " ++ kind ++ path' ++ '\n' : msg
kind = if null path' then p0 else p1
path' = HU.showPath (HU.path ss)
-- | So we can test map and friends
instance Show (a -> b) where
show _ = "(a -> b)"
data (LL.ListLike f i, Arbitrary f, Arbitrary i, Show f, Show i, Eq i, Eq f) => LLTest f i =
forall t. Testable t => LLTest (f -> t)
data (LL.ListLike f i, Arbitrary f, Arbitrary i, Show f, Show i, Eq i, Eq f, LL.ListLike f' f, TestLL f' f, Show f', Eq f', Arbitrary f') =>
LLWrap f' f i =
forall t. Testable t => LLWrap (f' -> t)
w :: TestLL f i => String -> LLTest f i -> HU.Test
w msg f = case f of
LLTest theTest -> mkTest msg theTest
ws :: (LL.StringLike f, TestLL f i) => String -> LLTest f i -> HU.Test
ws = w
wwrap :: (TestLL f i, TestLL f' f) => String -> LLWrap f' f i -> HU.Test
wwrap msg f = case f of
LLWrap theTest -> mkTest msg theTest
t :: forall f t i. (TestLL f i, Arbitrary f, Arbitrary i, Show f, Eq f, Testable t) => (f -> t) -> LLTest f i
t = LLTest
-- | all props, wrapped list
apw :: String -> (forall f' f i. (TestLL f i, Show i, Eq i, LL.ListLike f i, Eq f, Show f, Arbitrary f, Arbitrary i, LL.ListLike f' f, Show f', TestLL f' f, Arbitrary f', Eq f') => LLWrap f' f i) -> HU.Test
apw msg x = HU.TestLabel msg $ HU.TestList $
[wwrap "wrap (Vector (Vector Int))" (x::LLWrap (V.Vector (V.Vector Int)) (V.Vector Int) Int) ]
-- | all props, 1 args: full
apf :: String -> (forall f i. (Ord i, TestLL f i, Show i, Eq i, VS.Storable i, VU.Unbox i, LL.ListLike f i, Eq f, Show f, Arbitrary f, Arbitrary i, CoArbitrary f, CoArbitrary i) => LLTest f i) -> HU.Test
apf msg x = HU.TestLabel msg $ HU.TestList $
[w "Vector Int" (x::LLTest (V.Vector Int) Int),
w "StorableVector Int" (x::LLTest (VS.Vector Int) Int),
w "UnboxVector Int" (x::LLTest (VU.Vector Int) Int),
w "Vector Bool" (x::LLTest (V.Vector Bool) Bool),
w "StorableVector Bool" (x::LLTest (VS.Vector Bool) Bool),
w "UnboxVector Bool" (x::LLTest (VU.Vector Bool) Bool),
w "Text" (x::LLTest T.Text Char),
w "Text.Lazy" (x::LLTest TL.Text Char)
]
-- | all props, 1 args: full
aps :: String -> (forall f i. (Ord i, TestLL f i, Show i, Eq i, VU.Unbox i, LL.StringLike f, LL.ListLike f i, Eq f, Show f, Arbitrary f, Arbitrary i) => LLTest f i) -> HU.Test
aps msg x = HU.TestLabel msg $ HU.TestList $
[ w "Text" (x::LLTest T.Text Char),
w "Text.Lazy" (x::LLTest TL.Text Char),
w "Vector Char" (x::LLTest (V.Vector Char) Char),
w "Vector.Unbox Char" (x::LLTest (VU.Vector Char) Char)
]