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

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

import Control.Monad (ap)
import Data.Data
import Data.GenValidity
import Data.Kind (Type)
import Test.Hspec
import Test.QuickCheck
import Test.QuickCheck.Gen (unGen)
import Test.QuickCheck.Random (mkQCGen)
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 :: Type -> Type).
  (Typeable m) =>
  String
returnTypeStr :: forall (m :: * -> *). Typeable m => String
returnTypeStr = [String] -> String
unwords [String
"return", String
"::", String
"a", String
"->", forall {k} (a :: k). Typeable a => String
nameOf @m, String
"a"]

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

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

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

monadSpecWithInts ::
  forall (f :: Type -> Type).
  (Eq (f Int), Show (f Int), Monad f, Typeable f) =>
  Gen (f Int) ->
  Spec
monadSpecWithInts :: forall (f :: * -> *).
(Eq (f Int), Show (f Int), Monad f, Typeable f) =>
Gen (f Int) -> Spec
monadSpecWithInts Gen (f Int)
gen =
  forall (f :: * -> *) a b c.
(Show 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
    @f
    @Int
    forall a. GenValid a => Gen a
genValid
    String
"int"
    Gen (f Int)
gen
    ([String] -> String
unwords [forall {k} (a :: k). Typeable a => String
nameOf @f, String
"of ints"])
    Gen (f Int)
gen
    ([String] -> String
unwords [forall {k} (a :: k). Typeable a => String
nameOf @f, String
"of ints"])
    (forall a. Num a => a -> a -> a
(+) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. GenValid a => Gen a
genValid)
    String
"increments"
    ( do
        Int
s <- Gen Int
genListLength
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Int
b -> forall a. Gen a -> QCGen -> Int -> a
unGen Gen (f Int)
gen (Int -> QCGen
mkQCGen Int
b) Int
s
    )
    String
"perturbations using the int"
    ( do
        Int
s <- Gen Int
genListLength
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ \Int
b -> forall a. Gen a -> QCGen -> Int -> a
unGen Gen (f Int)
gen (Int -> QCGen
mkQCGen forall a b. (a -> b) -> a -> b
$ Int
2 forall a. Num a => a -> a -> a
* Int
b) Int
s
    )
    String
"perturbations using the double the int"
    (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Num a => a -> a -> a
(+) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. GenValid a => Gen a
genValid))
    ([String] -> String
unwords [forall {k} (a :: k). Typeable a => String
nameOf @f, String
"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 :: Type -> Type) (a :: Type) (b :: Type) (c :: Type).
  ( Show 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 :: forall (f :: * -> *) a b c.
(Show 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 Gen a
gena String
genaname Gen (f a)
gen String
genname Gen (f b)
genb String
genbname Gen (a -> b)
geng String
gengname Gen (a -> f b)
genbf String
genbfname Gen (b -> f c)
gencf String
gencfname Gen (f (a -> b))
genfab String
genfabname =
  forall a. SpecWith a -> SpecWith a
parallel forall a b. (a -> b) -> a -> b
$
    forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (String
"Monad " forall a. [a] -> [a] -> [a]
++ forall {k} (a :: k). Typeable a => String
nameOf @f) forall a b. (a -> b) -> a -> b
$ do
      forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe ([String] -> String
unwords [forall (m :: * -> *). Typeable m => String
returnTypeStr @f, String
"and", forall (m :: * -> *). Typeable m => String
bindTypeStr @f]) forall a b. (a -> b) -> a -> b
$ do
        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
          ( [String] -> String
unwords
              [ String
"satisfy the first Monad law: 'return a >>= k = k a' for",
                forall {k} (a :: k). Typeable a => String -> String
genDescr @a String
genaname,
                String
"and",
                forall {k} (a :: k). Typeable a => String -> String
genDescr @(a -> f b) String
genbfname
              ]
          )
          forall a b. (a -> b) -> a -> b
$ forall a b c.
(Show a, Show b, Show c, Eq c) =>
(a -> b -> c)
-> (a -> b -> c) -> Gen (a, b) -> ((a, b) -> [(a, b)]) -> Property
equivalentOnGens2
            (\a
a (Anon a -> f b
k) -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> f b
k)
            (\a
a (Anon a -> f b
k) -> a -> f b
k a
a)
            ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
gena forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. a -> Anon a
Anon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (a -> f b)
genbf))
            forall a. a -> [a]
shrinkNothing
        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
          ( [String] -> String
unwords
              [ String
"satisfy the second Monad law: 'm >>= return = m' for",
                forall {k} (a :: k). Typeable a => String -> String
genDescr @(f a) String
genname
              ]
          )
          forall a b. (a -> b) -> a -> b
$ forall a b.
(Show a, Show b, Eq b) =>
(a -> b) -> (a -> b) -> Gen a -> (a -> [a]) -> Property
equivalentOnGen (\f a
m -> f a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return) (\f a
m -> f a
m) Gen (f a)
gen forall a. a -> [a]
shrinkNothing
      forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (forall (m :: * -> *). Typeable m => String
bindTypeStr @f)
        forall a b. (a -> b) -> a -> b
$ forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
          ( [String] -> String
unwords
              [ String
"satisfies the third Monad law: 'm >>= (x -> k x >>= h) = (m >>= k) >>= h' for",
                forall {k} (a :: k). Typeable a => String -> String
genDescr @(f a) String
genname,
                forall {k} (a :: k). Typeable a => String -> String
genDescr @(a -> f b) String
genbfname,
                String
"and",
                forall {k} (a :: k). Typeable a => String -> String
genDescr @(b -> f c) String
gencfname
              ]
          )
        forall a b. (a -> b) -> a -> b
$ forall a b c d.
(Show a, Show b, Show c, Show d, Eq d) =>
(a -> b -> c -> d)
-> (a -> b -> c -> d)
-> Gen (a, b, c)
-> ((a, b, c) -> [(a, b, c)])
-> Property
equivalentOnGens3
          (\f a
m (Anon a -> f b
k) (Anon b -> f c
h) -> f a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\a
x -> a -> f b
k a
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> f c
h))
          (\f a
m (Anon a -> f b
k) (Anon b -> f c
h) -> (f a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> f b
k) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> f c
h)
          ((,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (f a)
gen forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. a -> Anon a
Anon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (a -> f b)
genbf) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. a -> Anon a
Anon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (b -> f c)
gencf))
          forall a. a -> [a]
