-- | Common code for strict and lazy tests

--------------------------------------------------------------------------------

import Prelude hiding ( null , length , take , drop , head , tail , init , lookup )
import qualified Prelude as P

import qualified Data.List     as L
import qualified Data.Foldable as F

import IMPORTSEQ as Seq

import Test.Framework
import Test.Framework.Providers.QuickCheck2
import Test.QuickCheck
import Test.QuickCheck.Gen

import Control.Applicative
import Control.Monad

--------------------------------------------------------------------------------

newtype NonEmptySeq a = NE { fromNE :: Seq a } deriving (Eq,Show)

data Indexed a = Indexed Int (Seq a) deriving (Eq,Show)

instance Arbitrary a => Arbitrary (Seq a) where
  arbitrary = do
    list <- arbitrary
    return $ fromList list

instance Arbitrary a => Arbitrary (NonEmptySeq a) where
  arbitrary = do
    x   <- arbitrary
    seq <- arbitrary
    return $ NE $ cons x seq

instance Arbitrary a => Arbitrary (Indexed a) where
  arbitrary = do
    NE seq <- arbitrary
    let n = length seq
    k <- choose (0,n-1)
    return $ Indexed k seq

--------------------------------------------------------------------------------
-- * test groups

TESTGROUP :: Test
TESTGROUP = testGroup GROUPNAME
  
  [ testProperty "toList . fromList"     prop_toFromList
  , testProperty "toListNaive"           prop_toListNaive
  -- , testProperty "build"                 prop_build
  , testProperty "unCons . cons"         prop_unCons_cons
  , testProperty "cons . unCons"         prop_cons_unCons
  , testProperty "length"                prop_length
  , testProperty "null"                  prop_null
  , testProperty "null . drop n"         prop_drop_null
  , testProperty "invariant . drop k"    prop_drop_invariant
  , testProperty "all invariant . tails" prop_tails_invariant
  , testProperty "singleton"             prop_singleton
  , testProperty "pair"                  prop_pair
  , testProperty "triple"                prop_triple
  , testProperty "quad"                  prop_quad
  , testProperty "mbHead"                prop_mbHead
  , testProperty "mbTail"                prop_mbTail
  , testProperty "mbTail2"               prop_mbTail2
  , testProperty "tails"                 prop_tails
  , testProperty "lookup"                prop_lookup
  , testProperty "mbLookup"              prop_mbLookup
  , testProperty "update"                prop_update
  , testProperty "update_all"            prop_update_all
  , testProperty "drop"                  prop_drop

  , testGroup "instances"
      [ testProperty "fmap"      prop_fmap 
      , testProperty "foldl"     prop_foldl
      , testProperty "foldr"     prop_foldr
      , testProperty "foldMap"   prop_foldMap
      ]

  , testGroup "slow"
      [ testProperty "append"    prop_append
      , testProperty "take"      prop_take
      , testProperty "init"      prop_init
      , testProperty "snoc"      prop_snoc
      , testProperty "unSnoc"    prop_unSnoc
      ] 
  ]

--------------------------------------------------------------------------------

prop_toFromList :: [Int] -> Bool
prop_toFromList list = toList (fromList list) == list

prop_toListNaive :: Seq Int -> Bool
prop_toListNaive seq = toList seq == toListNaive seq

-- prop_build :: [Int] -> Bool
-- prop_build list = (build (P.length list) list == fromList list)

prop_unCons_cons :: Int -> Seq Int -> Bool
prop_unCons_cons x seq = unCons (cons x seq) == Just (x,seq)

prop_cons_unCons :: NonEmptySeq Int -> Bool
prop_cons_unCons (NE seq) = case unCons seq of
  Just (x,xs) -> cons x xs == seq
  Nothing     -> error "shouldn't happen"

prop_length :: Seq Int -> Bool
prop_length seq = (length seq == P.length (toList seq))

prop_null :: Seq Int -> Bool
prop_null seq = (null seq == P.null (toList seq))

prop_drop_null :: Seq Int -> Bool
prop_drop_null seq = null (drop (length seq) seq)

