131 lines
4.7 KiB
Haskell
131 lines
4.7 KiB
Haskell
{-# 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
|
|
_eval_ = 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
|