{-# 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