module Tests.HBifunctor (
    hbifunctorTests
  ) where

import           Control.Applicative
import           Control.Monad.Freer.Church
import           Control.Natural.IsoF
import           Data.Bifunctor
import           Data.Bifunctor.Joker
import           Data.Functor
import           Data.Functor.Combinator
import           Data.Functor.Identity
import           Data.Functor.Product
import           Data.Functor.Sum
import           Data.HBifunctor.Associative
import           Data.HBifunctor.Tensor
import           Data.HFunctor.Chain
import           Data.Maybe
import           Data.Proxy
import           Hedgehog
import           Test.Tasty
import           Test.Tasty.Hedgehog
import           Tests.Util
import qualified Data.Semigroup              as S
import qualified Hedgehog.Gen                as Gen
import qualified Hedgehog.Range              as Range

hbimapProp
    :: forall t f g m a.
     ( HBifunctor t
     , Monad m
     , Show (t f g a), Eq (t f g a)
     )
    => Gen (t f g a)
    -> PropertyT m ()
hbimapProp gx = do
    x <- forAll gx
    hbimap id id x === x

associatingProp
    :: forall t f g h m a.
     ( Associative t
     , Monad m
     , Functor f, Functor g, Functor h
     , Show (t f (t g h) a)
     , Show (t (t f g) h a)
     , Eq (t f (t g h) a)
     , Eq (t (t f g) h a)
     )
    => Gen (t f (t g h) a)
    -> Gen (t (t f g) h a)
    -> PropertyT m ()
associatingProp = isoProp (associating @t)

matchingNEProp
    :: forall t f m a.
     ( Associative t
     , Monad m
     , Functor f
     , Show (f a), Eq (f a)
     , Show (NonEmptyBy t f a), Eq (NonEmptyBy t f a)
     , Show (t f (NonEmptyBy t f) a), Eq (t f (NonEmptyBy t f) a)
     )
    => Gen (NonEmptyBy t f a)
    -> Gen (f a)
    -> Gen (t f (NonEmptyBy t f) a)
    -> PropertyT m ()
matchingNEProp gx gy gz = isoProp (matchingNE @t) gx (sumGen gy gz)

unrollingNEProp
    :: forall t f m a.
     ( SemigroupIn t f
     , Monad m
     , Functor f
     , Show (NonEmptyBy t f a), Eq (NonEmptyBy t f a)
     , Show (f a), Eq (f a)
     , Show (t f (Chain1 t f) a), Eq (t f (Chain1 t f) a)
     )
    => Gen (NonEmptyBy t f a)
    -> Gen (Chain1 t f a)
    -> PropertyT m ()
unrollingNEProp = isoProp (unrollingNE @t)

consNEProp
    :: forall t f m a.
     ( Associative t
     , Monad m
     , Show (t f (NonEmptyBy t f) a)
     , Show (NonEmptyBy t f a), Eq (NonEmptyBy t f a)
     )
    => Gen (t f (NonEmptyBy t f) a)
    -> PropertyT m ()
consNEProp gx = do
    x <- forAll gx
    appendNE (hleft inject x) === consNE x

toNonEmptyByProp
    :: forall t f m a.
     ( Associative t
     , Monad m
     , Show (t f f a)
     , Show (NonEmptyBy t f a), Eq (NonEmptyBy t f a)
     )
    => Gen (t f f a)
    -> PropertyT m ()
toNonEmptyByProp gx = do
    x <- forAll gx
    appendNE (hbimap inject inject x) === toNonEmptyBy x

biretractProp
    :: forall t f m a.
     ( SemigroupIn t f
     , Interpret (NonEmptyBy t) f
     , Monad m
     , Show (t f f a)
     , Show (f a), Eq (f a)
     )
    => Gen (t f f a)
    -> PropertyT m ()
biretractProp gx = do
    x <- forAll gx
    retract (appendNE (hbimap inject inject x)) === biretract x

binterpretProp
    :: forall t f m a.
     ( SemigroupIn t f
     , Monad m
     , Show (t f f a)
     , Show (f a), Eq (f a)
     )
    => Gen (t f f a)
    -> PropertyT m ()
binterpretProp gx = do
    x <- forAll gx
    biretract x === binterpret id id x

rightIdentityProp
    :: forall t i f m a.
     ( Tensor t i
     , Monad m
     , Functor f
     , Show (f a), Eq (f a)
     , Show (t f i a), Eq (t f i a)
     )
    => Gen (f a)
    -> Gen (t f i a)
    -> PropertyT m ()
rightIdentityProp = isoProp (rightIdentity @t)

leftIdentityProp
    :: forall t i g m a.
     ( Tensor t i
     , Monad m
     , Functor g
     , Show (g a), Eq (g a)
     , Show (t i g a), Eq (t i g a)
     )
    => Gen (g a)
    -> Gen (t i g a)
    -> PropertyT m ()
