either-n-0.1.0.0: test/Either3Tests.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}

-- | Laws for 'Either3'.
module Either3Tests (
  either3Tests,
) where

import Control.DeepSeq (rnf)
import Control.Lens (FoldableWithIndex (..), FunctorWithIndex (..), TraversableWithIndex (..), each, over, preview, set, toListOf, view)
import Control.Monad.Zip (munzip, mzip)
import Data.Bifunctor (bimap)
import Data.Data (gmapQ, gmapT, showConstr, toConstr)
import Data.Either3
import Data.Functor.Classes (Eq1 (..), Eq2 (..), Ord1 (..), Ord2 (..), Show1 (..), Show2 (..))
import Data.Functor.Identity (Identity (..))
import Data.Lens.Injection (_I1, _I2, _I3)
import GHC.Generics (from, from1, to, to1)
import Gens (genEither3, genFnInt, genInt, genString)
import Hedgehog
import Hedgehog.Function (apply, fn)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Laws

type E = Either3 Int Int

subject :: Subject E E E
subject =
  Subject "Either3" (genEither3 genInt genInt) id id

subject2 :: Subject2 (Either3 Int) (Either3 Int) (Either3 Int)
subject2 =
  Subject2 "Either3" (genEither3 genInt) id id

genE :: Gen (Either3 Int String Int)
genE =
  genEither3 genInt genString genInt

either3Tests :: Laws
either3Tests =
  concat
    [ semigroupLaws subject
    , functorLaws subject
    , applicativeLaws subject
    , monadLaws subject
    , altLaws subject
    , extendLaws subject
    , selectiveLaws subject
    , foldableLaws subject
    , traversableLaws subject
    , bifunctorLaws subject2
    , bifoldableLaws subject2
    , bitraversableLaws subject2
    , swapLaws subject2
    , classesAgree
    , indexedLaws
    , eachLaws
    , prismLawsVia "Either3 Injection1" _I1 genE id id genInt
    , prismLawsVia "Either3 Injection2" _I2 genE id id genString
    , prismLawsVia "Either3 Injection3" _I3 genE id id genInt
    , [("Either3 NFData", property (forAll genE >>= \x -> rnf x === ()))]
    , genericLaws
    , monadZipLaws
    , opticsLaws
    , isoLaws "Either3 either3ACB" either3ACB (g3 genInt Gen.bool genString) (g3 genInt genString Gen.bool)
    , isoLaws "Either3 either3BAC" either3BAC (g3 genInt Gen.bool genString) (g3 Gen.bool genInt genString)
    , isoLaws "Either3 either3BCA" either3BCA (g3 genInt Gen.bool genString) (g3 Gen.bool genString genInt)
    , isoLaws "Either3 either3CAB" either3CAB (g3 genInt Gen.bool genString) (g3 genString genInt Gen.bool)
    , isoLaws "Either3 either3CBA" either3CBA (g3 genInt Gen.bool genString) (g3 genString Gen.bool genInt)
    , reorderLaws
    , prismLawsVia "Either3 AsEither3" _Either3 genE id id genE
    ]

-- | The lifted classes agree with 'Eq', 'Ord' and 'Show'.
classesAgree :: Laws
classesAgree =
  [ ("Either3 Eq1 agrees with Eq", agree2 (\x y -> liftEq (==) x y === (x == y)))
  , ("Either3 Eq2 agrees with Eq", agree2 (\x y -> liftEq2 (==) (==) x y === (x == y)))
  , ("Either3 Ord1 agrees with Ord", agree2 (\x y -> liftCompare compare x y === compare x y))
  , ("Either3 Ord2 agrees with Ord", agree2 (\x y -> liftCompare2 compare compare x y === compare x y))
  ,
    ( "Either3 Show1 agrees with Show"
    , property $ do
        x <- forAll genE
        d <- forAll (Gen.int (Range.linear 0 11))
        liftShowsPrec showsPrec showList d x "" === showsPrec d x ""
    )
  ,
    ( "Either3 Show2 agrees with Show"
    , property $ do
        x <- forAll genE
        d <- forAll (Gen.int (Range.linear 0 11))
        liftShowsPrec2 showsPrec showList showsPrec showList d x "" === showsPrec d x ""
    )
  ]
 where
  agree2 p =
    property $ do
      x <- forAll genE
      same <- forAll Gen.bool
      y <- if same then pure x else forAll genE
      p x y

