either-n-0.1.0.0: test/Either3TTests.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}
{- HLINT ignore "Use <&>" -}
{- HLINT ignore "Monad law, left identity" -}
{- HLINT ignore "Use asks" -}

-- | Laws for 'Either3T'.
module Either3TTests (
  either3TTests,
) where

import Control.DeepSeq (rnf)
import Control.Lens (each, over, preview, review, set, toListOf, view, _Wrapped)
import Control.Monad.Cont (Cont, callCC, runCont)
import Control.Monad.Except (catchError, throwError)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.RWS (RWS, runRWS)
import Control.Monad.Reader (Reader, ask, local, reader, runReader)
import Control.Monad.State (State, get, put, runState)
import Control.Monad.Writer (Writer, listen, pass, runWriter, tell, writer)
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 Data.String (fromString)
import GHC.Generics (from, from1, to, to1)
import Gens (genEither3, genFnInt, genInt, genString)
import Hedgehog
import Hedgehog.Function (Fn, apply, fn)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Laws

-- | Values with list effects.
genList3 :: Gen a -> Gen b -> Gen c -> Gen (Either3TList a b c)
genList3 a b c =
  Either3T <$> Gen.list (Range.linear 0 3) (genEither3 a b c)

genIdentity3 :: Gen a -> Gen b -> Gen c -> Gen (Either3TIdentity a b c)
genIdentity3 a b c =
  Either3T . Identity <$> genEither3 a b c

subjectIdentity :: Subject (Either3TIdentity Int Int) (Either3TIdentity Int Int) (Either3TIdentity Int Int)
subjectIdentity =
  Subject "Either3T Identity" (genIdentity3 genInt genInt) id id

subjectList :: Subject (Either3TList Int Int) (Either3TList Int Int) (Either3TList Int Int)
subjectList =
  Subject "Either3T []" (genList3 genInt genInt) id id

subject2 :: Subject2 (Either3TList Int) (Either3TList Int) (Either3TList Int)
subject2 =
  Subject2 "Either3T []" (genList3 genInt) id id

genL :: Gen (Either3TList Int String Int)
genL =
  genList3 genInt genString genInt

genI :: Gen (Either3TIdentity Int String Int)
genI =
  genIdentity3 genInt genString genInt

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

either3TTests :: Laws
either3TTests =
  concat
    [ semigroupLaws subjectIdentity
    , semigroupLaws subjectList
    , functorLaws subjectIdentity
    , functorLaws subjectList
    , applicativeLaws subjectIdentity
    , applicativeLaws subjectList
    , monadLaws subjectIdentity
    , monadLaws subjectList
    , altLaws subjectIdentity
    , altLaws subjectList
    , extendLaws subjectIdentity
    , extendLaws subjectList
    , selectiveLaws subjectIdentity
    , selectiveLaws subjectList
    , foldableLaws subjectList
    , traversableLaws subjectList
    , bifunctorLaws subject2
    , bifoldableLaws subject2
    , bitraversableLaws subject2
    , swapLaws subject2
    , wrappedLaws
    , either3IdentityLaws
    , classesAgree
    , optics
    , either3TOptics
    , isoLaws "Either3T [] either3TACB" either3TACB (genList3 genInt Gen.bool genString) (genList3 genInt genString Gen.bool)
    , isoLaws "Either3T [] either3TBAC" either3TBAC (genList3 genInt Gen.bool genString) (genList3 Gen.bool genInt genString)
    , isoLaws "Either3T [] either3TBCA" either3TBCA (genList3 genInt Gen.bool genString) (genList3 Gen.bool genString genInt)
    , isoLaws "Either3T [] either3TCAB" either3TCAB (genList3 genInt Gen.bool genString) (genList3 genString genInt Gen.bool)
    , isoLaws "Either3T [] either3TCBA" either3TCBA (genList3 genInt Gen.bool genString) (genList3 genString Gen.bool genInt)
    , reorderTLaws
    , prismLawsVia "Either3T [] AsEither3T" _Either3T genL id id genL
    , prismLawsVia "Either3T Identity Injection1" _I1 genI id id genInt
    , prismLawsVia "Either3T Identity Injection2" _I2 genI id id genString
    , prismLawsVia "Either3T Identity Injection3" _I3 genI id id genInt
    , prismLawsVia "Either3T Identity AsEither3" _Either3 genI id id genE
    , monadStateLaws
    , monadReaderLaws
    , monadFailLaws
    , monadIOLaws
    , monadWriterLaws
    , monadErrorLaws
    , monadRWSLaws
    , monadContLaws
    , monadZipLaws
    , genericLaws
    , [("Either3T [] NFData", property (forAll genL >>= \x -> rnf x === ()))]
    ]

