either-n-0.1.0.0: test/Laws.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wall #-}
{- HLINT ignore "Redundant bimap" -}
{- HLINT ignore "Use second" -}
{- HLINT ignore "Use first" -}
{- HLINT ignore "Use bimap" -}
{- HLINT ignore "Monad law, right identity" -}
{- HLINT ignore "Monad law, left identity" -}
{- HLINT ignore "Use <$>" -}
{- HLINT ignore "Functor law" -}

{- | Type class laws, checked through an observation.

A 'Subject' generates a showable value, injects it into the type under test,
and observes the result as a comparable value. This lets the same laws check
a type with no 'Eq' or 'Show' instance, by observing it as one that has them.
-}
module Laws (
  Laws,
  Subject (..),
  Subject2 (..),
  semigroupLaws,
  functorLaws,
  applicativeLaws,
  monadLaws,
  altLaws,
  extendLaws,
  selectiveLaws,
  foldableLaws,
  traversableLaws,
  bifunctorLaws,
  bifoldableLaws,
  bitraversableLaws,
  swapLaws,
  prismLawsVia,
  isoLaws,
) where

import Control.Lens (APrism', AnIso', cloneIso, clonePrism, preview, review, view)
import Control.Selective (Selective (..))
import Data.Bifoldable (Bifoldable (..))
import Data.Bifunctor (Bifunctor (..))
import Data.Bifunctor.Swap (Swap (..))
import Data.Bitraversable (Bitraversable (..))
import Data.Functor.Alt (Alt (..))
import Data.Functor.Apply (Apply (..))
import Data.Functor.Bind (Bind (..))
import Data.Functor.Compose (Compose (..))
import Data.Functor.Extend (Extend (..))
import Data.Functor.Identity (Identity (..))
import Data.String (fromString)
import Gens (genFnInt, genInt)
import Hedgehog
import Hedgehog.Function (Fn, apply, fn)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

type Laws = [(PropertyName, Property)]

-- | Generate a @g x@, inject it into the type under test @t x@, and observe it as an @o x@.
data Subject g t o
  = Subject
      String
      (forall x. Gen x -> Gen (g x))
      (forall x. g x -> t x)
      (forall x. t x -> o x)

-- | As 'Subject', for a type constructor of two arguments.
data Subject2 g p o
  = Subject2
      String
      (forall x y. Gen x -> Gen y -> Gen (g x y))
      (forall x y. g x y -> p x y)
      (forall x y. p x y -> o x y)

law :: String -> String -> PropertyT IO () -> (PropertyName, Property)
law name l p =
  (fromString (name ++ " " ++ l), property p)

semigroupLaws :: (Semigroup (t Int), Show (g Int), Eq (o Int), Show (o Int)) => Subject g t o -> Laws
semigroupLaws (Subject name gen inj obs) =
  [ law name "semigroup associativity" $ do
      x <- inj <$> forAll (gen genInt)
      y <- inj <$> forAll (gen genInt)
      z <- inj <$> forAll (gen genInt)
      obs ((x <> y) <> z) === obs (x <> (y <> z))
  ]

functorLaws :: (Functor t, Show (g Int), Eq (o Int), Show (o Int)) => Subject g t o -> Laws
functorLaws (Subject name gen inj obs) =
  [ law name "functor identity" $ do
      x <- inj <$> forAll (gen genInt)
      obs (fmap id x) === obs x
  , law name "functor composition" $ do
      x <- inj <$> forAll (gen genInt)
      f <- forAll genFnInt
      g <- forAll genFnInt
      obs (fmap (apply f . apply g) x) === obs (fmap (apply f) (fmap (apply g) x))
  ]

applicativeLaws ::
  (Apply t, Applicative t, Show (g Int), Show (g (Fn Int Int)), Eq (o Int), Show (o Int)) =>
  Subject g t o ->
  Laws
applicativeLaws (Subject name gen inj obs) =
  [ law name "applicative identity" $ do
      v <- inj <$> forAll (gen genInt)
      obs (pure id <*> v) === obs v
  , law name "applicative composition" $ do
      u <- fmap apply . inj <$> forAll (gen genFnInt)
      v <- fmap apply . inj <$> forAll (gen genFnInt)
      w <- inj <$> forAll (gen genInt)
      obs (pure (.) <*> u <*> v <*> w) === obs (u <*> (v <*> w))
  , law name "applicative homomorphism" $ do
      f <- forAll genFnInt
      x <- forAll genInt
      obs (pure (apply f) <*> pure x) === obs (pure (apply f x))
  , law name "applicative interchange" $ do
      u <- fmap apply . inj <$> forAll (gen genFnInt)
      y <- forAll genInt
      obs (u <*> pure y) === obs (pure ($ y) <*> u)
  , law name "apply agrees with applicative" $ do
      u <- fmap apply . inj <$> forAll (gen genFnInt)
      v <- inj <$> forAll (gen genInt)
      obs (u <.> v) === obs (u <*> v)
  ]

