{- HLINT ignore "Alternative law, right identity" -}
{- HLINT ignore "Alternative law, left identity" -}
{- HLINT ignore "Monoid law, right identity" -}
{- HLINT ignore "Monoid law, left identity" -}
{- HLINT ignore "Functor law" -}
{- HLINT ignore "Use <$>" -}
{- HLINT ignore "Use mconcat" -}
{- HLINT ignore "Redundant id" -}
{- HLINT ignore "Reduce duplication" -}
{-
Copyright: (c) 2018-2020 Kowainik
SPDX-License-Identifier: MPL-2.0
Maintainer: Kowainik <xrom.xkov@gmail.com>
-}
module Test.Laws
( validationLawsSpec
) where
import Control.Applicative (Alternative (empty, (<|>)), Applicative (liftA2))
import Control.Selective ((<*?))
import Data.Bifunctor (bimap)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Semigroup (sconcat, stimes)
import Data.Text (Text)
import Hedgehog (Gen, forAll, forAllWith, (===))
import Test.Hspec (Spec, describe, it)
import Test.Hspec.Hedgehog (hedgehog)
import Validation (Validation (..))
import Test.Gen (Property, genEither, genFunction, genFunction2, genInt, genSmallInt, genSmallList,
genSmallText, genValidation)
validationLawsSpec :: Spec
validationLawsSpec = describe "Validation Property Tests" $ do
describe "Semigroup instance for Validation" $ do
it "Associativity: a <> (b <> c) ≡ (a <> b) <> c"
semigroupAssociativity
it "Concatenation: sconcat ≡ foldr1 (<>)"
semigroupConcatenation
it "Times: stimes n a ≡ foldr1 (<>) (replicate n a)"
semigroupTimes
describe "Monoid instance for Validation" $ do
it "Right Identity: x <> mempty ≡ x" monoidRightIdentity
it "Left Identity: mempty <> x ≡ x" monoidLeftIdentity
it "Associativity: mappend a (mappend b c) ≡ mappend (mappend a b) c"
monoidAssociativity
it "Concatenation: mconcat ≡ foldr mappend mempty"
monoidConcatenation
describe "Functor instance for Validation" $ do
it "Identity: fmap id ≡ id"
functorIdentity
it "Composition: map f . fmap g ≡ fmap (f . g)"
functorComposition
it "Const: fmap (const x) ≡ x <$"
functorConst
describe "Applicative instance for Validation" $ do
it "Identity: pure id <*> x ≡ x"
applicativeIdentity
it "Composition: pure (.) <*> f <*> g <*> x ≡ f <*> (g <*> x)"
applicativeComposition
it "Homomorphism: pure f <*> pure x ≡ pure (f x)"
applicativeHomomorphism
it "Interchange: f <*> pure x ≡ pure ($ x) <*> f"
applicativeInterchange
it "Apply Right: u *> v ≡ (id <$ u) <*> v" applicativeApplyRight
it "Apply Left: u <* v ≡ liftA2 const u v" applicativeApplyLeft
it "(<*>) via liftA2: (<*>) ≡ liftA2 id"
applicativeApViaLiftA2
it "liftA2 via (<*>): liftA2 f x y ≡ f <$> x <*> y"
applicativeLiftA2ViaAp
describe "Alternative instance for Validation" $ do
it "Associativity: a <|> (b <|> c) ≡ (a <|> b) <|> c"
alternativeAssociativity
it "Right Identity: x <|> empty ≡ x" alternativeRightIdentity
it "Left Identity: empty <|> x ≡ x" alternativeLeftIdentity
describe "Selective instance for Validation" $ do
it "Identity: x <*? pure id ≡ either id id <$> x"
selectiveIdentity
it "Distributivity: pure x <*? (y *> z) ≡ (pure x <*? y) *> (pure x <*? z)"
selectiveDistributivity
it "Associativity: x <*? (y <*? z) ≡ (f <$> x) <*? (g <$> y) <*? (h <$> z)"
selectiveAssociativity
----------------------------------------------------------------------------
-- Semigroup instance properties
----------------------------------------------------------------------------
semigroupAssociativity :: Property
semigroupAssociativity = checkAssotiativityFor (genValidation genSmallText) (<>)
semigroupConcatenation :: Property
semigroupConcatenation = do
let gen = genValidation genSmallText
a <- forAll gen
as <- forAll $ genSmallList gen
let ne = a :| as
sconcat ne === foldr1 (<>) ne
semigroupTimes :: Property
semigroupTimes = do
a <- forAll $ genValidation genSmallText
n <- forAll genSmallInt
stimes n a === foldr1 (<>) (replicate n a)
----------------------------------------------------------------------------
-- Monoid instance properties
----------------------------------------------------------------------------
monoidRightIdentity :: Property
monoidRightIdentity = hedgehog $ do
x <- forAll $ genValidation genSmallText
x <> mempty === x
monoidLeftIdentity :: Property
monoidLeftIdentity = hedgehog $ do
x <- forAll $ genValidation genSmallText
mempty <> x === x
monoidAssociativity :: Property
monoidAssociativity = checkAssotiativityFor (genValidation genSmallText) mappend
monoidConcatenation :: Property
monoidConcatenation = hedgehog $ do
as <- forAll $ genSmallList $ genValidation genSmallText
mconcat as === foldr mappend mempty as
----------------------------------------------------------------------------
-- Functor instance laws
----------------------------------------------------------------------------
functorIdentity :: Property
functorIdentity = hedgehog $ do
a <- forAll $ genValidation genSmallText
fmap id a === id a
functorComposition :: Property
functorComposition = hedgehog $ do
a <- forAll $ genValidation genInt
f <- forAllWith (const "f") genFunction
g <- forAllWith (const "g") genFunction
fmap f (fmap g a) === fmap (f . g) a
functorConst :: Property
functorConst = hedgehog $ do
a <- forAll $ genValidation genSmallText
let x = 'X'
fmap (const x) a === (x <$ a)
----------------------------------------------------------------------------
-- Applicative instance properties
----------------------------------------------------------------------------
applicativeIdentity :: Property
applicativeIdentity = hedgehog $ do
vx <- forAll $ genValidation genSmallText
(pure id <*> vx) === vx
applicativeComposition :: Property
applicativeComposition = hedgehog $ do
vf <- forAllWith (const "f") $ genValidation genFunction
vg <- forAllWith (const "g") $ genValidation genFunction
vx <- forAll $ genValidation genInt
(pure (.) <*> vf <*> vg <*> vx) === (vf <*> (vg <*> vx))
applicativeHomomorphism :: Property
applicativeHomomorphism = hedgehog $ do
f <- forAllWith (const "f") genFunction
x <- forAll genInt
(pure f <*> pure x) === pure @(Validation [Text]) (f x)
applicativeInterchange :: Property
applicativeInterchange = hedgehog $ do
vf <- forAllWith (const "f") $ genValidation genFunction
x <- forAll genInt
(vf <*> pure x) === (pure ($ x) <*> vf)
applicativeApplyRight :: Property
applicativeApplyRight = hedgehog $ do
let genVal = genValidation genInt
vy <- forAll genVal
vx <- forAll genVal
(vy *> vx) === ((id <$ vy) <*> vx)
applicativeApplyLeft :: Property
applicativeApplyLeft = hedgehog $ do
let genVal = genValidation genInt
vy <- forAll genVal
vx <- forAll genVal
(vy <* vx) === liftA2 const vy vx
applicativeApViaLiftA2 :: Property
applicativeApViaLiftA2 = hedgehog $ do
vf <- forAllWith (const "f") $ genValidation genFunction
vx <- forAll $ genValidation genInt
(vf <*> vx) === liftA2 id vf vx
applicativeLiftA2ViaAp :: Property
applicativeLiftA2ViaAp = hedgehog $ do
f <- forAllWith (const "f") genFunction2
vx <- forAll $ genValidation genInt
vy <- forAll $ genValidation genInt
liftA2 f vx vy === (f <$> vx <*> vy)
----------------------------------------------------------------------------
-- Alternative instance properties
----------------------------------------------------------------------------
alternativeAssociativity :: Property
alternativeAssociativity = checkAssotiativityFor (genValidation genSmallText) (<|>)
alternativeRightIdentity :: Property
alternativeRightIdentity = hedgehog $ do
x <- forAll $ genValidation genSmallText
(x <|> empty) === x
alternativeLeftIdentity :: Property
alternativeLeftIdentity = hedgehog $ do
x <- forAll $ genValidation genSmallText
(empty <|> x) === x
----------------------------------------------------------------------------
-- Selective instance properties
----------------------------------------------------------------------------
selectiveIdentity :: Property
selectiveIdentity = do
x <- forAll $ genValidation $ genEither genSmallText genSmallText
(x <*? pure id) === (either id id <$> x)
selectiveDistributivity :: Property
selectiveDistributivity = do
x <- forAll $ genEither genInt genInt
y <- forAllWith (const "y") $ genValidation genFunction
z <- forAllWith (const "z") $ genValidation genFunction
(pure x <*? (y *> z)) === ((pure x <*? y) *> (pure x <*? z))
selectiveAssociativity :: Property
selectiveAssociativity = do
x <- forAll $ genValidation $ genEither genInt genInt
y <- forAllWith (const "y") $ genValidation $ genEither genInt genFunction
z <- forAllWith (const "z") $ genValidation genFunction2
let f = fmap Right
let g a b = bimap (,b) ($ b) a
let h = uncurry
(x <*? (y <*? z)) === ((f <$> x) <*? (g <$> y) <*? (h <$> z))
----------------------------------------------------------------------------
-- Property helpers
----------------------------------------------------------------------------
{- | Property test for the associativity law:
@
a ⊗ (b ⊗ c) ≡ (a ⊗ b) ⊗ c
@
-}
checkAssotiativityFor
:: (Show a, Eq a)
=> Gen a
-> (a -> a -> a)
-> Property
checkAssotiativityFor gen op = hedgehog $ do
a <- forAll gen
b <- forAll gen
c <- forAll gen
a `op` (b `op` c) === (a `op` b) `op` c