{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- | Functor properties
--
-- You will need @TypeApplications@ to use these.
module Test.Syd.Validity.Functor
  ( functorSpec,
    functorSpecOnArbitrary,
    functorSpecOnGens,
  )
where

import Data.Data
import Data.GenValidity
import Data.Kind
import Test.QuickCheck
import Test.Syd
import Test.Syd.Validity.Functions
import Test.Syd.Validity.Utils

{-# ANN module "HLint: ignore Functor law" #-}

fmapTypeStr ::
  forall (f :: Type -> Type).
  (Typeable f) =>
  String
fmapTypeStr =
  unwords
    [ "fmap",
      "::",
      "(a",
      "->",
      "b)",
      "->",
      nameOf @f,
      "a",
      "->",
      nameOf @f,
      "b"
    ]

flTypeStr ::
  forall (f :: Type -> Type).
  (Typeable f) =>
  String
flTypeStr =
  unwords ["(<$)", "::", "a", "->", nameOf @f, "b", "->", nameOf @f, "a"]

-- | Standard test spec for properties of Functor instances for values generated with GenValid instances
--
-- Example usage:
--
-- > functorSpecOnArbitrary @[]
functorSpec ::
  forall (f :: Type -> Type).
  (Eq (f Int), Show (f Int), Functor f, Typeable f, GenValid (f Int)) =>
  Spec
functorSpec = functorSpecWithInts @f genValid

-- | Standard test spec for properties of Functor instances for values generated with Arbitrary instances
--
-- Example usage:
--
-- > functorSpecOnArbitrary @[]
functorSpecOnArbitrary ::
  forall (f :: Type -> Type).
  (Eq (f Int), Show (f Int), Functor f, Typeable f, Arbitrary (f Int)) =>
  Spec
functorSpecOnArbitrary = functorSpecWithInts @f arbitrary

functorSpecWithInts ::
  forall (f :: Type -> Type).
  (Eq (f Int), Show (f Int), Functor f, Typeable f) =>
  Gen (f Int) ->
  Spec
functorSpecWithInts gen =
  functorSpecOnGens
    @f
    @Int
    genValid
    "int"
    gen
    (unwords [nameOf @f, "of ints"])
    ((+) <$> genValid)
    "increments"
    ((*) <$> genValid)
    "scalings"

-- | Standard test spec for properties of Functor instances for values generated by given generators (and names for those generator).
--
-- Example usage:
--
-- > functorSpecOnGens
-- >     @[]
-- >     @Int
-- >     (pure 4) "four"
-- >     (genListOf $ pure 5) "list of fives"
-- >     ((+) <$> genValid) "additions"
-- >     ((*) <$> genValid) "multiplications"
functorSpecOnGens ::
  forall (f :: Type -> Type) (a :: Type) (b :: Type) (c :: Type).
  ( Show a,
    Show (f a),
    Show (f c),
    Eq (f a),
    Eq (f c),
    Functor f,
    Typeable f,
    Typeable a,
    Typeable b,
    Typeable c
  ) =>
  Gen a ->
  String ->
  Gen (f a) ->
  String ->
  Gen (b -> c) ->
  String ->
  Gen (a -> b) ->
  String ->
  Spec
functorSpecOnGens gena genaname gen genname genf genfname geng gengname =
  parallel $
    describe ("Functor " ++ nameOf @f) $ do
      describe (fmapTypeStr @f) $ do
        it
          ( unwords
              [ "satisfies the first Fuctor law: 'fmap id == id' for",
                genDescr @(f a) genname
              ]
          )
          $ equivalentOnGen (fmap @f id) (id @(f a)) gen shrinkNothing
        it
          ( unwords
              [ "satisfieds the second Functor law: 'fmap (f . g) == fmap f . fmap g' for",
                genDescr @(f a) genname,
                "'s",
                "given to",
                genDescr @(b -> c) genfname,
                "and",
                genDescr @(a -> b) gengname
              ]
          )
          $ forAll (Anon <$> genf) $ \(Anon f) ->
            forAll (Anon <$> geng) $ \(Anon g) ->
              equivalentOnGen
                (fmap (f . g))
                (fmap f . fmap g)
                gen
                shrinkNothing
      describe (flTypeStr @f) $
        it
          ( unwords
              [ "is equivalent to its default implementation for",
                genDescr @a genaname,
                "and",
                genDescr @(f a) genname
              ]
          )
          $ forAll gena $ \a ->
            equivalentOnGen (a <$) (fmap $ const a) gen shrinkNothing