shrinkNothing
      forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe ([String] -> String
unwords [String
"relation with Applicative", forall {k} (a :: k). Typeable a => String
nameOf @f]) forall a b. (a -> b) -> a -> b
$ do
        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
          ( [String] -> String
unwords
              [String
"satisfies 'pure = return' for", forall {k} (a :: k). Typeable a => String -> String
genDescr @(f a) String
genname]
          )
          forall a b. (a -> b) -> a -> b
$ forall a b.
(Show a, Show b, Eq b) =>
(a -> b) -> (a -> b) -> Gen a -> (a -> [a]) -> Property
equivalentOnGen (forall (f :: * -> *) a. Applicative f => a -> f a
pure @f) (forall (m :: * -> *) a. Monad m => a -> m a
return @f) Gen a
gena forall a. a -> [a]
shrinkNothing
        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
          ( [String] -> String
unwords
              [ String
"satisfies '(<*>) = ap' for",
                forall {k} (a :: k). Typeable a => String -> String
genDescr @(f (a -> b)) String
genfabname,
                String
"and",
                forall {k} (a :: k). Typeable a => String -> String
genDescr @(f a) String
genname
              ]
          )
          forall a b. (a -> b) -> a -> b
$ forall a b c.
(Show a, Show b, Show c, Eq c) =>
(a -> b -> c)
-> (a -> b -> c) -> Gen (a, b) -> ((a, b) -> [(a, b)]) -> Property
equivalentOnGens2
            (\(Anon f (a -> b)
a) f a
b -> f (a -> b)
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f a
b)
            (\(Anon f (a -> b)
a) f a
b -> forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap f (a -> b)
a f a
b)
            ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. a -> Anon a
Anon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (f (a -> b))
genfab) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (f a)
gen)
            forall a. a -> [a]
shrinkNothing
        forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
          ( [String] -> String
unwords
              [ String
"satisfies '(>>) = (*>)' for",
                forall {k} (a :: k). Typeable a => String -> String
genDescr @(f a) String
genname,
                String
"and",
                forall {k} (a :: k). Typeable a => String -> String
genDescr @(f b) String
genbname
              ]
          )
          forall a b. (a -> b) -> a -> b
$ forall a b c.
(Show a, Show b, Show c, Eq c) =>
(a -> b -> c)
-> (a -> b -> c) -> Gen (a, b) -> ((a, b) -> [(a, b)]) -> Property
equivalentOnGens2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>) ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (f a)
gen forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (f b)
genb) forall a. a -> [a]
shrinkNothing
      forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe ([String] -> String
unwords [String
"relation with Functor", forall {k} (a :: k). Typeable a => String
nameOf @f])
        forall a b. (a -> b) -> a -> b
$ forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
          ( [String] -> String
unwords
              [ String
"satisfies 'fmap f xs = xs >>= return . f' for",
                forall {k} (a :: k). Typeable a => String -> String
genDescr @(a -> b) String
gengname,
                String
"and",
                forall {k} (a :: k). Typeable a => String -> String
genDescr @(f a) String
genname
              ]
          )
        forall a b. (a -> b) -> a -> b
$ forall a b c.
(Show a, Show b, Show c, Eq c) =>
(a -> b -> c)
-> (a -> b -> c) -> Gen (a, b) -> ((a, b) -> [(a, b)]) -> Property
equivalentOnGens2
          (\(Anon a -> b
f) f a
xs -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f f a
xs)
          (\(Anon a -> b
f) f a
xs -> f a
xs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f))
          ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. a -> Anon a
Anon forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (a -> b)
geng) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen (f a)
gen)
          forall a. a -> [a]
shrinkNothing