{-# LANGUAGE ScopedTypeVariables
            ,RankNTypes
            ,ExistentialQuantification
            ,MultiParamTypeClasses
            ,FunctionalDependencies
            ,FlexibleInstances
            ,UndecidableInstances
            ,FlexibleContexts #-}

{-
Copyright (C) 2007 John Goerzen <jgoerzen@complete.org>

All rights reserved.

For license and copyright information, see the file COPYRIGHT

-}

module TestInfrastructure where

import Test.QuickCheck
import Test.QuickCheck.Test
import qualified Data.ListLike as LL
import Data.ListLike.Text
import Data.ListLike.Vector
import qualified Data.Foldable as F
import qualified Data.Vector as V
import qualified Data.Vector.Storable as VS
import qualified Data.Vector.Unboxed as VU
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import System.Random
import System.IO
import qualified Test.HUnit as HU
import Text.Printf
import Data.Word
import Data.List
import Data.Monoid


instance Arbitrary (T.Text) where
    arbitrary = sized (\n -> choose (0, n) >>= myVector)
        where myVector n =
                  do arblist <- vector n
                     return (LL.fromList arblist)
    shrink = map LL.fromList . shrink . LL.toList

instance CoArbitrary (T.Text) where
    coarbitrary l = coarbitrary (LL.toList l)

instance Arbitrary (TL.Text) where
    arbitrary = sized (\n -> choose (0, n) >>= myVector)
        where myVector n =
                  do arblist <- vector n
                     return (LL.fromList arblist)
    shrink = map LL.fromList . shrink . LL.toList

instance CoArbitrary (TL.Text) where
    coarbitrary l = coarbitrary (LL.toList l)

instance Arbitrary i => Arbitrary (V.Vector i) where
    arbitrary = sized (\n -> choose (0, n) >>= myVector)
        where myVector n =
                  do arblist <- vector n
                     return (LL.fromList arblist)
    shrink = map LL.fromList . shrink . LL.toList

instance (CoArbitrary i) => CoArbitrary (V.Vector i) where
    coarbitrary l = coarbitrary (LL.toList l)

instance (Arbitrary i, VS.Storable i) => Arbitrary (VS.Vector i) where
    arbitrary = sized (\n -> choose (0, n) >>= myVector)
        where myVector n =
                  do arblist <- vector n
                     return (LL.fromList arblist)
    shrink = map LL.fromList . shrink . LL.toList

instance (CoArbitrary i, VS.Storable i) => CoArbitrary (VS.Vector i) where
    coarbitrary l = coarbitrary (LL.toList l)

instance (Arbitrary i, VU.Unbox i) => Arbitrary (VU.Vector i) where
    arbitrary = sized (\n -> choose (0, n) >>= myVector)
        where myVector n =
                  do arblist <- vector n
                     return (LL.fromList arblist)
    shrink = map LL.fromList . shrink . LL.toList

instance (CoArbitrary i, VU.Unbox i) => CoArbitrary (VU.Vector i) where
    coarbitrary l = coarbitrary (LL.toList l)

class (Show b, Arbitrary a, Show a, Eq a, Eq b, LL.ListLike a b) => TestLL a b where
  llcmp :: a -> [b] -> Property
  llcmp f l =  (putStrLn ("Expected: " ++ show l ++ "\nGot: " ++ show f))
               `whenFail` (l == (LL.toList f))
  checkLengths :: a -> [b] -> Bool
  checkLengths f l = (LL.length f) == length l

instance (Arbitrary a, Show a, Eq a) => TestLL [a] a where

instance TestLL T.Text Char where

instance TestLL TL.Text Char where

instance (Arbitrary a, Show a, Eq a) => TestLL (V.Vector a) a where

instance (Arbitrary a, Show a, Eq a, VS.Storable a) => TestLL (VS.Vector a) a where

instance (Arbitrary a, Show a, Eq a, VU.Unbox a) => TestLL (VU.Vector a) a where

mapRemoveDups :: (Eq k1) => [(k1, v1)] -> [(k1, v1)]
mapRemoveDups = nubBy (\(k1, _) (k2, _) -> k1 == k2)

mkTest msg test = HU.TestLabel msg $ HU.TestCase (quickCheck test)

-- Modified from HUnit
runVerbTestText :: HU.PutText st -> HU.Test -> IO (HU.Counts, st)
runVerbTestText (HU.PutText put us) t = do
  (counts, us') <- HU.performTest reportStart reportError reportFailure us t
  us'' <- put (HU.showCounts counts) True us'
  return (counts, us'')
 where
  reportStart ss us = do hPrintf stderr "\rTesting %-68s\n" (HU.showPath (HU.path ss))
                         put (HU.showCounts (HU.counts ss)) False us
  reportError   = reportProblem "Error:"   "Error in:   "
  reportFailure = reportProblem "Failure:" "Failure in: "
  reportProblem p0 p1 msg ss us = put line True us
   where line  = "### " ++ kind ++ path' ++ '\n' : msg
         kind  = if null path' then p0 else p1
         path' = HU.showPath (HU.path ss)


-- | So we can test map and friends
instance Show (a -> b) where
    show _ = "(a -> b)"

data (LL.ListLike f i, Arbitrary f, Arbitrary i, Show f, Show i, Eq i, Eq f) => LLTest f i =
    forall t. Testable t => LLTest (f -> t)

data (LL.ListLike f i, Arbitrary f, Arbitrary i, Show f, Show i, Eq i, Eq f, LL.ListLike f' f, TestLL f' f, Show f', Eq f', Arbitrary f') =>
     LLWrap f' f i =
         forall t. Testable t => LLWrap (f' -> t)

w :: TestLL f i => String -> LLTest f i -> HU.Test
w msg f = case f of
                    LLTest theTest -> mkTest msg theTest

ws :: (LL.StringLike f, TestLL f i) => String -> LLTest f i -> HU.Test
ws = w

wwrap :: (TestLL f i, TestLL f' f) => String -> LLWrap f' f i -> HU.Test
wwrap msg f = case f of
                   LLWrap theTest -> mkTest msg theTest

t :: forall f t i. (TestLL f i, Arbitrary f, Arbitrary i, Show f, Eq f, Testable t) => (f -> t) -> LLTest f i
t = LLTest

-- | all props, wrapped list
apw :: String -> (forall f' f i. (TestLL f i, Show i, Eq i, LL.ListLike f i, Eq f, Show f, Arbitrary f, Arbitrary i, LL.ListLike f' f, Show f', TestLL f' f, Arbitrary f', Eq f') => LLWrap f' f i) -> HU.Test
apw msg x = HU.TestLabel msg $ HU.TestList $
    [wwrap "wrap (Vector (Vector Int))" (x::LLWrap (V.Vector (V.Vector Int)) (V.Vector Int) Int) ]

-- | all props, 1 args: full
apf :: String -> (forall f i. (Ord i, TestLL f i, Show i, Eq i, VS.Storable i, VU.Unbox i, LL.ListLike f i, Eq f, Show f, Arbitrary f, Arbitrary i, CoArbitrary f, CoArbitrary i) => LLTest f i) -> HU.Test
apf msg x = HU.TestLabel msg $ HU.TestList $
    [w "Vector Int" (x::LLTest (V.Vector Int) Int),
     w "StorableVector Int" (x::LLTest (VS.Vector Int) Int),
     w "UnboxVector Int" (x::LLTest (VU.Vector Int) Int),
     w "Vector Bool" (x::LLTest (V.Vector Bool) Bool),
     w "StorableVector Bool" (x::LLTest (VS.Vector Bool) Bool),
     w "UnboxVector Bool" (x::LLTest (VU.Vector Bool) Bool),
     w "Text" (x::LLTest T.Text Char),
     w "Text.Lazy" (x::LLTest TL.Text Char)
    ]

-- | all props, 1 args: full
aps :: String -> (forall f i. (Ord i, TestLL f i, Show i, Eq i, VU.Unbox i, LL.StringLike f, LL.ListLike f i, Eq f, Show f, Arbitrary f, Arbitrary i) => LLTest f i) -> HU.Test
aps msg x = HU.TestLabel msg $ HU.TestList $
    [ w "Text" (x::LLTest T.Text Char),
     w "Text.Lazy" (x::LLTest TL.Text Char),
     w "Vector Char" (x::LLTest (V.Vector Char) Char),
     w "Vector.Unbox Char" (x::LLTest (VU.Vector Char) Char)
    ]