monadLaws ::
  (Bind t, Monad t, Show (g Int), Eq (o Int), Show (o Int)) =>
  Subject g t o ->
  Laws
monadLaws (Subject name gen inj obs) =
  [ law name "monad left identity" $ do
      a <- forAll genInt
      k <- forAll (fn (gen genInt))
      obs (pure a >>= inj . apply k) === obs (inj (apply k a))
  , law name "monad right identity" $ do
      m <- inj <$> forAll (gen genInt)
      obs (m >>= pure) === obs m
  , law name "monad associativity" $ do
      m <- inj <$> forAll (gen genInt)
      k <- forAll (fn (gen genInt))
      h <- forAll (fn (gen genInt))
      obs ((m >>= inj . apply k) >>= inj . apply h) === obs (m >>= (\x -> inj (apply k x) >>= inj . apply h))
  , law name "bind agrees with monad" $ do
      m <- inj <$> forAll (gen genInt)
      k <- forAll (fn (gen genInt))
      obs (m >>- inj . apply k) === obs (m >>= inj . apply k)
  ]

altLaws :: (Alt t, Show (g Int), Eq (o Int), Show (o Int)) => Subject g t o -> Laws
altLaws (Subject name gen inj obs) =
  [ law name "alt associativity" $ do
      x <- inj <$> forAll (gen genInt)
      y <- inj <$> forAll (gen genInt)
      z <- inj <$> forAll (gen genInt)
      obs ((x <!> y) <!> z) === obs (x <!> (y <!> z))
  , law name "alt left distributivity" $ do
      x <- inj <$> forAll (gen genInt)
      y <- inj <$> forAll (gen genInt)
      f <- forAll genFnInt
      obs (apply f <$> (x <!> y)) === obs ((apply f <$> x) <!> (apply f <$> y))
  ]

-- | @duplicated . duplicated = fmap duplicated . duplicated@, observed at every level.
extendLaws ::
  (Extend t, Functor o, Show (g Int), Eq (o (o (o Int))), Show (o (o (o Int)))) =>
  Subject g t o ->
  Laws
extendLaws (Subject name gen inj obs) =
  [ law name "extend associativity" $ do
      x <- inj <$> forAll (gen genInt)
      let obs3 = obs . fmap (obs . fmap obs)
      obs3 (duplicated (duplicated x)) === obs3 (fmap duplicated (duplicated x))
  ]

-- | @x \<*? pure id = either id id \<$\> x@
selectiveLaws :: (Selective t, Show (g (Either Int Int)), Eq (o Int), Show (o Int)) => Subject g t o -> Laws
selectiveLaws (Subject name gen inj obs) =
  [ law name "selective identity" $ do
      x <- inj <$> forAll (gen (Gen.either genInt genInt))
      obs (select x (pure id)) === obs (either id id <$> x)
  ]

-- | @foldMap f = foldr (\\x acc -> f x <> acc) mempty@
foldableLaws :: (Foldable t, Show (g Int)) => Subject g t o -> Laws
foldableLaws (Subject name gen inj _) =
  [ law name "foldMap agrees with foldr" $ do
      x <- inj <$> forAll (gen genInt)
      f <- forAll (fn (Gen.list (Range.linear 0 3) genInt))
      foldMap (apply f) x === foldr (\a acc -> apply f a <> acc) [] x
  ]

traversableLaws :: (Traversable t, Show (g Int), Eq (o Int), Show (o Int)) => Subject g t o -> Laws
traversableLaws (Subject name gen inj obs) =
  [ law name "traversable identity" $ do
      x <- inj <$> forAll (gen genInt)
      obs (runIdentity (traverse Identity x)) === obs x
  , law name "traversable composition" $ do
      x <- inj <$> forAll (gen genInt)
      f <- forAll (fn (Gen.maybe genInt))
      g <- forAll (fn (Gen.list (Range.linear 0 3) genInt))
      let lhs = traverse (Compose . fmap (apply g) . apply f) x
          rhs = Compose (fmap (traverse (apply g)) (traverse (apply f) x))
      fmap (fmap obs) (getCompose lhs) === fmap (fmap obs) (getCompose rhs)
  ]

