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

-- | Monad properties
--
-- You will need @TypeApplications@ to use these.
module Test.Validity.Monad
    ( monadSpecOnValid
    , monadSpec
    , monadSpecOnArbitrary
    , monadSpecOnGens
    ) where

import Data.Data

import Control.Monad (ap)
import Data.GenValidity
import Test.QuickCheck.Gen (unGen)
import Test.QuickCheck.Random (mkQCGen)

import Test.Hspec
import Test.QuickCheck

import Test.Validity.Functions
import Test.Validity.Utils

{-# ANN module "HLint: ignore Use fmap" #-}

{-# ANN module "HLint: ignore Use <$>" #-}

{-# ANN module "HLint: ignore Use >=>" #-}

{-# ANN module "HLint: ignore Use id" #-}

{-# ANN module "HLint: ignore Monad law, left identity" #-}

{-# ANN module "HLint: ignore Monad law, right identity" #-}

{-# ANN module "HLint: ignore Avoid lambda" #-}

{-# ANN module "HLint: ignore Reduce duplication" #-}

returnTypeStr ::
       forall (m :: * -> *). (Typeable m)
    => String
returnTypeStr = unwords ["return", "::", "a", "->", nameOf @m, "a"]

bindTypeStr ::
       forall (m :: * -> *). (Typeable m)
    => String
bindTypeStr =
    unwords
        [ "(>>=)"
        , "::"
        , nameOf @m
        , "a"
        , "->"
        , "(b"
        , "->"
        , nameOf @m
        , "a)"
        , "->"
        , nameOf @m
        , "b"
        ]

-- | Standard test spec for properties of Monad instances for values generated with GenValid instances
--
-- Example usage:
--
-- > monadSpecOnValid @[]
monadSpecOnValid ::
       forall (f :: * -> *).
       (Eq (f Int), Show (f Int), Monad f, Typeable f, GenValid (f Int))
    => Spec
monadSpecOnValid = monadSpecWithInts @f genValid

-- | Standard test spec for properties of Monad instances for values generated with GenUnchecked instances
--
-- Example usage:
--
-- > monadSpec @[]
monadSpec ::
       forall (f :: * -> *).
       (Eq (f Int), Show (f Int), Monad f, Typeable f, GenUnchecked (f Int))
    => Spec
monadSpec = monadSpecWithInts @f genUnchecked

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

monadSpecWithInts ::
       forall (f :: * -> *). (Eq (f Int), Show (f Int), Monad f, Typeable f)
    => Gen (f Int)
    -> Spec
monadSpecWithInts gen =
    monadSpecOnGens
        @f
        @Int
        genUnchecked
        "int"
        gen
        (unwords [nameOf @f, "of ints"])
        gen
        (unwords [nameOf @f, "of ints"])
        ((+) <$> genUnchecked)
        "increments"
        (do s <- abs <$> genUnchecked
            pure $ \b -> unGen gen (mkQCGen b) s)
        "perturbations using the int"
        (do s <- abs <$> genUnchecked
            pure $ \b -> unGen gen (mkQCGen $ 2 * b) s)
        "perturbations using the double the int"
        (pure <$> ((+) <$> genUnchecked))
        (unwords [nameOf @f, "of additions"])

-- | Standard test spec for properties of Monad instances for values generated by given generators (and names for those generator).
--
-- Example usage:
--
-- > monadSpecOnGens
-- >     @[]
-- >     @Int
-- >     (pure 4)
-- >     "four"
-- >     (genListOf $ pure 5)
-- >     "list of fives"
-- >     (genListOf $ pure 6)
-- >     "list of sixes"
-- >     ((*) <$> genValid)
-- >     "factorisations"
-- >     (pure $ \a -> [a])
-- >     "singletonisation"
-- >     (pure $ \a -> [a])
-- >     "singletonisation"
-- >     (pure $ pure (+ 1))
-- >     "increment in list"
monadSpecOnGens ::
       forall (f :: * -> *) (a :: *) (b :: *) (c :: *).
       ( Show a
       , Eq a
       , Show (f a)
       , Show (f b)
       , Show (f c)
       , Eq (f a)
       , Eq (f b)
       , Eq (f c)
       , Monad f
       , Typeable f
       , Typeable a
       , Typeable b
       , Typeable c
       )
    => Gen a
    -> String
    -> Gen (f a)
    -> String
    -> Gen (f b)
    -> String
    -> Gen (a -> b)
    -> String
    -> Gen (a -> f b)
    -> String
    -> Gen (b -> f c)
    -> String
    -> Gen (f (a -> b))
    -> String
    -> Spec
monadSpecOnGens gena genaname gen genname genb genbname geng gengname genbf genbfname gencf gencfname genfab genfabname =
    parallel $
    describe ("Monad " ++ nameOf @f) $ do
        describe (unwords [returnTypeStr @f, "and", bindTypeStr @f]) $ do
            it
                (unwords
                     [ "satisfy the first Monad law: 'return a >>= k = k a' for"
                     , genDescr @a genaname
                     , "and"
                     , genDescr @(a -> f b) genbfname
                     ]) $
                equivalentOnGens2
                    (\a (Anon k) -> return a >>= k)
                    (\a (Anon k) -> k a)
                    ((,) <$> gena <*> (Anon <$> genbf))
                    shrinkNothing
            it
                (unwords
                     [ "satisfy the second Monad law: 'm >>= return = m' for"
                     , genDescr @(f a) genname
                     ]) $
                equivalentOnGen (\m -> m >>= return) (\m -> m) gen shrinkNothing
        describe (bindTypeStr @f) $
            it
                (unwords
                     [ "satisfies the third Monad law: 'm >>= (x -> k x >>= h) = (m >>= k) >>= h' for"
                     , genDescr @(f a) genname
                     , genDescr @(a -> f b) genbfname
                     , "and"
                     , genDescr @(b -> f c) gencfname
                     ]) $
            equivalentOnGens3
                (\m (Anon k) (Anon h) -> m >>= (\x -> k x >>= h))
                (\m (Anon k) (Anon h) -> (m >>= k) >>= h)
                ((,,) <$> gen <*> (Anon <$> genbf) <*> (Anon <$> gencf))
                shrinkNothing
        describe (unwords ["relation with Applicative", nameOf @f]) $ do
            it
                (unwords
                     ["satisfies 'pure = return' for", genDescr @(f a) genname]) $
                equivalentOnGen (pure @f) (return @f) gena shrinkNothing
            it
                (unwords
                     [ "satisfies '(<*>) = ap' for"
                     , genDescr @(f (a -> b)) genfabname
                     , "and"
                     , genDescr @(f a) genname
                     ]) $
                equivalentOnGens2
                    (\(Anon a) b -> a <*> b)
                    (\(Anon a) b -> ap a b)
                    ((,) <$> (Anon <$> genfab) <*> gen)
                    shrinkNothing
            it
                (unwords
                     [ "satisfies '(>>) = (*>)' for"
                     , genDescr @(f a) genname
                     , "and"
                     , genDescr @(f b) genbname
                     ]) $
                equivalentOnGens2 (>>) (*>) ((,) <$> gen <*> genb) shrinkNothing
        describe (unwords ["relation with Functor", nameOf @f]) $
            it
                (unwords
                     [ "satisfies 'fmap f xs = xs >>= return . f' for"
                     , genDescr @(a -> b) gengname
                     , "and"
                     , genDescr @(f a) genname
                     ]) $
            equivalentOnGens2
                (\(Anon f) xs -> fmap f xs)
                (\(Anon f) xs -> xs >>= (return . f))
                ((,) <$> (Anon <$> geng) <*> gen)
                shrinkNothing