prop_drop_invariant :: Indexed Int -> Bool
prop_drop_invariant (Indexed k seq) = checkInvariant (drop k seq)

prop_tails_invariant :: Seq Int -> Bool
prop_tails_invariant seq = all checkInvariant $ tails seq

prop_singleton :: Int -> Bool
prop_singleton x = singleton x == fromList [x]

prop_pair :: Int -> Int -> Bool
prop_pair x y = pair x y == fromList [x,y]

prop_triple :: Int -> Int -> Int -> Bool
prop_triple x y z = triple x y z == fromList [x,y,z]

prop_quad :: Int -> Int -> Int -> Int -> Bool
prop_quad x y z w = quad x y z w == fromList [x,y,z,w]

prop_mbHead :: Seq Int -> Bool
prop_mbHead seq = mbHead seq == (P.fst <$> unCons seq)

prop_mbTail :: Seq Int -> Bool
prop_mbTail seq = mbTail seq == (P.snd <$> unCons seq)

prop_mbTail2 :: Seq Int -> Bool
prop_mbTail2 seq = (toList <$> mbTail seq) == listMbTail (toList seq) where
  listMbTail list = case list of { [] -> Nothing ; (x:xs) -> Just xs }

prop_tails :: Seq Int -> Bool
prop_tails seq = map toList (tails seq) == L.tails (toList seq)

prop_lookup :: Indexed Int -> Bool
prop_lookup (Indexed k seq) = lookup k seq == (toList seq) !! k

prop_mbLookup :: Indexed Int -> Bool
prop_mbLookup (Indexed k seq) = mbLookup k seq == Just ((toList seq) !! k)

prop_update :: Indexed Int -> Bool
prop_update (Indexed k seq) = toList (update (+1000) k seq) == (listUpdate (+1000) k $ toList seq) where
  listUpdate :: (a -> a) -> Int -> [a] -> [a]
  listUpdate f k xs = P.take k xs ++ (case P.drop k xs of
    []     -> []
    (y:ys) -> f y : ys)

prop_update_all :: Seq Int -> Bool
prop_update_all seq = L.foldr (update (+2000)) seq [0..n-1] == fmap (+2000) seq where
  n = length seq

prop_drop :: Indexed Int -> Bool
prop_drop (Indexed k seq) = P.drop k (toList seq) == toList (drop k seq)

--------------------------------------------------------------------------------
-- instances

prop_foldl :: Seq Int -> Bool
prop_foldl seq = L.foldl f s0 (toList seq) == F.foldl f s0 seq where
  f x y = 2*x - 5*y + 13
  s0 = 3

prop_foldr :: Seq Int -> Bool
prop_foldr seq = L.foldr f s0 (toList seq) == F.foldr f s0 seq where
  f x y = 3*x - y + 1
  s0 = 7

prop_fmap :: Seq Int -> Bool
prop_fmap seq = L.map f (toList seq) == toList (fmap f seq) where
  f x = 3*x + x*x

prop_foldMap :: Seq Int -> Bool
prop_foldMap seq = F.foldMap f (toList seq) == F.foldMap f seq where
  f n = replicate (g n) n
  g n = let k = 1 + abs n 
        in  min k 10 + ilog2 k
  ilog2 k = floor $ log (fromIntegral k :: Double) / log2
  log2 = log 2.0 :: Double
  
--------------------------------------------------------------------------------
-- slow ones

prop_append :: [Int ] -> [Int] -> Bool
prop_append xs ys = fromList (xs++ys) == append (fromList xs) (fromList ys)

prop_take :: Indexed Int -> Bool
prop_take (Indexed k seq) = P.take k (toList seq) == toList (take k seq)

prop_init :: NonEmptySeq Int -> Bool
prop_init (NE seq) = P.init (toList seq) == toList (init seq)

prop_snoc :: Seq Int -> Int -> Bool
prop_snoc seq x = (toList seq ++ [x]) == toList (snoc seq x)

prop_unSnoc :: NonEmptySeq Int -> Bool
prop_unSnoc (NE seq) = unSnoc seq == Just (fromList (P.init list) , P.last list) where
  list = toList seq

--------------------------------------------------------------------------------