-- | '_Wrapped' is an isomorphism.
wrappedLaws :: Laws
wrappedLaws =
  [
    ( "Either3T [] _Wrapped view . review"
    , property $ do
        x <- forAll (Gen.list (Range.linear 0 3) genE)
        view _Wrapped (review _Wrapped x :: Either3TList Int String Int) === x
    )
  ,
    ( "Either3T [] _Wrapped review . view"
    , property $ do
        t <- forAll genL
        review _Wrapped (view _Wrapped t) === t
    )
  ]

-- | 'either3Identity' is an isomorphism.
either3IdentityLaws :: Laws
either3IdentityLaws =
  [
    ( "either3Identity review . view"
    , property $ do
        x <- forAll genE
        review either3Identity (view either3Identity x) === x
    )
  ,
    ( "either3Identity view . review"
    , property $ do
        t <- forAll genI
        view either3Identity (review either3Identity t) === t
    )
  ,
    ( "either3Identity changes type as fmap does"
    , property $ do
        x <- forAll genE
        f <- forAll genFnInt
        over either3Identity (fmap (apply f)) x === fmap (apply f) x
    )
  ,
    ( "either3Identity agrees with _Wrapped"
    , property $ do
        x <- forAll genE
        view either3Identity x === review _Wrapped (Identity x)
    )
  ]

-- | 'Eq', 'Ord', 'Show' and the lifted classes agree with those of the wrapped value.
classesAgree :: Laws
classesAgree =
  [ ("Either3T [] Eq agrees with the wrapped value", agree2 (\x y -> (x == y) === (view _Wrapped x == view _Wrapped y)))
  , ("Either3T [] Ord agrees with the wrapped value", agree2 (\x y -> compare x y === compare (view _Wrapped x) (view _Wrapped y)))
  , ("Either3T [] Eq1 agrees with Eq", agree2 (\x y -> liftEq (==) x y === (x == y)))
  , ("Either3T [] Eq2 agrees with Eq", agree2 (\x y -> liftEq2 (==) (==) x y === (x == y)))
  , ("Either3T [] Ord1 agrees with Ord", agree2 (\x y -> liftCompare compare x y === compare x y))
  , ("Either3T [] Ord2 agrees with Ord", agree2 (\x y -> liftCompare2 compare compare x y === compare x y))
  ,
    ( "Either3T [] Show shows the wrapped value"
    , property $ do
        x <- forAll genL
        show x === "Either3T " ++ showsPrec 11 (view _Wrapped x) ""
    )
  ,
    ( "Either3T [] Show1 agrees with Show"
    , property $ do
        x <- forAll genL
        d <- forAll (Gen.int (Range.linear 0 11))
        liftShowsPrec showsPrec showList d x "" === showsPrec d x ""
    )
  ,
    ( "Either3T [] Show2 agrees with Show"
    , property $ do
        x <- forAll genL
        d <- forAll (Gen.int (Range.linear 0 11))
        liftShowsPrec2 showsPrec showList showsPrec showList d x "" === showsPrec d x ""
    )
  ,
    ( "Either3T [] each visits every value"
    , property $ do
        x <- forAll (genList3 genInt genInt genInt)
        toListOf each x === concatMap (toListOf each) (view _Wrapped x)
    )
  ]
 where
  agree2 p =
    property $ do
      x <- forAll genL
      same <- forAll Gen.bool
      y <- if same then pure x else forAll genL
      p x y

