{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules, ScopedTypeVariables, DeriveDataTypeable, ViewPatterns #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances, OverlappingInstances, GeneralizedNewtypeDeriving #-}
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,Int,Dbl)
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 b) => Show (a -> b) where show _ = "<func>"
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
instance Typeable IOMode where typeOf _ = typeOf ()
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"
main :: IO ()
main = withMain $ do
test "data\\Default.hs" 144 "findIndex ((==) a) ==> elemIndex a" $
\ a -> (findIndex ((==) a)) ==> (elemIndex a)
test "data\\Default.hs" 179 "foldr1 (&&) ==> and" $
((foldr1 (&&)) ?==> (and))
test "data\\Default.hs" 407 "sinh x / cosh x ==> tanh x" $
\ x -> (sqrt x) ==> (x ** 0.5)
test "data\\Default.hs" 154 "take i x ==> []" $
\ (NegZero i) x -> (take i x) ==> ([])
test "data\\Default.hs" 70 "head (sortBy f x) ==> minimumBy f x" $
\ (Compare f) x -> (head (sortBy f x)) ==> (minimumBy f x)