leftIdentityProp = isoProp (leftIdentity @t)

splittingLBProp
    :: forall t i f m a.
     ( Tensor t i
     , Monad m
     , Show (i a), Eq (i a)
     , Show (ListBy t f a), Eq (ListBy t f a)
     , Show (t f (ListBy t f) a), Eq (t f (ListBy t f) a)
     )
    => Gen (ListBy t f a)
    -> Gen ((i :+: t f (ListBy t f)) a)
    -> PropertyT m ()
splittingLBProp = isoProp (splittingLB @t)

unrollingProp
    :: forall t i f m a.
     ( MonoidIn t i f
     , Monad m
     , Show (ListBy t f a), Eq (ListBy t f a)
     , Show (i a), Eq (i a)
     , Show (t f (Chain t i f) a), Eq (t f (Chain t i f) a)
     )
    => Gen (ListBy t f a)
    -> Gen (Chain t i f a)
    -> PropertyT m ()
unrollingProp = isoProp (unrolling @t)

toListByProp
    :: forall t i f m a.
     ( Tensor t i
     , Monad m
     , Show (t f f a)
     , Show (ListBy t f a), Eq (ListBy t f a)
     )
    => Gen (t f f a)
    -> PropertyT m ()
toListByProp gx = do
    x <- forAll gx
    reviewF (splittingLB @t) (R1 (hright (inject @(ListBy t)) x)) === toListBy @t x

fromNEProp
    :: forall t i f m a.
     ( Tensor t i
     , Monad m
     , Show (NonEmptyBy t f a)
     , Show (ListBy t f a), Eq (ListBy t f a)
     )
    => Gen (NonEmptyBy t f a)
    -> PropertyT m ()
fromNEProp gx = do
    x <- forAll gx
    reviewF (splittingLB @t) (R1 (splitNE @t x)) === fromNE @t x

pureTProp
    :: forall t i f m a.
     ( MonoidIn t i f
     , Interpret (ListBy t) f
     , Monad m
     , Show (i a)
     , Show (f a), Eq (f a)
     )
    => Gen (i a)
    -> PropertyT m ()
pureTProp gx = do
    x <- forAll gx
    retract (reviewF (splittingLB @t) (L1 x)) === pureT @t @_ @f x

splittingNEProp
    :: forall t i f m a.
     ( Matchable t i
     , Monad m
     , Show (NonEmptyBy t f a), Eq (NonEmptyBy t f a)
     , Show (t f (ListBy t f) a), Eq (t f (ListBy t f) a)
     )
    => Gen (NonEmptyBy t f a)
    -> Gen (t f (ListBy t f) a)
    -> PropertyT m ()
splittingNEProp = isoProp (splittingNE @t)

matchingLBProp
    :: forall t i f m a.
     ( Matchable t i
     , Monad m
     , Show (i a), Eq (i a)
     , Show (ListBy t f a), Eq (ListBy t f a)
     , Show (NonEmptyBy t f a), Eq (NonEmptyBy t f a)
     )
    => Gen (ListBy t f a)
    -> Gen ((i :+: NonEmptyBy t f) a)
    -> PropertyT m ()
matchingLBProp = isoProp (matchingLB @t)

matchingChainProp
    :: forall t i f m a.
     ( Matchable t i
     , Monad m
     , Functor f
     , Show (f a), Eq (f a)
     , Show (i a), Eq (i a)
     , Show (t f (Chain1 t f) a), Eq (t f (Chain1 t f) a)
     , Show (t f (Chain t i f) a), Eq (t f (Chain t i f) a)
     )
    => Gen (Chain t i f a)
    -> Gen ((i :+: Chain1 t f) a)
    -> PropertyT m ()
matchingChainProp = isoProp (matchingChain @t)

genChain
    :: forall t i f m a. (MonadGen m, TestHBifunctor t)
    => m (f a)
    -> Maybe (m (i a))
    -> m (Chain t i f a)
genChain gx gy = go
  where
    go = case gy of
      Nothing  -> More <$> genHB @t gx go
      Just gy' -> Gen.bool >>= \case
        False -> Done <$> gy'
        True  -> More <$> genHB @t gx go

maybeSumGen
    :: Maybe (Gen (f a))
    -> Gen (g a)
    -> Gen ((f :+: g) a)
maybeSumGen = maybe (fmap R1) sumGen

hbifunctorProps
    :: forall t f a.
     ( TestHBifunctor t
     , Show (t f f a), Eq (t f f a)
     )
    => Gen (f a)
    -> TestTree
hbifunctorProps gx = testGroup "HBifunctor"
                       . map (uncurry testProperty . second property) $
    [ ("hbimap", hbimapProp @t (genHB gx gx))
    ]

