1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules, ScopedTypeVariables, DeriveDataTypeable, ViewPatterns #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
-- | Used with --quickcheck
module HLint_QuickCheck(module HLint_QuickCheck, module X) where
import System.IO.Unsafe
import Data.Typeable
import Data.List
import Data.Maybe
import Data.IORef
import Control.Exception
import Control.Monad
import System.IO
import Control.Concurrent.Chan
import System.Mem.Weak(Weak)
import Test.QuickCheck hiding ((==>))
import Test.QuickCheck.Test hiding (test)
import Test.QuickCheck.Modifiers as X
default(Maybe Bool,[Bool],Int,Dbl)
-- We need a Show instance that nails down the sides, so defaulting works.
-- The one from Text.Show.Functions is insufficient.
instance (Show a, Show b) => Show (a -> b) where show _ = "<func>"
newtype Dbl = Dbl Double deriving (Enum,Floating,Fractional,Num,Read,Real,RealFloat,RealFrac,Show,Typeable,Arbitrary,CoArbitrary)
instance Eq Dbl where
Dbl a == Dbl b | isNaN a && isNaN b = True
| otherwise = abs (a - b) < 1e-4 || let s = a+b in s /= 0 && abs ((a-b)/s) < 1e-8
instance Ord Dbl where
compare a b | a == b = EQ
compare (Dbl a) (Dbl b) = compare a b
newtype NegZero a = NegZero a deriving (Typeable, Show)
instance (Num a, Arbitrary a) => Arbitrary (NegZero a) where
arbitrary = fmap (NegZero . negate . abs) arbitrary
newtype Nat a = Nat a deriving (Typeable, Show)
instance (Num a, Arbitrary a) => Arbitrary (Nat a) where
arbitrary = fmap (Nat . abs) arbitrary
newtype Compare a = Compare (a -> a -> Ordering) deriving (Typeable, Show)
instance (Ord a, Arbitrary a) => Arbitrary (Compare a) where
arbitrary = fmap (\b -> Compare $ (if b then flip else id) compare) arbitrary
instance Show a => Show (IO a) where show _ = "<IO>"
instance Show a => Show (Weak a) where show _ = "<Weak>"
instance Show a => Show (Chan a) where show _ = "<Chan>"
instance Eq (IO a) where _ == _ = True
instance Eq SomeException where a == b = show a == show b
deriving instance Typeable IOMode
instance Arbitrary Handle where arbitrary = elements [stdin, stdout, stderr]
instance CoArbitrary Handle where coarbitrary _ = variant 0
instance Arbitrary IOMode where arbitrary = elements [ReadMode,WriteMode,AppendMode,ReadWriteMode]
instance Arbitrary a => Arbitrary (IO a) where arbitrary = fmap return arbitrary
instance Arbitrary (Chan a) where arbitrary = return $ unsafePerformIO newChan
instance Exception (Maybe Bool)
data Test a = Test Bool a a deriving (Show, Typeable)
instance Functor Test where
fmap f (Test a b c) = Test a (f b) (f c)
a ==> b = Test False a b
a ?==> b = Test True a b
class Testable2 a where
property2 :: Test a -> Property
instance Testable2 a => Testable (Test a) where
property = property2
instance Eq a => Testable2 a where
property2 (Test bx (catcher -> x) (catcher -> y)) =
property $ (bx && isNothing x) || x == y
instance (Arbitrary a, Show a, Testable2 b) => Testable2 (a -> b) where
property2 x = property $ \a -> fmap ($ a) x
{-# NOINLINE bad #-}
bad :: IORef Int
bad = unsafePerformIO $ newIORef 0
test :: (Show p, Testable p, Typeable p) => FilePath -> Int -> String -> p -> IO ()
test file line hint p = do
res <- quickCheckWithResult stdArgs{chatty=False} p
unless (isSuccess res) $ do
putStrLn $ "\n" ++ file ++ ":" ++ show line ++ ": " ++ hint
print $ typeOf p
putStr $ output res
modifyIORef bad (+1)
catcher :: a -> Maybe a
catcher x = unsafePerformIO $ do
res <- try $ evaluate x
return $ case res of
Left (_ :: SomeException) -> Nothing
Right v -> Just v
_noParen_ = id
withMain :: IO () -> IO ()
withMain act = do
act
bad <- readIORef bad
when (bad > 0) $
error $ "Failed " ++ show bad ++ " tests"
---------------------------------------------------------------------
-- EXAMPLES
main :: IO ()
main = withMain $ do
let t = \ a -> (findIndex ((==) a)) ==> (elemIndex a)
in test "data\\Default.hs" 144 "findIndex ((==) a) ==> elemIndex a" t
let t = ((foldr1 (&&)) ?==> (and))
in test "data\\Default.hs" 179 "foldr1 (&&) ==> and" t
let t = \ x -> (sqrt x) ==> (x ** 0.5)
in test "data\\Default.hs" 407 "sinh x / cosh x ==> tanh x" t
let t = \ (NegZero i) x -> (take i x) ==> ([])
in test "data\\Default.hs" 154 "take i x ==> []" t
let t = \ (Compare f) x -> (head (sortBy f x)) ==> (minimumBy f x)
in test "data\\Default.hs" 70 "head (sortBy f x) ==> minimumBy f x" t
let t = \ f -> ((f $)) ==> (f)
in test "data\\Default.hs" 218 "(f $) ==> f" t
|
