{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}

module Properties where

import Prelude hiding (null, foldr, lookup, concatMap, concat, and,
                       all, drop, take, reverse, filter)

import Control.Monad
import Data.Char
import Data.Collections
import Data.Collections.Properties
import Data.Collections.Instances
import Data.List (intersperse,nub,nubBy)
import Data.Maybe
import Data.Monoid
import qualified Data.Set.Enum as Enum
import Data.Map.List
import Data.Set.List
import System.Exit
import Test.QuickCheck
import Test.QuickCheck.Batch hiding (runTests)
import qualified Data.Collections as C
import Data.Typeable
import Presentation
import System.Random
import Data.ByteString (ByteString)
import Data.Word
import System.Environment
import Text.Regex.Posix

--deriving instance Typeable a => Typeable (RangedSet a) -- (makes GHC 6.8 panic)
#include "Typeable.h"
INSTANCE_TYPEABLE1(RangedSet,rangedSetTc,"RangedSet")

options = 
    TestOptions 
    {
     no_of_tests = 300, 
     length_of_tests = 20,
     debug_tests = False
    }

prettyResult (TestOk s n msg) = s ++ " " ++ show n ++ concatMap concat msg
prettyResult (TestExausted s n msg) = s ++ show n ++ concatMap concat msg
prettyResult (TestFailed s n) = "failed with at " ++ show n ++ " with (" ++ concat (intersperse "," s) ++ ")"
prettyResult (TestAborted e) = "aborted: " ++ show e

resultOk (TestOk _ _ _) = True
resultOk (TestExausted _ _ _) = True
resultOk (TestFailed _ _) = False
resultOk (TestAborted _) = False

runOneTest (test, name) = 
    do putStr $ name ++ "... "
       result <- run test options
       putStrLn $ prettyResult result
       return result
       
runTests groupName propTests =
    do putStrLn $ "Running tests " ++ groupName
       results <- mapM runOneTest $ propTests
       let ok = all resultOk results
       let failing = filter (not . resultOk . snd) $ zip (map snd propTests) results
       putStrLn $ "RESULT: " ++ groupName ++ " " ++ if ok then "PASSED" else "FAILED"
       return (groupName, failing)

__ = undefined


map_coll_properties s = map_fold_properties s >< map_unfold_properties s
set_coll_properties s = set_fold_properties s >< set_unfold_properties s

goodSequence s = ("goodSequence", foldable_properties s >< collection_properties s >< sequence_properties s >< 
                                  indexed_properties s >< indexed_sequence_properties s)

goodMap m = ("goodMap", foldable_properties m >< collection_properties m >< map_properties m 
                          >< map_coll_properties m >< indexed_properties m >< indexed_map_properties m)

goodSet m = ("goodSet", foldable_properties m >< collection_properties m >< map_properties m >< set_coll_properties m)

unfoldableSet m = ("unfoldSet", unfoldable_properties m >< map_properties m >< set_unfold_properties m) 

main = 
    do [filterExp] <- getArgs
       let runTestsForType getTests val = if typName =~ filterExp 
                                          then runTests (testName ++ " " ++ typName) tests
                                          else return (testName, [])
               where typName = show $ typeOf val
                     (testName, tests) = getTests val
       failed <- sequence 
         [runTestsForType goodSequence (__::[Int])
         ,runTestsForType goodSequence (__::Seq Int)
         ,runTestsForType goodSequence (__::ByteString)

         ,runTestsForType goodMap (__::StdMap Int Int)
         ,runTestsForType goodMap (__::AssocList [(Int,Int)] Int Int)
         ,runTestsForType goodMap (__::StdMap Int Int)
         --
         ,runTestsForType goodMap (__::AvlMap Int Int)
         ,runTestsForType goodMap (__::IntMap Int)
          --
          ,runTestsForType goodSet (__::Enum.Set SmallInt)
          ,runTestsForType goodSet (__::IntSet)
          ,runTestsForType goodSet (__::AvlSet Int)
          ,runTestsForType goodSet (__::StdSet Int)
          ,runTestsForType goodSet (__::SetList [Int])
          --
          ,runTestsForType unfoldableSet (__::RangedSet Int)
          ,runTestsForType unfoldableSet (__::RangedSet Float)
           ]
       putStrLn ""
       putStrLn $ showTable $ ["group","property","reason"]:[[group,test,prettyResult reason]
                                                             | (group,failedSet) <- failed, (test,reason) <- failedSet]
       return ()

----------
-- Types

newtype SmallInt = SmallInt Int
    deriving (Enum, Integral, Random, Real, Ord, Num, Eq, Show, Typeable)

instance Bounded SmallInt where
    minBound = 0
    maxBound = 31

instance Monoid Int where -- to satisfy AvlMap
    mempty = 0
    mappend = (+)

-----------------------
-- Arbitrary instances

instance Arbitrary SmallInt where
    arbitrary = choose (minBound, maxBound)
    coarbitrary x = variant (fromIntegral x)

instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (StdMap k v)  where
    arbitrary = return fromList `ap` arbitrary

instance (Ord k, Arbitrary k) => Arbitrary (StdSet k)  where
    arbitrary = return fromList `ap` arbitrary

instance Arbitrary v => Arbitrary (IntMap v)  where
    arbitrary = return fromList `ap` arbitrary

instance Arbitrary IntSet where
    arbitrary = return fromList `ap` arbitrary

instance (Arbitrary k, Enum k) => Arbitrary (Enum.Set k) where
    arbitrary = return fromList `ap` arbitrary

instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (AvlMap k v)  where
    arbitrary = return fromList `ap` arbitrary

instance (Ord k, Arbitrary k) => Arbitrary (AvlSet k)  where
    arbitrary = return fromList `ap` arbitrary

instance Arbitrary k => Arbitrary (Seq k)  where
    arbitrary = return fromList `ap` arbitrary

instance (Eq l, Arbitrary [l]) => Arbitrary (SetList [l])  where
    arbitrary = return (SetList . nub) `ap` arbitrary -- use nub so at least some functions have a chance to succeed.

instance (Eq k, Arbitrary [(k,v)]) => Arbitrary (AssocList [(k,v)] k v)  where
    arbitrary = return (AssocList . nubBy (testing fst)) `ap` arbitrary 
    -- use nub so at least some functions have a chance to succeed.

instance Arbitrary Word8 where
    arbitrary = do x :: Int <- arbitrary
                   return (fromIntegral x)
    coarbitrary x = variant (fromIntegral x)

instance Arbitrary ByteString where
    arbitrary = return fromList `ap` arbitrary

testing :: Eq b => (a -> b) -> a -> a -> Bool
testing f x y = (f x) == (f y)


instance Arbitrary Char where
  arbitrary     = choose ('a','d')
  coarbitrary c = variant (ord c - ord 'a')