{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Test.Validity.Ord
( ordSpecOnGen
, ordSpecOnValid
, ordSpecOnInvalid
, ordSpec
, ordSpecOnArbitrary
) where
import Data.Data
import Data.GenValidity
import Test.Hspec
import Test.QuickCheck
import Test.Validity.Functions
import Test.Validity.Relations
import Test.Validity.Utils
{-# ANN module "HLint: ignore Use <=" #-}
{-# ANN module "HLint: ignore Use >=" #-}
{-# ANN module "HLint: ignore Use <" #-}
{-# ANN module "HLint: ignore Use >" #-}
leTypeStr ::
forall a. Typeable a
=> String
leTypeStr = binRelStr @a "<="
geTypeStr ::
forall a. Typeable a
=> String
geTypeStr = binRelStr @a ">="
ltTypeStr ::
forall a. Typeable a
=> String
ltTypeStr = binRelStr @a "<"
gtTypeStr ::
forall a. Typeable a
=> String
gtTypeStr = binRelStr @a ">"
ordSpecOnValid ::
forall a. (Show a, Ord a, Typeable a, GenValid a)
=> Spec
ordSpecOnValid = ordSpecOnGen @a genValid "valid" shrinkValid
ordSpecOnInvalid ::
forall a. (Show a, Ord a, Typeable a, GenInvalid a)
=> Spec
ordSpecOnInvalid = ordSpecOnGen @a genInvalid "invalid" shrinkInvalid
ordSpec ::
forall a. (Show a, Ord a, Typeable a, GenUnchecked a)
=> Spec
ordSpec = ordSpecOnGen @a genUnchecked "unchecked" shrinkUnchecked
ordSpecOnArbitrary ::
forall a. (Show a, Ord a, Typeable a, Arbitrary a)
=> Spec
ordSpecOnArbitrary = ordSpecOnGen @a arbitrary "arbitrary" shrink
ordSpecOnGen ::
forall a. (Show a, Eq a, Ord a, Typeable a)
=> Gen a
-> String
-> (a -> [a])
-> Spec
ordSpecOnGen gen genname s =
parallel $ do
let name = nameOf @a
funlestr = leTypeStr @a
fungestr = geTypeStr @a
funltstr = ltTypeStr @a
fungtstr = gtTypeStr @a
cmple = (<=) @a
cmpge = (>=) @a
cmplt = (<) @a
cmpgt = (>) @a
gen2 = (,) <$> gen <*> gen
gen3 = (,,) <$> gen <*> gen <*> gen
s2 = shrinkT2 s
describe ("Ord " ++ name) $ do
describe funlestr $ do
it
(unwords
[ "is reflexive for"
, "\"" ++ genname
, name ++ "\"" ++ "'s"
]) $
reflexivityOnGen cmple gen s
it
(unwords
[ "is antisymmetric for"
, "\"" ++ genname
, name ++ "\"" ++ "'s"
]) $
antisymmetryOnGens cmple gen2 s
it
(unwords
[ "is transitive for"
, "\"" ++ genname
, name ++ "\"" ++ "'s"
]) $
transitivityOnGens cmple gen3 s
it
(unwords
[ "is equivalent to (\\a b -> compare a b /= GT) for"
, "\"" ++ genname
, name ++ "\"" ++ "'s"
]) $
equivalentOnGens2 cmple (\a b -> compare a b /= GT) gen2 s2
describe fungestr $ do
it
(unwords
[ "is reflexive for"
, "\"" ++ genname
, name ++ "\"" ++ "'s"
]) $
reflexivityOnGen cmpge gen s
it
(unwords
[ "is antisymmetric for"
, "\"" ++ genname
, name ++ "\"" ++ "'s"
]) $
antisymmetryOnGens cmpge gen2 s
it
(unwords
[ "is transitive for"
, "\"" ++ genname
, name ++ "\"" ++ "'s"
]) $
transitivityOnGens cmpge gen3 s
it
(unwords
[ "is equivalent to (\\a b -> compare a b /= LT) for"
, "\"" ++ genname
, name ++ "\"" ++ "'s"
]) $
equivalentOnGens2 cmpge (\a b -> compare a b /= LT) gen2 s2
describe funltstr $ do
it
(unwords
[ "is antireflexive for"
, "\"" ++ genname
, name ++ "\"" ++ "'s"
]) $
antireflexivityOnGen cmplt gen s
it
(unwords
[ "is transitive for"
, "\"" ++ genname
, name ++ "\"" ++ "'s"
]) $
transitivityOnGens cmplt gen3 s
it
(unwords
[ "is equivalent to (\\a b -> compare a b == LT) for"
, "\"" ++ genname
, name ++ "\"" ++ "'s"
]) $
equivalentOnGens2 cmplt (\a b -> compare a b == LT) gen2 s2
describe fungtstr $ do
it
(unwords
[ "is antireflexive for"
, "\"" ++ genname
, name ++ "\"" ++ "'s"
]) $
antireflexivityOnGen cmpgt gen s
it
(unwords
[ "is transitive for"
, "\"" ++ genname
, name ++ "\"" ++ "'s"
]) $
transitivityOnGens cmpgt gen3 s
it
(unwords
[ "is equivalent to (\\a b -> compare a b == GT) for"
, "\"" ++ genname
, name ++ "\"" ++ "'s"
]) $
equivalentOnGens2 cmpgt (\a b -> compare a b == GT) gen2 s2