{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}

#if HAVE_QUANTIFIED_CONSTRAINTS
{-# LANGUAGE QuantifiedConstraints #-}
#endif

import Control.Monad
import Control.Monad.Zip (MonadZip)
import Control.Applicative
#if defined(VERSION_aeson)
import Data.Aeson (ToJSON,FromJSON)
#endif
import Data.Bits
import Data.Foldable
import Data.Map (Map)
import qualified Data.Map as M
#if MIN_VERSION_containers(0,5,9)
import qualified Data.Map.Merge.Strict as MM
#endif
import Data.Traversable
#if HAVE_SEMIGROUPOIDS
import Data.Functor.Apply (Apply((<.>)))
#endif
#if HAVE_BINARY_LAWS
import Data.Functor.Const (Const(..))
#endif
#if HAVE_UNARY_LAWS
import Data.Functor.Classes
#endif
import Data.Int
import Data.Monoid (Sum(..),Monoid,mappend,mconcat,mempty)
import Data.Orphans ()
import Data.Primitive
import Data.Proxy
import Data.Vector (Vector)
import Data.Word
import Foreign.Storable
import Test.QuickCheck
import Text.Show.Functions

import qualified Data.Vector as V
import qualified Data.Foldable as F

import Test.QuickCheck.Classes
import qualified Spec.ShowRead

main :: IO ()
main = do
#if HAVE_SEMIGROUPOIDS
#if MIN_VERSION_containers(0,5,9)
  quickCheck prop_map_apply_equals
#endif
#endif
  lawsCheckMany allPropsApplied

allPropsApplied :: [(String,[Laws])]
allPropsApplied = M.toList . M.fromListWith (++) $
  [ ("Int",allLaws (Proxy :: Proxy Int))
  , ("Int64",allLaws (Proxy :: Proxy Int64))
  , ("Word",allLaws (Proxy :: Proxy Word))
#if HAVE_BINARY_LAWS
  , ("Tuple"
    , [ bitraversableLaws (Proxy :: Proxy (,))
      , bifoldableLaws (Proxy :: Proxy (,))
      ]
    )
  , ("Const"
    , [ bifoldableLaws (Proxy :: Proxy Const)
      , bitraversableLaws (Proxy :: Proxy Const)
      ]
    )
  , ("Either"
    , [ bitraversableLaws (Proxy :: Proxy Either)
      , bifoldableLaws (Proxy :: Proxy Either)
      ]
    )
#endif
#if HAVE_UNARY_LAWS
  , ("Maybe",allHigherLaws (Proxy1 :: Proxy1 Maybe))
  , ("List",allHigherLaws (Proxy1 :: Proxy1 []))
--  , ("BadList",allHigherLaws (Proxy1 :: Proxy1 BadList))
#endif
#if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS)
#if MIN_VERSION_base(4,9,0) && MIN_VERSION_containers(0,5,9)
  , ("Map", someHigherLaws (Proxy1 :: Proxy1 (Map Int)))
  , ("Pound", someHigherLaws (Proxy1 :: Proxy1 (Pound Int)))
#endif
#endif
#if MIN_VERSION_base(4,7,0)
  , ("Vector",
    [ isListLaws (Proxy :: Proxy (Vector Word))
#if HAVE_VECTOR
    , muvectorLaws (Proxy :: Proxy Word8)
    , muvectorLaws (Proxy :: Proxy (Int, Word))
#endif
    ])
#endif
  ]
  ++ Spec.ShowRead.lawsApplied

allLaws :: forall a.
  ( Integral a
  , Num a
  , Prim a
  , Storable a
  , Ord a
  , Arbitrary a
  , Show a
  , Read a
  , Enum a
  , Bounded a
#if defined(VERSION_aeson)
  , ToJSON a
  , FromJSON a
#endif
#if MIN_VERSION_base(4,7,0)
  , FiniteBits a
#endif
  ) => Proxy a -> [Laws]
allLaws p =
  [ primLaws p
  , storableLaws p
  , semigroupLaws (Proxy :: Proxy (Sum a))
  , monoidLaws (Proxy :: Proxy (Sum a))
  , boundedEnumLaws p
#if defined(VERSION_aeson)
  , jsonLaws p
#endif
  , eqLaws p
  , ordLaws p
  , numLaws p
  , integralLaws p
#if MIN_VERSION_base(4,7,0)
  , bitsLaws p
#endif
  ]

foldlMapM :: (Foldable t, Monoid b, Monad m) => (a -> m b) -> t a -> m b
foldlMapM f = foldlM (\b a -> liftM (mappend b) (f a)) mempty

#if HAVE_UNARY_LAWS
allHigherLaws ::
  (Traversable f, MonadZip f, MonadPlus f, Applicative f,
#if HAVE_QUANTIFIED_CONSTRAINTS
   forall a. Eq a => Eq (f a), forall a. Arbitrary a => Arbitrary (f a),
   forall a. Show a => Show (f a)
#else
   Eq1 f, Arbitrary1 f, Show1 f
#endif
  ) => proxy f -> [Laws]
allHigherLaws p =
  [ functorLaws p
  , applicativeLaws p
  , monadLaws p
  , monadPlusLaws p
  , monadZipLaws p
  , foldableLaws p
  , traversableLaws p
  ]
#endif

#if defined(HAVE_SEMIGROUPOIDS) && defined(HAVE_UNARY_LAWS)
someHigherLaws ::
  (Apply f,
#if HAVE_QUANTIFIED_CONSTRAINTS
   forall a. Eq a => Eq (f a), forall a. Arbitrary a => Arbitrary (f a),
   forall a. Show a => Show (f a)
#else
   Eq1 f, Arbitrary1 f, Show1 f
#endif
  ) => proxy f -> [Laws]
someHigherLaws p =
  [ applyLaws p
  ]
#endif

-- This type fails the laws for the strict functions
-- in Foldable. It is used just to confirm that
-- those property tests actually work.
newtype Rogue a = Rogue [a]
  deriving
  ( Eq, Show, Arbitrary
#if HAVE_UNARY_LAWS
  , Arbitrary1
  , Eq1
  , Show1
#endif
  )

-- Note: when using base < 4.6, the Rogue type does
-- not really test anything.
instance Foldable Rogue where
  foldMap f (Rogue xs) = F.foldMap f xs
  foldl f x (Rogue xs) = F.foldl f x xs
#if MIN_VERSION_base(4,6,0)
  foldl' f x (Rogue xs) = F.foldl f x xs
  foldr' f x (Rogue xs) = F.foldr f x xs
#endif

newtype BadList a = BadList [a]
  deriving
  ( Eq, Show, Arbitrary
  , Arbitrary1, Eq1, Show1
  , Traversable, Functor, MonadZip, Monad, Applicative, MonadPlus, Alternative
  )

instance Foldable BadList where
  foldMap f (BadList xs) = F.foldMap f xs
  fold (BadList xs) = fold (reverse xs)

newtype Pound k v = Pound { getPound :: Map k v }
  deriving
  ( Eq, Functor, Show, Arbitrary
#if HAVE_UNARY_LAWS
  , Arbitrary1
  -- The following instances are only available for the variants
  -- of the type classes in base, not for those in transformers.
#if MIN_VERSION_base(4,9,0) && MIN_VERSION_containers(0,5,9)
  , Eq1
  , Show1
#endif
#endif
  )

#if HAVE_SEMIGROUPOIDS
#if MIN_VERSION_containers(0,5,9)
instance Ord k => Apply (Pound k) where
  Pound m1 <.> Pound m2 = Pound $
    MM.merge
      MM.dropMissing
      MM.dropMissing
      (MM.zipWithMatched (\_ f a -> f a))
      m1
      m2
#endif
#endif

#if HAVE_SEMIGROUPOIDS
#if MIN_VERSION_containers(0,5,9)
prop_map_apply_equals :: Map Int (Int -> Int)
                      -> Map Int Int
                      -> Bool
prop_map_apply_equals mf ma =
  let pf = Pound mf
      pa = Pound ma
      m = mf <.> ma
      p = pf <.> pa
  in m == (getPound p)
#endif
#endif

-------------------
-- Orphan Instances
-------------------

instance Arbitrary a => Arbitrary (Vector a) where
  arbitrary = V.fromList <$> arbitrary
  shrink v = map V.fromList (shrink (V.toList v))

#if !MIN_VERSION_QuickCheck(2,8,2)
instance (Ord k, Arbitrary k, Arbitrary v) => Arbitrary (Map k v) where
  arbitrary = M.fromList <$> arbitrary
  shrink m = map M.fromList (shrink (M.toList m))
#endif

#if !MIN_VERSION_QuickCheck(2,9,0)
instance Arbitrary a => Arbitrary (Sum a) where
  arbitrary = Sum <$> arbitrary
  shrink = map Sum . shrink . getSum
#endif