Lens.hs

module Test.Laws.Lens
  ( -- * Lens Laws
    laws,
    injective,
    surjective,
    idempotent,
  )
where

import Lens.Micro (Lens', set)
import Lens.Micro.Extras (view)

import Hedgehog (Gen, PropertyT, diff, forAll, property)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.Hedgehog (testProperty)

-- ---------------------------------------------------------------------------------------------------------------------

laws :: (Show a, Eq a, Show b, Eq b) => Lens' a b -> String -> Gen a -> Gen b -> TestTree
laws p desc gen1 gen0 =
  testGroup
    (if null desc then "lens laws" else desc ++ " - lens laws")
    [ testProperty "1. injectivity" $ property (injective p gen1 gen0)
    , testProperty "2. surjectivity" $ property (surjective p gen1)
    , testProperty "3. idempotency" $ property (idempotent p gen1 gen0)
    ]

-- | Setters are injective. You get back what you put in:
--
-- @
-- 'view' p ('set' p x fx) == 'set' p x fx
-- @
injective :: (Monad m, Show a, Eq b, Show b) => Lens' a b -> Gen a -> Gen b -> PropertyT m ()
injective p gen1 gen0 = do
  fx <- forAll gen1
  x <- forAll gen0
  diff (view p (set p x fx)) (==) x

-- | Setters are surjective. Putting back what you got doesn't change anything:
--
-- @
-- 'set' p ('view' p fx) fx == fx
-- @
surjective :: (Monad m, Eq a, Show a) => Lens' a b -> Gen a -> PropertyT m ()
surjective p gen1 = do
  fx <- forAll gen1
  diff (set p (view p fx) fx) (==) fx

-- | Setters are idempotent. Setting twice is the same as setting once:
--
-- @
-- 'set' p x ('set' p x fx) == 'set' p x fx
-- @
idempotent :: (Monad m, Eq a, Show a, Show b) => Lens' a b -> Gen a -> Gen b -> PropertyT m ()
idempotent p gen1 gen0 = do
  fx <- forAll gen1
  x <- forAll gen0
  diff (set p x (set p x fx)) (==) (set p x fx)