{-# LANGUAGE StandaloneDeriving #-}
module Main where

import Data.Monoid
--import Text.Megaparsec.Pos (Pos, unsafePos, SourcePos(..), sourceName, sourceLine, sourceColumn)
import qualified Data.Map as Map
import qualified Data.Set as Set

import Test.QuickCheck
import Test.QuickCheck.Property
import Test.Tasty
import Test.Tasty.QuickCheck

import LambdaCube.Compiler.DesugaredSource
import LambdaCube.Compiler.Core

----------------------------------------------------------------- Main

-- Usage: ":main --quickcheck-max-size 30 --quickcheck-tests 100"
main = defaultMain $ testGroup "Compiler"
  [ testGroup "Infer" $ concat [
        monoidTestProperties "SI"    (arbitrary :: Gen SI)
--      , monoidTestProperties "Infos" (arbitrary :: Gen Infos) -- list is always a monoid
--      , monoidTestProperties "MaxDB" (arbitrary :: Gen MaxDB)
      ]
  ]

----------------------------------------------------------------- Arbitraries

-- SourcePos

-- TODO: generate only valid positions
instance Arbitrary SPos where
    arbitrary = SPos <$> arbitrary <*> arbitrary

-- TODO: review
instance Arbitrary FileInfo where
    arbitrary = FileInfo <$> arbitrary <*> arbitrary <*> arbitrary

-- Range
instance Arbitrary Range where
  -- TODO: generate only valid ranges (positive numbers, second position is after first one)
  arbitrary = Range <$> arbitrary <*> arbitrary <*> arbitrary
  shrink (Range a b c) = Range <$> shrink a <*> shrink b <*> shrink c

-- SI

instance Arbitrary SI where
  arbitrary = oneof [NoSI . Set.fromList <$> arbitrary, RangeSI <$> arbitrary]
  shrink (NoSI ds) = []
  shrink (RangeSI r) = mempty: map RangeSI (shrink r)

instance MonoidEq SI where
  NoSI a    =::= NoSI  b   = a == b
  RangeSI a =::= RangeSI b = a == b

instance TestShow SI where
  testShow (NoSI a)    = "NoSI " ++ show a
  testShow (RangeSI a) = "RangeSI " ++ show a

-- Infos
{- list is always a monoid
instance Arbitrary Info where
  arbitrary = Info <$> arbitrary

instance Arbitrary Infos where
  arbitrary        = Infos . Map.fromList <$> arbitrary
  shrink (Infos m) = map (Infos . Map.fromList . shrink) $ Map.toList m

deriving instance Eq Infos

instance MonoidEq Infos where
  (=::=) = (==)

instance TestShow Infos where
  testShow (Infos i) = "Infos " ++ show i
-}
-- MaxDB
{- todo
instance Arbitrary MaxDB where
  arbitrary = MaxDB <$> {-fmap (fmap abs)-} arbitrary
  shrink (MaxDB m) = map MaxDB $ shrink m

instance MonoidEq MaxDB where
  MaxDB (Just n) =::= MaxDB (Just m) = n == m
  MaxDB Nothing  =::= MaxDB Nothing  = True
  MaxDB (Just 0) =::= MaxDB Nothing  = True
  MaxDB Nothing  =::= MaxDB (Just 0) = True
  _              =::= _              = False

instance TestShow MaxDB where
  testShow (MaxDB a) = "MaxDB " ++ show a
-}
----------------------------------------------------------------- Test building blocks

class Monoid m => MonoidEq m where
  (=::=) :: m -> m -> Bool

infix 4 =::=

monoidTestProperties name gen =
  [ testProperty (name ++ " monoid left identity")  (propMonoidLeftIdentity gen)
  , testProperty (name ++ " monoid right identity") (propMonoidRightIdentity gen)
  , testProperty (name ++ " monoid associativity")  (propMonoidAssociativity gen)
  ]

----------------------------------------------------------------- Properties

-- * Monoid

propMonoidLeftIdentity :: (MonoidEq m, TestShow m) => Gen m -> Property
propMonoidLeftIdentity gen = forAll' gen (\x -> x =*= mempty <> x)

propMonoidRightIdentity :: (MonoidEq m, TestShow m) => Gen m -> Property
propMonoidRightIdentity gen = forAll' gen (\x -> x =*= x <> mempty)

propMonoidAssociativity :: (Arbitrary m, MonoidEq m, TestShow m) => Gen m -> Property
propMonoidAssociativity gen =
  forAll' gen $ \x -> forAll' gen $ \y -> forAll' gen $ \z ->
    (x <> y) <> z =*= x <> (y <> z)

----------------------------------------------------------------- Tools

class TestShow t where
  testShow :: t -> String

-- | Like '=::=', but prints a counterexample when it fails.
infix 4 =*=
(=*=) :: (MonoidEq a, TestShow a) => a -> a -> Property
x =*= y =
  counterexample (testShow x ++ " /= " ++ testShow y) (x =::= y)

forAll' :: (TestShow a, Testable prop)
        => Gen a -> (a -> prop) -> Property
forAll' gen pf =
  again $
  MkProperty $
  gen >>= \x ->
    unProperty (counterexample (testShow x) (pf x))