associativeProps
    :: forall t f a.
     ( SemigroupIn t f
     , Interpret (NonEmptyBy t) f
     , TestHBifunctor t
     , TestHFunctor (NonEmptyBy t)
     , Functor f
     , Show (t f (t f f) a)     , Eq (t f (t f f) a)
     , Show (t (t f f) f a)     , Eq (t (t f f) f a)
     , Show (t f f a)
     , Show (t f (NonEmptyBy t f) a)    , Eq (t f (NonEmptyBy t f) a)
     , Show (NonEmptyBy t f a)          , Eq (NonEmptyBy t f a)
     , Show (t f (Chain1 t f) a), Eq (t f (Chain1 t f) a)
     , Show (f a)               , Eq (f a)
     )
    => Gen (f a)
    -> TestTree
associativeProps gx = testGroup "Associative"
                       . map (uncurry testProperty . second property) $
    [ ("associating", associatingProp @t (genHB gx (genHB gx gx)) (genHB (genHB gx gx) gx))
    , ("matchingNE" , matchingNEProp  @t (genHF gx) gx (genHB gx (genHF gx)))
    , ("unrollingNE", unrollingNEProp @t (genHF gx) (genHF gx))
    , ("consNE"     , consNEProp      @t (genHB gx (genHF gx)))
    , ("toNonEmptyBy"       , toNonEmptyByProp        @t (genHB gx gx))
    , ("biretract"  , biretractProp   @t (genHB gx gx))
    , ("binterpret" , binterpretProp  @t (genHB gx gx))
    ]

tensorProps
    :: forall t i f a.
     ( MonoidIn t i f
     , Interpret (ListBy t) f
     , TestHBifunctor t
     , TestHFunctor (ListBy t)
     , TestHFunctor (NonEmptyBy t)
     , Functor f
     , Show (t f i a)            , Eq (t f i a)
     , Show (t i f a)            , Eq (t i f a)
     , Show (t f (ListBy t f) a)         , Eq (t f (ListBy t f) a)
     , Show (t f (Chain t i f) a), Eq (t f (Chain t i f) a)
     , Show (t f f a)
     , Show (ListBy t f a)               , Eq (ListBy t f a)
     , Show (NonEmptyBy t f a)
     , Show (i a)                  , Eq (i a)
     , Show (f a)                    , Eq (f a)
     )
    => Gen (f a)
    -> Maybe (Gen (i a))
    -> TestTree
tensorProps gx gy = testGroup "Tensor"
                    . map (uncurry testProperty . second property)
                    . catMaybes $
    [ gy <&> \y -> ("rightIdentity", rightIdentityProp @t gx (genHB gx y))
    , gy <&> \y -> ("leftIdentity" , leftIdentityProp  @t gx (genHB y gx))
    , Just ("splittingLB", splittingLBProp @t (genHF gx) (maybeSumGen gy (genHB gx (genHF gx))))
    , Just ("unrolling", unrollingProp @t (genHF gx) (genChain gx gy))
    , Just ("toListBy"       , toListByProp        @t (genHB gx gx))
    , Just ("fromNE"     , fromNEProp      @t (genHF gx))
    , gy <&> \y -> ("pureT"        , pureTProp          @t @_ @f y)
    ]

matchableProps
    :: forall t i f a.
     ( Matchable t i
     , TestHBifunctor t
     , TestHFunctor (ListBy t)
     , TestHFunctor (NonEmptyBy t)
     , Functor f
     , Show (t f (ListBy t f) a)         , Eq (t f (ListBy t f) a)
     , Show (t f (Chain t i f) a), Eq (t f (Chain t i f) a)
     , Show (t f (Chain1 t f) a)     , Eq (t f (Chain1 t f) a)
     , Show (ListBy t f a)               , Eq (ListBy t f a)
     , Show (NonEmptyBy t f a)               , Eq (NonEmptyBy t f a)
     , Show (i a)                  , Eq (i a)
     , Show (f a)                    , Eq (f a)
     )
    => Gen (f a)
    -> Maybe (Gen (i a))
    -> TestTree
matchableProps gx gy = testGroup "Matchable"
                     . map (uncurry testProperty . second property) $
    [ ("splittingNE"  , splittingNEProp   @t (genHF gx) (genHB gx (genHF gx)))
    , ("matchingLB"   , matchingLBProp    @t (genHF gx) (maybeSumGen gy (genHF gx)))
    , ("matchingChain", matchingChainProp @t (genChain gx gy) (maybeSumGen gy (genHF gx)))
    ]