-- | Lens laws for 'either3', and 'reviewEither3' in an effectful @f@.
optics :: Laws
optics =
  [
    ( "Either3T Identity HasEither3 view . set"
    , property $ do
        s <- forAll genI
        v <- forAll genE
        view either3 (set either3 v s) === v
    )
  ,
    ( "Either3T Identity HasEither3 set . view"
    , property $ do
        s <- forAll genI
        set either3 (view either3 s) s === s
    )
  ,
    ( "Either3T Identity HasEither3 set . set"
    , property $ do
        s <- forAll genI
        v <- forAll genE
        v' <- forAll genE
        set either3 v' (set either3 v s) === set either3 v' s
    )
  ,
    ( "Either3T [] reviewEither3 is pure"
    , property $ do
        e <- forAll genE
        (review reviewEither3 e :: Either3TList Int String Int) === Either3T [e]
    )
  ]

-- | 'setEither3' and 'matchEither3' on @Either3T Identity@, and the classy optics for 'Either3T'.
either3TOptics :: Laws
either3TOptics =
  [
    ( "Either3T Identity setEither3 agrees with set either3"
    , property $ do
        s <- forAll genI
        v <- forAll genE
        setEither3 v s === set either3 v s
    )
  ,
    ( "Either3T Identity matchEither3 agrees with preview _Either3"
    , property $ do
        s <- forAll genI
        matchEither3 s === preview _Either3 s
    )
  ,
    ( "Either3T [] HasEither3T view . set"
    , property $ do
        s <- forAll genL
        v <- forAll genL
        view either3T (set either3T v s) === v
    )
  ,
    ( "Either3T [] HasEither3T set . view"
    , property $ do
        s <- forAll genL
        set either3T (view either3T s) s === s
    )
  ,
    ( "Either3T [] HasEither3T set . set"
    , property $ do
        s <- forAll genL
        v <- forAll genL
        v' <- forAll genL
        set either3T v' (set either3T v s) === set either3T v' s
    )
  ,
    ( "Either3T [] matchEither3T agrees with preview _Either3T"
    , property $ do
        s <- forAll genL
        matchEither3T s === preview _Either3T s
    )
  ]

-- | Each reordering of 'Either3T' applies the reordering of 'Either3' under @f@.
reorderTLaws :: Laws
reorderTLaws =
  [ agreeUnder "either3TACB" (view either3TACB) (view either3ACB)
  , agreeUnder "either3TBAC" (view either3TBAC) (view either3BAC)
  , agreeUnder "either3TBCA" (view either3TBCA) (view either3BCA)
  , agreeUnder "either3TCAB" (view either3TCAB) (view either3CAB)
  , agreeUnder "either3TCBA" (view either3TCBA) (view either3CBA)
  ]
 where
  agreeUnder name t e =
    ( fromString ("Either3T [] " ++ name ++ " agrees with the Either3 reordering under f")
    , property $ do
        x <- forAll (genList3 genInt Gen.bool genString)
        t x === over _Wrapped (fmap e) x
    )

type StateT3 = Either3T (State Int) Int Int

runS :: StateT3 a -> Int -> (Either3 Int Int a, Int)
runS =
  runState . view _Wrapped

monadStateLaws :: Laws
monadStateLaws =
  [
    ( "Either3T State get >>= put"
    , property $ do
        s <- forAll genInt
        runS (get >>= put) s === runS (pure ()) s
    )
  ,
    ( "Either3T State put >> get"
    , property $ do
        s <- forAll genInt
        s0 <- forAll genInt
        runS (put s >> get) s0 === runS (put s >> pure s) s0
    )
  ,
    ( "Either3T State put >> put"
    , property $ do
        s <- forAll genInt
        s' <- forAll genInt
        s0 <- forAll genInt
        runS (put s >> put s') s0 === runS (put s') s0
    )
  ]

