Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 239 lines (198 sloc) 9.439 kb
b9db356 @jgoerzen Moved out TestInfrastructure
authored
1 {-
2 Copyright (C) 2007 John Goerzen <jgoerzen@complete.org>
3
4 All rights reserved.
5
6 For license and copyright information, see the file COPYRIGHT
7
8 -}
9
50ae5dd @jgoerzen Added comment
authored
10 -- FIXME -- better code is in offlineimap v7 branch
b9db356 @jgoerzen Moved out TestInfrastructure
authored
11 module TestInfrastructure where
12
13 import Test.QuickCheck
14 import Test.QuickCheck.Batch
15 import qualified Data.ByteString as BS
16 import qualified Data.ByteString.Lazy as BSL
17 import qualified Data.ListLike as LL
18 import qualified Data.Map as Map
19 import qualified Data.Array as A
20 import qualified Data.Foldable as F
21 import System.Random
a6fb3d0 @jgoerzen Made "exhaustion" a warning, not a failure
authored
22 import System.IO
b2a8026 @jgoerzen import HUnit qualified
authored
23 import qualified Test.HUnit as HU
b9db356 @jgoerzen Moved out TestInfrastructure
authored
24 import Text.Printf
25 import Data.Word
26 import Data.List
27 import Data.Monoid
28
dd48389 @jgoerzen Add more tests.
authored
29 {-
30 #if defined __HUGS__
31 -}
32 instance (Arbitrary a) => Arbitrary (Maybe a) where
33 arbitrary = sized arbMaybe
34 where
35 arbMaybe 0 = return Nothing
36 arbMaybe n = fmap Just (resize (n-1) arbitrary)
37 coarbitrary Nothing = variant 0
38 coarbitrary (Just x) = variant 1 . coarbitrary x
39 {-
40 #endif
41 -}
42
de48cb0 @jgoerzen Beautifying tests
authored
43 (@=?) :: (Eq a, Show a) => a -> a -> Result
44 expected @=? actual =
45 Result {ok = Just (expected == actual),
46 arguments = ["Result: expected " ++ show expected ++ ", got " ++ show actual],
47 stamp = []}
48
8f55271 @jgoerzen Beautifying tests
authored
49 (@?=) :: (Eq a, Show a) => a -> a -> Result
50 (@?=) = flip (@=?)
51
672d458 @jgoerzen Compiles with -fallow-overlapping-instances -fallow-undecidable-instance...
authored
52 instance (LL.ListLike f i, Arbitrary i) => Arbitrary f where
53 arbitrary = sized (\n -> choose (0, n) >>= myVector)
54 where myVector n =
02d0c7e @jgoerzen Trying to fix Hugs errors
authored
55 do arblist <- vector n
56 return (LL.fromList arblist)
d6ba122 @jgoerzen Compiles in hugs
authored
57 coarbitrary l = coarbitrary (LL.toList l)
672d458 @jgoerzen Compiles with -fallow-overlapping-instances -fallow-undecidable-instance...
authored
58
de48cb0 @jgoerzen Beautifying tests
authored
59 class (Show b, Arbitrary a, Show a, Eq a, Eq b, LL.ListLike a b) => TestLL a b where
1543e7c @jgoerzen added checkLengths to permit a more broad length checking
authored
60 -- | Compare a ListLike to a list using any local conversions needed
de48cb0 @jgoerzen Beautifying tests
authored
61 llcmp :: a -> [b] -> Result
62 llcmp f l = l @=? (LL.toList f)
fcee5d8 @jgoerzen trying
authored
63
1543e7c @jgoerzen added checkLengths to permit a more broad length checking
authored
64 -- | Check the lenghts of the two items. True if they should be considered
65 -- to match.
66 checkLengths :: a -> [b] -> Bool
67 checkLengths f l = (LL.length f) == length l
68
fcee5d8 @jgoerzen trying
authored
69 instance (Arbitrary a, Show a, Eq a) => TestLL [a] a where
de48cb0 @jgoerzen Beautifying tests
authored
70 llcmp x y = y @=? x
fcee5d8 @jgoerzen trying
authored
71
72 instance (Arbitrary a, Show a, Eq a) => TestLL (MyList a) a where
de48cb0 @jgoerzen Beautifying tests
authored
73 llcmp (MyList x) l = l @=? x
fcee5d8 @jgoerzen trying
authored
74
9ece602 @jgoerzen trying to get maps to work
authored
75 instance TestLL BS.ByteString Word8 where
76
77 instance TestLL BSL.ByteString Word8 where
78
79 instance (Arbitrary a, Show a, Eq a) => TestLL (A.Array Int a) a where
80
fcee5d8 @jgoerzen trying
authored
81 instance (Show k, Show v, Arbitrary k, Arbitrary v, Ord v, Ord k) => TestLL (Map.Map k v) (k, v) where
fa95ba4 @jgoerzen More test beautification
authored
82 llcmp m l =
9a79484 @jgoerzen Working on it
authored
83 if mycmp (Map.toList m) && mychk l
fa95ba4 @jgoerzen More test beautification
authored
84 then l @=? l -- True
85 else l @=? (Map.toList m) -- False
86 where mycmp [] = True
ac9f50a @jgoerzen Fixed Map errors so far
authored
87 mycmp (x:xs) = if elem x l
88 then mycmp xs
fa95ba4 @jgoerzen More test beautification
authored
89 else False
9a79484 @jgoerzen Working on it
authored
90 mychk [] = True
91 mychk ((k, _):xs) = if Map.member k m then mychk xs else False
1543e7c @jgoerzen added checkLengths to permit a more broad length checking
authored
92 -- FIXME: should find a way to use LL.length instead of Map.size here
93 checkLengths m l = Map.size m == length (mapRemoveDups l)
94
95 mapRemoveDups :: (Eq k1) => [(k1, v1)] -> [(k1, v1)]
96 mapRemoveDups = nubBy (\(k1, _) (k2, _) -> k1 == k2)
97
b9db356 @jgoerzen Moved out TestInfrastructure
authored
98 data MyList a = MyList [a]
865542c @jgoerzen Test maximum, all
authored
99 deriving (Ord, Eq, Show)
b9db356 @jgoerzen Moved out TestInfrastructure
authored
100
101 instance LL.FoldableLL (MyList a) a where
102 foldr f i (MyList x) = foldr f i x
103 foldl f i (MyList x) = foldl f i x
104 foldr1 f (MyList x) = foldr1 f x
105 foldl1 f (MyList x) = foldl1 f x
106
107 instance Monoid (MyList a) where
108 mempty = MyList []
109 mappend (MyList x) (MyList y) = MyList (x ++ y)
110
111 instance LL.ListLike (MyList a) a where
112 singleton x = MyList [x]
113 head (MyList x) = head x
114 tail (MyList x) = MyList (tail x)
115 null (MyList x) = null x
116
7fac63f @jgoerzen Now test strings
authored
117 instance LL.StringLike (MyList Char) where
118 toString (MyList x) = x
119 fromString x = MyList x
120
b9db356 @jgoerzen Moved out TestInfrastructure
authored
121 instance Arbitrary Word8 where
a7a89c9 @jgoerzen Redid Word8 instance of Arbitrary
authored
122 arbitrary = sized $ \n -> choose (0, min (fromIntegral n) maxBound)
123 coarbitrary n = variant (if n >= 0 then 2 * x else 2 * x + 1)
124 where x = abs . fromIntegral $ n
b9db356 @jgoerzen Moved out TestInfrastructure
authored
125
98a8d2a @jgoerzen checkpointing
authored
126 instance Arbitrary Char where
95835b6 @jgoerzen Adjusted Char arbitrary instance for Hugs
authored
127 arbitrary = sized $ \n -> choose (toEnum 0, min (toEnum n) maxBound)
128 coarbitrary n = variant (if (fromEnum n) >= 0 then toEnum (2 * x) else toEnum (2 * x + 1))
129 where (x::Int) = abs . fromEnum $ n
98a8d2a @jgoerzen checkpointing
authored
130
b9db356 @jgoerzen Moved out TestInfrastructure
authored
131 instance Random Word8 where
132 randomR (a, b) g = (\(x, y) -> (fromInteger x, y)) $
133 randomR (toInteger a, toInteger b) g
134 random g = randomR (minBound, maxBound) g
135
6160707 @jgoerzen Made it more obvious how to debug the tests
authored
136 testoptions = defOpt {length_of_tests = 0, debug_tests = False}
137
138 mkTest msg test = HU.TestLabel msg $ HU.TestCase $ (run test testoptions >>= checResult)
b9db356 @jgoerzen Moved out TestInfrastructure
authored
139 where checResult (TestOk x y z) = printmsg x y >> return ()
a6fb3d0 @jgoerzen Made "exhaustion" a warning, not a failure
authored
140 checResult (TestExausted x y z) =
141 do hPrintf stderr "\r%-78s\n" $
142 "Warning: Arguments exhausted after " ++ show y ++ " cases."
143 return ()
fa95ba4 @jgoerzen More test beautification
authored
144 checResult (TestFailed x y) = HU.assertFailure $
145 "Test Failure\n" ++
146 "Arguments: " ++
147 (concat . intersperse "\n " $ x) ++
148 "\nTest No.: " ++ show y
b2a8026 @jgoerzen import HUnit qualified
authored
149 checResult (TestAborted x) = HU.assertFailure (show x)
380de10 @jgoerzen Test enhancements
authored
150 printmsg x y
a6fb3d0 @jgoerzen Made "exhaustion" a warning, not a failure
authored
151 | False = hPrintf stderr "\r%-78s\r"
380de10 @jgoerzen Test enhancements
authored
152 (msg ++ " " ++ x ++ " (" ++ show y ++ " cases)")
153 | otherwise = return ()
154
155 -- Modified from HUnit
156 runVerbTestText :: HU.PutText st -> HU.Test -> IO (HU.Counts, st)
157 runVerbTestText (HU.PutText put us) t = do
158 (counts, us') <- HU.performTest reportStart reportError reportFailure us t
159 us'' <- put (HU.showCounts counts) True us'
160 return (counts, us'')
161 where
a6fb3d0 @jgoerzen Made "exhaustion" a warning, not a failure
authored
162 reportStart ss us = do hPrintf stderr "\rTesting %-68s\n" (HU.showPath (HU.path ss))
380de10 @jgoerzen Test enhancements
authored
163 put (HU.showCounts (HU.counts ss)) False us
164 reportError = reportProblem "Error:" "Error in: "
165 reportFailure = reportProblem "Failure:" "Failure in: "
166 reportProblem p0 p1 msg ss us = put line True us
167 where line = "### " ++ kind ++ path' ++ '\n' : msg
168 kind = if null path' then p0 else p1
169 path' = HU.showPath (HU.path ss)
170
b9db356 @jgoerzen Moved out TestInfrastructure
authored
171
eb41dc4 @jgoerzen Now added test for map
authored
172 -- | So we can test map and friends
173 instance Show (a -> b) where
174 show _ = "(a -> b)"
175
f22fade @jgoerzen checkpointing
authored
176 data (LL.ListLike f i, Arbitrary f, Arbitrary i, Show f, Show i, Eq i, Eq f) => LLTest f i =
b2a8026 @jgoerzen import HUnit qualified
authored
177 forall t. Testable t => LLTest (f -> t)
6bbbde6 @jgoerzen Checkpointing
authored
178
406fab3 @jgoerzen Fixed for hugs
authored
179 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') =>
180 LLWrap f' f i =
181 forall t. Testable t => LLWrap (f' -> t)
182
b2a8026 @jgoerzen import HUnit qualified
authored
183 w :: TestLL f i => String -> LLTest f i -> HU.Test
c1ed29d @jgoerzen Renaming some functions
authored
184 w msg f = case f of
672d458 @jgoerzen Compiles with -fallow-overlapping-instances -fallow-undecidable-instance...
authored
185 LLTest theTest -> mkTest msg theTest
186
98a8d2a @jgoerzen checkpointing
authored
187 ws :: (LL.StringLike f, TestLL f i) => String -> LLTest f i -> HU.Test
188 ws = w
189
406fab3 @jgoerzen Fixed for hugs
authored
190 wwrap :: (TestLL f i, TestLL f' f) => String -> LLWrap f' f i -> HU.Test
191 wwrap msg f = case f of
192 LLWrap theTest -> mkTest msg theTest
193
b2a8026 @jgoerzen import HUnit qualified
authored
194 t :: forall f t i. (TestLL f i, Arbitrary f, Arbitrary i, Show f, Eq f, Testable t) => (f -> t) -> LLTest f i
c1ed29d @jgoerzen Renaming some functions
authored
195 t = LLTest
6bbbde6 @jgoerzen Checkpointing
authored
196
56d7870 @jgoerzen tests pass in ghc
authored
197 -- | all props, wrapped list
406fab3 @jgoerzen Fixed for hugs
authored
198 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
7642a40 @jgoerzen compiles
authored
199 apw msg x = HU.TestLabel msg $ HU.TestList $
dd48389 @jgoerzen Add more tests.
authored
200 [wwrap "wrap [[Int]]" (x::LLWrap [[Int]] [Int] Int),
201 wwrap "wrap MyList (MyList Int)" (x::LLWrap (MyList (MyList Int)) (MyList Int) Int),
202 wwrap "wrap Array (Array Int)" (x::LLWrap (A.Array Int (A.Array Int Int)) (A.Array Int Int) Int),
203 wwrap "wrap Array [Int]" (x::LLWrap (A.Array Int [Int]) [Int] Int)
406fab3 @jgoerzen Fixed for hugs
authored
204 ]
56d7870 @jgoerzen tests pass in ghc
authored
205
98a8d2a @jgoerzen checkpointing
authored
206 -- | all props, 1 args: full
865542c @jgoerzen Test maximum, all
authored
207 apf :: String -> (forall f i. (Ord i, TestLL f i, Show i, Eq i, LL.ListLike f i, Eq f, Show f, Arbitrary f, Arbitrary i) => LLTest f i) -> HU.Test
b2a8026 @jgoerzen import HUnit qualified
authored
208 apf msg x = HU.TestLabel msg $ HU.TestList $
c1ed29d @jgoerzen Renaming some functions
authored
209 [w "[Int]" (x::LLTest [Int] Int),
210 w "MyList Int" (x::LLTest (MyList Int) Int),
d7ff7ab @jgoerzen test tweaking for hugs
authored
211 w "String" (x::LLTest String Char),
c1ed29d @jgoerzen Renaming some functions
authored
212 w "[Bool]" (x::LLTest [Bool] Bool),
213 w "MyList Bool" (x::LLTest (MyList Bool) Bool),
214 w "Map Int Int" (x::LLTest (Map.Map Int Int) (Int, Int)),
215 w "Map Bool Int" (x::LLTest (Map.Map Bool Int) (Bool, Int)),
216 w "Map Int Bool" (x::LLTest (Map.Map Int Bool) (Int, Bool)),
217 w "Map Bool Bool" (x::LLTest (Map.Map Bool Bool) (Bool, Bool)),
218 w "ByteString" (x::LLTest BS.ByteString Word8),
219 w "ByteString.Lazy" (x::LLTest BSL.ByteString Word8),
220 w "Array Int Int" (x::LLTest (A.Array Int Int) Int),
dd48389 @jgoerzen Add more tests.
authored
221 w "Array Int Bool" (x::LLTest (A.Array Int Bool) Bool),
222 w "[[Int]]" (x::LLTest [[Int]] [Int]),
223 w "MyList (MyList Int)" (x::LLTest (MyList (MyList Int)) (MyList Int)),
224 w "[MyList Int]" (x::LLTest [MyList Int] (MyList Int)),
225 w "Array [Int]" (x::LLTest (A.Array Int [Int]) [Int]),
226 w "Array (Array Int)" (x::LLTest (A.Array Int (A.Array Int Int)) (A.Array Int Int)),
227 w "Array (Just Int)" (x::LLTest (A.Array Int (Maybe Int)) (Maybe Int))
6bbbde6 @jgoerzen Checkpointing
authored
228 ]
98a8d2a @jgoerzen checkpointing
authored
229
230 -- | all props, 1 args: full
231 aps :: String -> (forall f i. (Ord i, TestLL f i, Show i, Eq i, LL.StringLike f, LL.ListLike f i, Eq f, Show f, Arbitrary f, Arbitrary i) => LLTest f i) -> HU.Test
232 aps msg x = HU.TestLabel msg $ HU.TestList $
233 [w "String" (x::LLTest String Char),
7fac63f @jgoerzen Now test strings
authored
234 w "MyList Char" (x::LLTest (MyList Char) Char),
98a8d2a @jgoerzen checkpointing
authored
235 w "ByteString" (x::LLTest BS.ByteString Word8),
236 w "ByteString.Lazy" (x::LLTest BSL.ByteString Word8),
237 w "Array Int Char" (x::LLTest (A.Array Int Char) Char)
238 ]
Something went wrong with that request. Please try again.