bifunctorLaws :: (Bifunctor p, Show (g Int Int), Eq (o Int Int), Show (o Int Int)) => Subject2 g p o -> Laws
bifunctorLaws (Subject2 name gen inj obs) =
  [ law name "bifunctor identity" $ do
      x <- inj <$> forAll (gen genInt genInt)
      obs (bimap id id x) === obs x
  , law name "bifunctor composition" $ do
      x <- inj <$> forAll (gen genInt genInt)
      f <- forAll genFnInt
      g <- forAll genFnInt
      h <- forAll genFnInt
      i <- forAll genFnInt
      obs (bimap (apply f . apply g) (apply h . apply i) x) === obs (bimap (apply f) (apply h) (bimap (apply g) (apply i) x))
  , law name "first and second agree with bimap" $ do
      x <- inj <$> forAll (gen genInt genInt)
      f <- forAll genFnInt
      g <- forAll genFnInt
      obs (first (apply f) (second (apply g) x)) === obs (bimap (apply f) (apply g) x)
  ]

-- | @bifoldMap f g = bifoldr (\\x acc -> f x <> acc) (\\y acc -> g y <> acc) mempty@
bifoldableLaws :: (Bifoldable p, Show (g Int Int)) => Subject2 g p o -> Laws
bifoldableLaws (Subject2 name gen inj _) =
  [ law name "bifoldMap agrees with bifoldr" $ do
      x <- inj <$> forAll (gen genInt genInt)
      f <- forAll (fn (Gen.list (Range.linear 0 3) genInt))
      g <- forAll (fn (Gen.list (Range.linear 0 3) genInt))
      bifoldMap (apply f) (apply g) x === bifoldr (\a acc -> apply f a <> acc) (\b acc -> apply g b <> acc) [] x
  ]

bitraversableLaws :: (Bitraversable p, Show (g Int Int), Eq (o Int Int), Show (o Int Int)) => Subject2 g p o -> Laws
bitraversableLaws (Subject2 name gen inj obs) =
  [ law name "bitraversable identity" $ do
      x <- inj <$> forAll (gen genInt genInt)
      obs (runIdentity (bitraverse Identity Identity x)) === obs x
  , law name "bitraversable composition" $ do
      x <- inj <$> forAll (gen genInt genInt)
      f <- forAll (fn (Gen.maybe genInt))
      g <- forAll (fn (Gen.maybe genInt))
      h <- forAll (fn (Gen.list (Range.linear 0 3) genInt))
      i <- forAll (fn (Gen.list (Range.linear 0 3) genInt))
      let lhs = bitraverse (Compose . fmap (apply h) . apply f) (Compose . fmap (apply i) . apply g) x
          rhs = Compose (fmap (bitraverse (apply h) (apply i)) (bitraverse (apply f) (apply g) x))
      fmap (fmap obs) (getCompose lhs) === fmap (fmap obs) (getCompose rhs)
  ]

swapLaws :: (Bifunctor p, Swap p, Show (g Int Int), Eq (o Int Int), Show (o Int Int)) => Subject2 g p o -> Laws
swapLaws (Subject2 name gen inj obs) =
  [ law name "swap involution" $ do
      x <- inj <$> forAll (gen genInt genInt)
      obs (swap (swap x)) === obs x
  , law name "swap naturality" $ do
      x <- inj <$> forAll (gen genInt genInt)
      f <- forAll genFnInt
      g <- forAll genFnInt
      obs (swap (bimap (apply f) (apply g) x)) === obs (bimap (apply g) (apply f) (swap x))
  ]

{- | Prism laws, generating a showable @g@, injecting it into @s@, and observing @s@ as @o@.

* @preview l (review l a) == Just a@
* @preview l s == Just a ==> review l a == s@
-}
prismLawsVia :: (Show g, Eq o, Show o, Eq a, Show a) => String -> APrism' s a -> Gen g -> (g -> s) -> (s -> o) -> Gen a -> Laws
prismLawsVia name p genG inj obs genA =
  [ law name "preview . review" $ do
      a <- forAll genA
      preview (clonePrism p) (review (clonePrism p) a) === Just a
  , law name "review . preview" $ do
      s <- inj <$> forAll genG
      obs (maybe s (review (clonePrism p)) (preview (clonePrism p) s)) === obs s
  ]

{- | Isomorphism laws.

* @view l (review l a) == a@
* @review l (view l s) == s@
-}
isoLaws :: (Eq s, Show s, Eq a, Show a) => String -> AnIso' s a -> Gen s -> Gen a -> Laws
isoLaws name l genS genA =
  [ law name "view . review" $ do
      a <- forAll genA
      view (cloneIso l) (review (cloneIso l) a) === a
  , law name "review . view" $ do
      s <- forAll genS
      review (cloneIso l) (view (cloneIso l) s) === s
  ]