type ReaderT3 = Either3T (Reader Int) Int Int

runR :: ReaderT3 a -> Int -> Either3 Int Int a
runR =
  runReader . view _Wrapped

monadReaderLaws :: Laws
monadReaderLaws =
  [
    ( "Either3T Reader local f ask"
    , property $ do
        f <- forAll genFnInt
        r <- forAll genInt
        runR (local (apply f) ask) r === runR (fmap (apply f) ask) r
    )
  ,
    ( "Either3T Reader local id"
    , property $ do
        m <- genReader
        r <- forAll genInt
        runR (local id m) r === runR m r
    )
  ,
    ( "Either3T Reader local composition"
    , property $ do
        m <- genReader
        f <- forAll genFnInt
        g <- forAll genFnInt
        r <- forAll genInt
        runR (local (apply f) (local (apply g) m)) r === runR (local (apply g . apply f) m) r
    )
  ,
    ( "Either3T Reader local does not change the environment for what follows"
    , property $ do
        m <- genReader
        f <- forAll genFnInt
        r <- forAll genInt
        runR (local (apply f) m >> ask) r === fmap (const r) (runR (local (apply f) m) r)
    )
  ]
 where
  genReader :: PropertyT IO (ReaderT3 Int)
  genReader =
    do
      h <- forAll (fn (genEither3 genInt genInt genInt))
      pure (Either3T (reader (apply (h :: Fn Int (Either3 Int Int Int)))))

monadFailLaws :: Laws
monadFailLaws =
  [
    ( "Either3T Maybe fail s >>= k"
    , property $ do
        s <- forAll genString
        k <- forAll (fn (genEither3 genInt genInt genInt))
        (fail s >>= review reviewEither3 . apply (k :: Fn Int (Either3 Int Int Int)) :: Either3TMaybe Int Int Int) === Either3T Nothing
    )
  ]

monadIOLaws :: Laws
monadIOLaws =
  [
    ( "Either3T IO liftIO . pure"
    , property $ do
        x <- forAll genInt
        r <- evalIO (view _Wrapped (liftIO (pure x) :: Either3TIO Int Int Int))
        r === Third3 x
    )
  ,
    ( "Either3T IO liftIO distributes over >>="
    , property $ do
        x <- forAll genInt
        f <- forAll genFnInt
        lhs <- evalIO (view _Wrapped (liftIO (pure x >>= pure . apply f) :: Either3TIO Int Int Int))
        rhs <- evalIO (view _Wrapped (liftIO (pure x) >>= liftIO . pure . apply f :: Either3TIO Int Int Int))
        lhs === rhs
    )
  ]

type WriterT3 = Either3T (Writer [Int]) Int Int

runW :: WriterT3 a -> (Either3 Int Int a, [Int])
runW =
  runWriter . view _Wrapped

genWriter :: PropertyT IO (WriterT3 Int)
genWriter =
  do
    e <- forAll (genEither3 genInt genInt genInt)
    w <- forAll genList'
    pure (Either3T (writer (e, w)))

genList' :: Gen [Int]
genList' =
  Gen.list (Range.linear 0 3) genInt

