@@ -1,4 +1,5 @@
1−{-# LANGUAGE BangPatterns, FlexibleInstances, TypeSynonymInstances #-}
1+{-# LANGUAGE BangPatterns, FlexibleInstances, ScopedTypeVariables,
2+ TypeSynonymInstances #-}
23{-# OPTIONS_GHC -fno-enable-rewrite-rules #-}
34
45import Test.QuickCheck
@@ -30,14 +31,20 @@ import Prelude hiding (catch)
3031
3132import QuickCheckUtils
3233
33−-- If a pure property threatens to crash, wrap it with this to keep
34−-- QuickCheck from bombing out.
35−crashy :: a -> a -> a
36−{-# NOINLINE crashy #-}
37−crashy onException p = unsafePerformIO $
38− (return $! p) `catch` \e ->
39− let types = e :: SomeException
40− in trace ("*** Exception: " ++ show e) return onException
34+-- Ensure that two potentially bottom values (in the sense of crashing
35+-- for some inputs, not looping infinitely) either both crash, or both
36+-- give comparable results for some input.
37+(=^=) :: (Eq a, Show a) => a -> a -> Bool
38+{-# NOINLINE (=^=) #-}
39+i =^= j = unsafePerformIO $ do
40+ x <- try (return $! i)
41+ y <- try (return $! j)
42+ case (x,y) of
43+ (Left (_ :: SomeException), Left (_ :: SomeException))
44+ -> return True
45+ (Right a, Right b) -> return (a == b)
46+ e -> trace ("*** Divergence: " ++ show e) return False
47+infix 4 =^=
4148
4249tracer f a = let r = f a
4350 in trace (show r) r
@@ -91,8 +98,8 @@ instance Stringy TL.Text where
9198 splitAtS = TL.splitAt . fromIntegral
9299
93100-- Do two functions give the same answer?
94−eq :: (Eq a) => (t -> a) -> (t -> a) -> t -> Bool
95−eq a b s = crashy False $ a s == b s
101+eq :: (Eq a, Show a) => (t -> a) -> (t -> a) -> t -> Bool
102+eq a b s = a s =^= b s
96103
97104-- What about with the RHS packed?
98105eqP :: (Eq a, Show a, Stringy s) =>
@@ -109,26 +116,9 @@ eqP a b s w = eq "orig" (a s) (b t) &&
109116 m | l == 0 = n
110117 | otherwise = n `mod` l
111118 n = fromIntegral w
112− eq s a b | crashy False $ a == b = True
119+ eq s a b | a =^= b = True
113120 | otherwise = trace (s ++ ": " ++ show a ++ " /= " ++ show b) False
114121
115−-- Or with the string non-empty, and the RHS packed?
116−eqEP :: (Eq a, Stringy s) =>
117− (String -> a) -> (s -> a) -> NotEmpty String -> Word8 -> Bool
118−eqEP a b e w = a s == b t &&
119− a s == b mini &&
120− (null sa || a sa == b ta) &&
121− (null sb || a sb == b tb)
122− where (sa,sb) = splitAt m s
123− (ta,tb) = splitAtS m t
124− t = packS s
125− mini = packSChunkSize 10 s
126− l = length s
127− m | l == 0 = n
128− | otherwise = n `mod` l
129− n = fromIntegral w
130− s = notEmpty e
131−
132122prop_S_Eq s = (s==) `eq` ((S.stream s==) . S.stream)
133123prop_T_Eq s = (s==) `eq` ((T.pack s==) . T.pack)
134124prop_TL_Eq s = (s==) `eq` ((TL.pack s==) . TL.pack)
@@ -162,26 +152,26 @@ prop_T_uncons s = uncons `eqP` (fmap (second unpackS) . T.uncons)
162152 where types = s :: String
163153prop_TL_uncons s = uncons `eqP` (fmap (second unpackS) . TL.uncons)
164154 where types = s :: String
165−prop_S_head = head `eqEP` S.head
166−prop_T_head = head `eqEP` T.head
167−prop_TL_head = head `eqEP` TL.head
168−prop_S_last = last `eqEP` S.last
169−prop_T_last = last `eqEP` T.last
170−prop_TL_last = last `eqEP` TL.last
171−prop_S_tail = tail `eqEP` (unpackS . S.tail)
172−prop_T_tail = tail `eqEP` (unpackS . T.tail)
173−prop_TL_tail = tail `eqEP` (unpackS . TL.tail)
174−prop_S_init = init `eqEP` (unpackS . S.init)
175−prop_T_init = init `eqEP` (unpackS . T.init)
176−prop_TL_init = init `eqEP` (unpackS . TL.init)
177−prop_S_null = null `eqP` S.null
178−prop_T_null = null `eqP` T.null
179−prop_TL_null = null `eqP` TL.null
180−prop_S_length = length `eqP` S.length
181−prop_T_length = length `eqP` T.length
182−prop_TL_length = length `eqP` (fromIntegral . TL.length)
183−prop_T_map f = map f `eqP` (unpackS . T.map f)
184−prop_TL_map f = map f `eqP` (unpackS . TL.map f)
155+prop_S_head = head `eqP` S.head
156+prop_T_head = head `eqP` T.head
157+prop_TL_head = head `eqP` TL.head
158+prop_S_last = last `eqP` S.last
159+prop_T_last = last `eqP` T.last
160+prop_TL_last = last `eqP` TL.last
161+prop_S_tail = tail `eqP` (unpackS . S.tail)
162+prop_T_tail = tail `eqP` (unpackS . T.tail)
163+prop_TL_tail = tail `eqP` (unpackS . TL.tail)
164+prop_S_init = init `eqP` (unpackS . S.init)
165+prop_T_init = init `eqP` (unpackS . T.init)
166+prop_TL_init = init `eqP` (unpackS . TL.init)
167+prop_S_null = null `eqP` S.null
168+prop_T_null = null `eqP` T.null
169+prop_TL_null = null `eqP` TL.null
170+prop_S_length = length `eqP` S.length
171+prop_T_length = length `eqP` T.length
172+prop_TL_length = length `eqP` (fromIntegral . TL.length)
173+prop_T_map f = map f `eqP` (unpackS . T.map f)
174+prop_TL_map f = map f `eqP` (unpackS . TL.map f)
185175prop_T_intercalate c = L.intercalate c `eq` (unpackS . T.intercalate (packS c) . map packS)
186176prop_TL_intercalate c = L.intercalate c `eq` (unpackS . TL.intercalate (TL.pack c) . map TL.pack)
187177prop_T_intersperse c = L.intersperse c `eqP` (unpackS . T.intersperse c)
@@ -222,46 +212,46 @@ prop_T_justifyLeft k c = justifyLeft k c `eqP` (unpackS . T.justifyLeft k c)
222212prop_T_justifyRight k c = jr k c `eqP` (unpackS . T.justifyRight k c)
223213 where jr k c s = replicate (k - length s) c ++ s
224214
225−prop_T_foldl f z = L.foldl f z `eqP` (T.foldl f z)
215+prop_T_foldl f z = L.foldl f z `eqP` (T.foldl f z)
226216 where types = f :: Char -> Char -> Char
227−prop_TL_foldl f z = L.foldl f z `eqP` (TL.foldl f z)
217+prop_TL_foldl f z = L.foldl f z `eqP` (TL.foldl f z)
228218 where types = f :: Char -> Char -> Char
229−prop_T_foldl' f z = L.foldl' f z `eqP` T.foldl' f z
219+prop_T_foldl' f z = L.foldl' f z `eqP` T.foldl' f z
230220 where types = f :: Char -> Char -> Char
231−prop_TL_foldl' f z = L.foldl' f z `eqP` TL.foldl' f z
221+prop_TL_foldl' f z = L.foldl' f z `eqP` TL.foldl' f z
232222 where types = f :: Char -> Char -> Char
233−prop_T_foldl1 f = L.foldl1 f `eqEP` T.foldl1 f
234−prop_TL_foldl1 f = L.foldl1 f `eqEP` TL.foldl1 f
235−prop_T_foldl1' f = L.foldl1' f `eqEP` T.foldl1' f
236−prop_TL_foldl1' f = L.foldl1' f `eqEP` TL.foldl1' f
237−prop_T_foldr f z = L.foldr f z `eqP` T.foldr f z
223+prop_T_foldl1 f = L.foldl1 f `eqP` T.foldl1 f
224+prop_TL_foldl1 f = L.foldl1 f `eqP` TL.foldl1 f
225+prop_T_foldl1' f = L.foldl1' f `eqP` T.foldl1' f
226+prop_TL_foldl1' f = L.foldl1' f `eqP` TL.foldl1' f
227+prop_T_foldr f z = L.foldr f z `eqP` T.foldr f z
238228 where types = f :: Char -> Char -> Char
239−prop_TL_foldr f z = L.foldr f z `eqP` TL.foldr f z
229+prop_TL_foldr f z = L.foldr f z `eqP` TL.foldr f z
240230 where types = f :: Char -> Char -> Char
241−prop_T_foldr1 f = L.foldr1 f `eqEP` T.foldr1 f
242−prop_TL_foldr1 f = L.foldr1 f `eqEP` TL.foldr1 f
231+prop_T_foldr1 f = L.foldr1 f `eqP` T.foldr1 f
232+prop_TL_foldr1 f = L.foldr1 f `eqP` TL.foldr1 f
243233
244234prop_T_concat = L.concat `eq` (unpackS . T.concat . map packS)
245235prop_TL_concat = L.concat `eq` (unpackS . TL.concat . map TL.pack)
246−prop_T_concatMap f = L.concatMap f `eqP` (unpackS . T.concatMap (packS . f))
247−prop_TL_concatMap f = L.concatMap f `eqP` (unpackS . TL.concatMap (TL.pack . f))
248−prop_T_any p = L.any p `eqP` T.any p
249−prop_TL_any p = L.any p `eqP` TL.any p
250−prop_T_all p = L.all p `eqP` T.all p
251−prop_TL_all p = L.all p `eqP` TL.all p
252−prop_T_maximum = L.maximum `eqEP` T.maximum
253−prop_TL_maximum = L.maximum `eqEP` TL.maximum
254−prop_T_minimum = L.minimum `eqEP` T.minimum
255−prop_TL_minimum = L.minimum `eqEP` TL.minimum
256−
257−prop_T_scanl f z = L.scanl f z `eqP` (unpackS . T.scanl f z)
258−prop_TL_scanl f z = L.scanl f z `eqP` (unpackS . TL.scanl f z)
259−prop_T_scanl1 f = L.scanl1 f `eqP` (unpackS . T.scanl1 f)
260−prop_TL_scanl1 f = L.scanl1 f `eqP` (unpackS . TL.scanl1 f)
261−prop_T_scanr f z = L.scanr f z `eqP` (unpackS . T.scanr f z)
262−prop_TL_scanr f z = L.scanr f z `eqP` (unpackS . TL.scanr f z)
263−prop_T_scanr1 f = L.scanr1 f `eqP` (unpackS . T.scanr1 f)
264−prop_TL_scanr1 f = L.scanr1 f `eqP` (unpackS . TL.scanr1 f)
236+prop_T_concatMap f = L.concatMap f `eqP` (unpackS . T.concatMap (packS . f))
237+prop_TL_concatMap f = L.concatMap f `eqP` (unpackS . TL.concatMap (TL.pack . f))
238+prop_T_any p = L.any p `eqP` T.any p
239+prop_TL_any p = L.any p `eqP` TL.any p
240+prop_T_all p = L.all p `eqP` T.all p
241+prop_TL_all p = L.all p `eqP` TL.all p
242+prop_T_maximum = L.maximum `eqP` T.maximum
243+prop_TL_maximum = L.maximum `eqP` TL.maximum
244+prop_T_minimum = L.minimum `eqP` T.minimum
245+prop_TL_minimum = L.minimum `eqP` TL.minimum
246+
247+prop_T_scanl f z = L.scanl f z `eqP` (unpackS . T.scanl f z)
248+prop_TL_scanl f z = L.scanl f z `eqP` (unpackS . TL.scanl f z)
249+prop_T_scanl1 f = L.scanl1 f `eqP` (unpackS . T.scanl1 f)
250+prop_TL_scanl1 f = L.scanl1 f `eqP` (unpackS . TL.scanl1 f)
251+prop_T_scanr f z = L.scanr f z `eqP` (unpackS . T.scanr f z)
252+prop_TL_scanr f z = L.scanr f z `eqP` (unpackS . TL.scanr f z)
253+prop_T_scanr1 f = L.scanr1 f `eqP` (unpackS . T.scanr1 f)
254+prop_TL_scanr1 f = L.scanr1 f `eqP` (unpackS . TL.scanr1 f)
265255
266256prop_T_mapAccumL f z = L.mapAccumL f z `eqP` (second unpackS . T.mapAccumL f z)
267257 where types = f :: Int -> Char -> (Int,Char)