associativeProps_
    :: forall t f a.
     ( SemigroupIn t f
     , Interpret (NonEmptyBy t) f
     , TestHBifunctor t
     , TestHFunctor (NonEmptyBy t)
     , Functor f
     , Show (t f (t f f) a)     , Eq (t f (t f f) a)
     , Show (t (t f f) f a)     , Eq (t (t f f) f a)
     , Show (t f f a)           , Eq (t f f a)
     , Show (t f (NonEmptyBy t f) a)    , Eq (t f (NonEmptyBy t f) a)
     , Show (NonEmptyBy t f a)          , Eq (NonEmptyBy t f a)
     , Show (t f (Chain1 t f) a), Eq (t f (Chain1 t f) a)
     , Show (f a)               , Eq (f a)
     )
    => Gen (f a)
    -> [TestTree]
associativeProps_ gx = [ hbifunctorProps @t gx, associativeProps @t gx ]

tensorProps_
    :: forall t i f a.
     ( MonoidIn t i f
     , Interpret (NonEmptyBy t) f
     , Interpret (ListBy t) f
     , TestHBifunctor t
     , TestHFunctor (ListBy t)
     , TestHFunctor (NonEmptyBy t)
     , Functor f
     , Show (t f (t f f) a)          , Eq (t f (t f f) a)
     , Show (t (t f f) f a)          , Eq (t (t f f) f a)
     , Show (t f i a)            , Eq (t f i a)
     , Show (t i f a)            , Eq (t i f a)
     , Show (t f (ListBy t f) a)         , Eq (t f (ListBy t f) a)
     , Show (t f (NonEmptyBy t f) a)         , Eq (t f (NonEmptyBy t f) a)
     , Show (t f (Chain t i f) a), Eq (t f (Chain t i f) a)
     , Show (t f (Chain1 t f) a)     , Eq (t f (Chain1 t f) a)
     , Show (t f f a)                , Eq (t f f a)
     , Show (ListBy t f a)               , Eq (ListBy t f a)
     , Show (NonEmptyBy t f a)               , Eq (NonEmptyBy t f a)
     , Show (i a)                  , Eq (i a)
     , Show (f a)                    , Eq (f a)
     )
    => Gen (f a)
    -> Maybe (Gen (i a))
    -> [TestTree]
tensorProps_ gx gy = associativeProps_ @t gx ++ [ tensorProps @t gx gy ]

matchableProps_
    :: forall t i f a.
     ( Matchable t i
     , Interpret (NonEmptyBy t) f
     , Interpret (ListBy t) f
     , MonoidIn t i f
     , TestHBifunctor t
     , TestHFunctor (ListBy t)
     , TestHFunctor (NonEmptyBy t)
     , Functor f
     , Show (t f (t f f) a)          , Eq (t f (t f f) a)
     , Show (t (t f f) f a)          , Eq (t (t f f) f a)
     , Show (t f i a)            , Eq (t f i a)
     , Show (t i f a)            , Eq (t i f a)
     , Show (t f (ListBy t f) a)         , Eq (t f (ListBy t f) a)
     , Show (t f (NonEmptyBy t f) a)         , Eq (t f (NonEmptyBy t f) a)
     , Show (t f (Chain t i f) a), Eq (t f (Chain t i f) a)
     , Show (t f (Chain1 t f) a)     , Eq (t f (Chain1 t f) a)
     , Show (t f f a)                , Eq (t f f a)
     , Show (ListBy t f a)               , Eq (ListBy t f a)
     , Show (NonEmptyBy t f a)               , Eq (NonEmptyBy t f a)
     , Show (i a)                  , Eq (i a)
     , Show (f a)                    , Eq (f a)
     )
    => Gen (f a)
    -> Maybe (Gen (i a))
    -> [TestTree]
matchableProps_ gx gy = tensorProps_ @t gx gy ++ [ matchableProps @t gx gy ]

hbifunctorTests :: TestTree
hbifunctorTests = testGroup "HBifunctors"
    [ testGroup "Sum"      $ matchableProps_      @(:+:)   listGen Nothing
    , testGroup "Sum'"     $ matchableProps_      @Sum     listGen Nothing
    , testGroup "Product"  $ matchableProps_      @(:*:)   listGen (Just (pure Proxy))
    , testGroup "Product'" $ matchableProps_      @Product listGen (Just (pure Proxy))
    , testGroup "These1"   $ tensorProps_       @These1  listGen Nothing
    , testGroup "LeftF"    $ associativeProps_ @LeftF   listGen
    , testGroup "Joker"    $ associativeProps_ @Joker   listGen
    , testGroup "RightF"   $ associativeProps_ @RightF  listGen
    , testGroup "Day"      $ matchableProps_      @Day     (Const . S.Sum <$> intGen)
                                                           (Just (Identity <$> intGen))
    , testGroup "Comp"     $ tensorProps_       @Comp    (Gen.list (Range.linear 0 3) intGen)
                                                           (Just (Identity <$> intGen))
    ]