monadWriterLaws :: Laws
monadWriterLaws =
  [
    ( "Either3T Writer tell mempty"
    , property $
        runW (tell mempty) === runW (pure ())
    )
  ,
    ( "Either3T Writer tell w1 >> tell w2"
    , property $ do
        w1 <- forAll genList'
        w2 <- forAll genList'
        runW (tell w1 >> tell w2) === runW (tell (w1 <> w2))
    )
  ,
    ( "Either3T Writer writer (a, w)"
    , property $ do
        a <- forAll genInt
        w <- forAll genList'
        runW (writer (a, w)) === runW (tell w >> pure a)
    )
  ,
    ( "Either3T Writer listen (pure a)"
    , property $ do
        a <- forAll genInt
        runW (listen (pure a)) === runW (pure (a, mempty))
    )
  ,
    ( "Either3T Writer listen (tell w)"
    , property $ do
        w <- forAll genList'
        runW (listen (tell w)) === runW (tell w >> pure ((), w))
    )
  ,
    ( "Either3T Writer fmap fst . listen"
    , property $ do
        m <- genWriter
        runW (fmap fst (listen m)) === runW m
    )
  ,
    ( "Either3T Writer pass (tell w >> pure (a, f))"
    , property $ do
        w <- forAll genList'
        a <- forAll genInt
        f <- forAll (fn genList')
        runW (pass (tell w >> pure (a, apply f))) === runW (tell (apply f w) >> pure a)
    )
  ]

type ErrorT3 = Either3T (Either Int) Int Int

monadErrorLaws :: Laws
monadErrorLaws =
  [
    ( "Either3T Either throwError e >>= k"
    , property $ do
        e <- forAll genInt
        k <- forAll (fn (genEither3 genInt genInt genInt))
        (throwError e >>= review reviewEither3 . apply (k :: Fn Int (Either3 Int Int Int)) :: ErrorT3 Int) === throwError e
    )
  ,
    ( "Either3T Either catchError (throwError e) h"
    , property $ do
        e <- forAll genInt
        h <- forAll (fn (genEither3 genInt genInt genInt))
        (catchError (throwError e) (review reviewEither3 . apply h) :: ErrorT3 Int) === review reviewEither3 (apply h e)
    )
  ,
    ( "Either3T Either catchError (pure a) h"
    , property $ do
        a <- forAll genInt
        h <- forAll (fn (genEither3 genInt genInt genInt))
        (catchError (pure a) (review reviewEither3 . apply h) :: ErrorT3 Int) === pure a
    )
  ,
    ( "Either3T Either catchError m throwError"
    , property $ do
        m <- forAll (Either3T <$> Gen.either genInt (genEither3 genInt genInt genInt))
        catchError m throwError === (m :: ErrorT3 Int)
    )
  ]

monadRWSLaws :: Laws
monadRWSLaws =
  [
    ( "Either3T RWS reads, writes and updates state"
    , property $ do
        r <- forAll genInt
        s0 <- forAll genInt
        let m = ask >>= \x -> tell [x] >> get >>= \s -> put (s + x) :: Either3T (RWS Int [Int] Int) Int Int ()
        runRWS (view _Wrapped m) r s0 === (Third3 (), s0 + r, [r])
    )
  ]

type ContT3 = Either3T (Cont (Either3 Int Int Int)) Int Int

runC :: ContT3 Int -> Either3 Int Int Int
runC m =
  runCont (view _Wrapped m) id

monadContLaws :: Laws
monadContLaws =
  [
    ( "Either3T Cont callCC (const m)"
    , property $ do
        e <- forAll (genEither3 genInt genInt genInt)
        runC (callCC (const (review reviewEither3 e))) === e
    )
  ,
    ( "Either3T Cont callCC escapes"
    , property $ do
        a <- forAll genInt
        e <- forAll (genEither3 genInt genInt genInt)
        runC (callCC (\k -> k a >> review reviewEither3 e)) === Third3 a
    )
  ]

monadZipLaws :: Laws
monadZipLaws =
  [
    ( "Either3T [] mzip naturality"
    , property $ do
        ma <- forAll (genList3 genInt genInt genInt)
        mb <- forAll (genList3 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)
    )
  ,
    ( "Either3T [] mzip information preservation"
    , property $ do
        ma <- forAll (genList3 genInt genInt genInt)
        f <- forAll genFnInt
        let mb = fmap (apply f) ma
        munzip (mzip ma mb) === (ma, mb)
    )
  ]

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