document-build-0.2.0.0: test/Laws.hs

{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wall #-}

{- | Laws of the kinds of optics that the instances of names have: identity,
lens, prism and affine traversal, and the law of a manifest.

Each law reads the optic through 'cloneLens' for a lens, 'clonePrism' for a
prism and 'cloneTraversal' for an affine traversal, so a test fails to
compile where an instance is of a weaker kind than its comment says.
-}
module Laws (
  Laws,
  manifestLaw,
  identityLaws,
  lensLaws,
  prismLaws,
  affineLaws,
) where

import Control.Lens (ALens', APrism', ATraversal', cloneLens, clonePrism, cloneTraversal, preview, review, set, toListOf, traverseOf, view)
import Data.Char (ord)
import Data.Functor.Compose (Compose (..))
import Data.Functor.Identity (Identity (..))
import Data.String (fromString)
import Hedgehog
import Hedgehog.Function (fn, forAllFn)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range

type Laws = [(PropertyName, Property)]

-- | The law of a manifest: it rebuilds every value as it was.
manifestLaw :: (Eq s, Show s) => String -> (s -> s) -> Gen s -> Laws
manifestLaw name m genS =
  [
    ( fromString (name <> " == id")
    , property $
        do
          s <- forAll genS
          m s === s
    )
  ]

-- | The laws of an identity: viewing gives the value, and setting replaces it.
identityLaws :: (Eq s, Show s) => String -> ALens' s s -> Gen s -> Laws
identityLaws name o genS =
  [
    ( fromString (name <> " identity")
    , property $
        do
          s <- forAll genS
          t <- forAll genS
          view (cloneLens o) s === s
          set (cloneLens o) t s === t
    )
  ]

-- | The lens laws: view-set, set-view and set-set.
lensLaws :: (Eq s, Show s, Eq a, Show a) => String -> ALens' s a -> Gen s -> Gen a -> Laws
lensLaws name l genS genA =
  [
    ( fromString (name <> " view . set")
    , property $
        do
          s <- forAll genS
          a <- forAll genA
          view (cloneLens l) (set (cloneLens l) a s) === a
    )
  ,
    ( fromString (name <> " set . view")
    , property $
        do
          s <- forAll genS
          set (cloneLens l) (view (cloneLens l) s) s === s
    )
  ,
    ( fromString (name <> " set . set")
    , property $
        do
          s <- forAll genS
          a <- forAll genA
          b <- forAll genA
          set (cloneLens l) b (set (cloneLens l) a s) === set (cloneLens l) b s
    )
  ]

-- | The prism laws: preview-review and review-preview.
prismLaws :: (Eq s, Show s, Eq a, Show a) => String -> APrism' s a -> Gen s -> Gen a -> Laws
prismLaws name p genS genA =
  [
    ( fromString (name <> " preview . review")
    , property $
        do
          a <- forAll genA
          preview (clonePrism p) (review (clonePrism p) a) === Just a
    )
  ,
    ( fromString (name <> " review . preview")
    , property $
        do
          s <- forAll genS
          maybe s (review (clonePrism p)) (preview (clonePrism p) s) === s
    )
  ]

{- | The laws of an affine traversal: identity, composition, and at most one
target. The functions of the composition law are generated with hedgehog-fn,
over a key that each target is mapped to by its 'show', so that targets
without an instance of 'Hedgehog.Function.Arg', such as 'String', are
covered.
-}
affineLaws :: (Eq s, Show s, Eq a, Show a) => String -> ATraversal' s a -> Gen s -> Gen a -> Laws
affineLaws name o genS genA =
  [
    ( fromString (name <> " traverse pure")
    , property $
        do
          s <- forAll genS
          traverseOf (cloneTraversal o) Identity s === Identity s
    )
  ,
    ( fromString (name <> " traverse composition")
    , property $
        do
          s <- forAll genS
          f <- (. key) <$> forAllFn (fn (Gen.maybe genA))
          g <- (. key) <$> forAllFn (fn (Gen.list (Range.linear 0 3) genA))
          fmap (traverseOf (cloneTraversal o) f) (traverseOf (cloneTraversal o) g s)
            === getCompose (traverseOf (cloneTraversal o) (Compose . fmap f . g) s)
    )
  ,
    ( fromString (name <> " at most one target")
    , property $
        do
          s <- forAll genS
          assert (length (toListOf (cloneTraversal o) s) <= 1)
    )
  ]
 where
  key :: (Show a) => a -> Int
  key =
    foldr (\c k -> (k * 31 + ord c) `mod` 1000003) 7 . show