```{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances -fallow-incoherent-instances -XRank2Types -fno-monomorphism-restriction #-}

module Test.GMap.Utils where

import Test.QuickCheck

import Data.GMap
import Data.GMap.ChoiceMap
import qualified Data.List as L

import Data.GMap.AssocList

import System.Random(newStdGen)

gen n g = do
stdg <- newStdGen
return \$ generate n stdg g

-- eg use: (Just `on` (+))       is        (\a b -> Just (a + b))
on f g a b = f (g a b)

-- ### QuickCheck instances ###

instance Show (a->b) where
show _ = "<function>"

instance (OrderedMap map k, Arbitrary k, Arbitrary a) => Arbitrary (map a) where
arbitrary = liftM fromAssocs (arbitrary :: Gen [(k,a)])
coarbitrary mp = coarbitrary (assocs mp)

instance (OrderedMap map k, Show k, Show a) => Show (map a) where
show map = "fromAssocs " ++ (show \$ assocs map)

instance Arbitrary Char where
arbitrary = sized \$ \n -> choose (minBound , maxBound `min` (toEnum n))
coarbitrary c = variant (fromEnum c)

instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) => Arbitrary (a,b,c,d,e) where
arbitrary = do
(a,b,c,(d,e)) <- arbitrary
return (a,b,c,d,e)
coarbitrary (a,b,c,d,e) = coarbitrary (a,b,c,(d,e))

instance (Arbitrary a, Arbitrary b) => Arbitrary (Choice2 a b) where
arbitrary = oneof [C1of2 `fmap` arbitrary, C2of2 `fmap` arbitrary]
coarbitrary choice = case choice of
C1of2 a -> coarbitrary a
C2of2 b -> coarbitrary b

instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (Choice3 a b c) where
arbitrary = oneof [C1of3 `fmap` arbitrary, C2of3 `fmap` arbitrary, C3of3 `fmap` arbitrary]
coarbitrary choice = case choice of
C1of3 a -> coarbitrary a
C2of3 b -> coarbitrary b
C3of3 c -> coarbitrary c

instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d) => Arbitrary (Choice4 a b c d) where
arbitrary = oneof [C1of4 `fmap` arbitrary, C2of4 `fmap` arbitrary, C3of4 `fmap` arbitrary, C4of4 `fmap` arbitrary]
coarbitrary choice = case choice of
C1of4 a -> coarbitrary a
C2of4 b -> coarbitrary b
C3of4 c -> coarbitrary c
C4of4 d -> coarbitrary d

instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d, Arbitrary e) => Arbitrary (Choice5 a b c d e) where
arbitrary = oneof [C1of5 `fmap` arbitrary, C2of5 `fmap` arbitrary, C3of5 `fmap` arbitrary, C4of5 `fmap` arbitrary, C5of5 `fmap` arbitrary]
coarbitrary choice = case choice of
C1of5 a -> coarbitrary a
C2of5 b -> coarbitrary b
C3of5 c -> coarbitrary c
C4of5 d -> coarbitrary d
C5of5 e -> coarbitrary e

-- These functions are used to pass types around as undefined arguments.
like = const :: a -> a -> a
likeElem = const :: OrderedMap map k => a -> map a -> a
likeMaybeElem = const :: OrderedMap map k => Maybe a -> map a -> Maybe a

-- Test type (allows specifying type of map used in tests)
data Test m1 m2 where
-- A simple test - pass in a map and get out something testable
SimpleTest :: Testable b => (m1 -> b) -> Test m1 m2
-- A simple test that requires two maps. Used for set ops etc
SimpleTest2 :: Testable b => ((m1,m1) -> b) -> Test m1 m2
-- CompareTest the behaviour of two different maps
CompareTest :: (Arbitrary a, Show a, Eq b) =>
(m1 -> a -> b) -> (m2 -> a -> b) -> Test m1 m2
CompareTest2 :: (Arbitrary a, Show a, Eq b) =>
((m1,m1) -> a -> b) -> ((m2,m2) -> a -> b) -> Test m1 m2

compareTest :: (OrderedMap mp1 k, OrderedMap mp2 k, Arbitrary a, Show a, Eq b, Ord k) => (forall mp. (OrderedMap mp k, Eq k, Ord k) => (mp e) -> a -> b) -> Test (mp1 e) (mp2 e)
compareTest f = CompareTest f f
compareTest2 :: (OrderedMap mp1 k, OrderedMap mp2 k, Arbitrary a, Show a, Eq b, Ord k) => (forall mp. (OrderedMap mp k, Eq k, Ord k) => ((mp e),(mp e)) -> a -> b) -> Test (mp1 e) (mp2 e)
compareTest2 f = CompareTest2 f f

-- Unsurprisingly Tests are Testable
instance (OrderedMap mp1 k, OrderedMap mp2 k, Show (mp1 a), Show (mp2 a), Arbitrary k, Arbitrary a, Show k, Show a) => Testable (Test (mp1 a) (mp2 a)) where
property (SimpleTest f) = property f
property (SimpleTest2 f) = property f
property (CompareTest f1 f2) = property (\ kas a -> f1 (fromAssocs kas) a == f2 (fromAssocs kas) a)
property (CompareTest2 f1 f2) = property (\ kas1 kas2 a -> f1 (fromAssocs kas1, fromAssocs kas2) a == f2 (fromAssocs kas1, fromAssocs kas2) a)

-- Used to generate lists of tests by parsing the source file
-- Its unfortunate that its necessary, better introspection would make life easier
testList file prefix code = do
let props = L.filter (\l -> (L.isPrefixOf prefix l) && (not \$ L.isPrefixOf (prefix ++ " ::") l)) \$
L.map head \$ L.filter (not.null) \$ L.map words \$ lines source
let printProp prop = do
putStr "("
putStr (code ++ prop)
putStr ",\""
putStr prop
putStr "\")"
putStr "["
mapM_ (\prop -> do
putStr ","
printProp prop) \$ tail props
putStrLn "]"

config n = Config
{ configMaxTest = n
, configMaxFail = 1000
, configSize    = (+ 3) . (`div` 2)
, configEvery   = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]
}

-- A list of named tests
type Tests m1 m2 = [(Test m1 m2, String)]

runTests :: (Testable (Test m1 m2)) => Tests m1 m2 -> Int -> IO ()
runTests tests n =
mapM_ ( \ (prop,name) -> do
putStr name
putStr " : "
check (config n) prop ) tests

-- Narrows the type of runTests using the type of the first argument
runAListTest :: (OrderedMap mp k,        Testable (Test (mp a) (AList k a))) => (mp a) -> Tests (mp a) (AList k a) -> Int -> IO ()
runSListTest :: (OrderedMap mp k, Testable (Test (mp a) (SList mp k a))) => (mp a) -> Tests (mp a) (SList mp k a) -> Int -> IO ()
runAListTest _ = runTests
runSListTest _ = runTests
```