indexedLaws :: Laws
indexedLaws =
  [
    ( "Either3 imap agrees with fmap"
    , property $ do
        x <- forAll genE
        f <- forAll genFnInt
        imap (const (apply f)) x === fmap (apply f) x
    )
  ,
    ( "Either3 ifoldMap agrees with foldMap"
    , property $ do
        x <- forAll genE
        f <- forAll (fn (Gen.list (Range.linear 0 3) genInt))
        ifoldMap (const (apply f)) x === foldMap (apply f) x
    )
  ,
    ( "Either3 itraverse agrees with traverse"
    , property $ do
        x <- forAll genE
        f <- forAll (fn (Gen.maybe genInt))
        itraverse (const (apply f)) x === traverse (apply f) x
    )
  ]

eachLaws :: Laws
eachLaws =
  [
    ( "Either3 each identity"
    , property $ do
        x <- forAll genSame
        runIdentity (each Identity x) === x
    )
  ,
    ( "Either3 each visits the one value"
    , property $ do
        x <- forAll genSame
        length (toListOf each x) === 1
    )
  ,
    ( "Either3 each composition"
    , property $ do
        x <- forAll genSame
        f <- forAll genFnInt
        g <- forAll genFnInt
        over each (apply f . apply g) x === over each (apply f) (over each (apply g) x)
    )
  ]
 where
  genSame = genEither3 genInt genInt genInt

-- | The derived 'Generic', 'Generic1' and 'Data' instances.
genericLaws :: Laws
genericLaws =
  [
    ( "Either3 Generic to . from"
    , property $ do
        x <- forAll genE
        to (from x) === x
    )
  ,
    ( "Either3 Generic1 to1 . from1"
    , property $ do
        x <- forAll genE
        to1 (from1 x) === x
    )
  ,
    ( "Either3 Data gmapT id"
    , property $ do
        x <- forAll genE
        gmapT id x === x
    )
  ,
    ( "Either3 Data toConstr names the constructor"
    , property $ do
        x <- forAll genE
        showConstr (toConstr x) === foldEither3 (const "First3") (const "Second3") (const "Third3") x
    )
  ,
    ( "Either3 Data gmapQ visits the one field"
    , property $ do
        x <- forAll genE
        length (gmapQ (const ()) x) === 1
    )
  ]

monadZipLaws :: Laws
monadZipLaws =
  [
    ( "Either3 mzip naturality"
    , property $ do
        ma <- forAll (genEither3 genInt genInt genInt)
        mb <- forAll (genEither3 genInt genInt genInt)
        f <- forAll genFnInt
        g <- forAll genFnInt
        fmap (bimap (apply f) (apply g)) (mzip ma mb) === mzip (fmap (apply f) ma) (fmap (apply g) mb)
    )
  ,
    ( "Either3 mzip information preservation"
    , property $ do
        ma <- forAll (genEither3 genInt genInt genInt)
        f <- forAll genFnInt
        let mb = fmap (apply f) ma
        munzip (mzip ma mb) === (ma, mb)
    )
  ]

-- | The classy optics, defined by 'setEither3' and 'matchEither3', obey the lens laws.
opticsLaws :: Laws
opticsLaws =
  [
    ( "Either3 HasEither3 view . set"
    , property $ do
        s <- forAll genE
        v <- forAll genE
        view either3 (set either3 v s) === v
    )
  ,
    ( "Either3 HasEither3 set . view"
    , property $ do
        s <- forAll genE
        set either3 (view either3 s) s === s
    )
  ,
    ( "Either3 HasEither3 set . set"
    , property $ do
        s <- forAll genE
        v <- forAll genE
        v' <- forAll genE
        set either3 v' (set either3 v s) === set either3 v' s
    )
  ,
    ( "Either3 setEither3 agrees with set either3"
    , property $ do
        s <- forAll genE
        v <- forAll genE
        setEither3 v s === set either3 v s
    )
  ,
    ( "Either3 matchEither3 agrees with preview _Either3"
    , property $ do
        s <- forAll genE
        matchEither3 s === preview _Either3 s
    )
  ]

g3 :: Gen a -> Gen b -> Gen c -> Gen (Either3 a b c)
g3 =
  genEither3

-- | The reordering isomorphisms compose as permutations do.
reorderLaws :: Laws
reorderLaws =
  [
    ( "Either3 either3CAB undoes either3BCA"
    , property $ do
        x <- forAll (g3 genInt Gen.bool genString)
        view either3CAB (view either3BCA x) === x
    )
  ,
    ( "Either3 either3ACB, either3BAC and either3CBA are involutions"
    , property $ do
        x <- forAll (g3 genInt genInt genInt)
        view either3ACB (view either3ACB x) === x
        view either3BAC (view either3BAC x) === x
        view either3CBA (view either3CBA x) === x
    )
  ]