casa-reoc-0.1.0.0: test/Laws.hs

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

-- | Laws of lenses, prisms and affine traversals (the classy optics recipe, Laws).
module Laws (
  Laws,
  lensLaws,
  prismLaws,
  affineLaws,
) where

import Control.Lens (ALens', APrism', Traversal', cloneLens, clonePrism, preview, review, set, toListOf, traverseOf, view)
import Data.Functor.Compose (Compose (..))
import Data.Functor.Identity (Identity (..))
import Data.String (fromString)
import Hedgehog

type Laws = [(PropertyName, Property)]

-- | 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.
affineLaws :: (Eq s, Show s, Eq a, Show a) => String -> Traversal' s a -> Gen s -> Gen a -> Laws
affineLaws name t genS genA =
  [
    ( fromString (name <> " traverse pure")
    , property $ do
        s <- forAll genS
        runIdentity (traverseOf t Identity s) === s
    )
  ,
    ( fromString (name <> " composition")
    , property $ do
        s <- forAll genS
        x <- forAll genA
        y <- forAll genA
        let f a = if a == x then Nothing else Just y
            g a = [a, x]
        fmap (traverseOf t f) (traverseOf t g s) === getCompose (traverseOf t (Compose . fmap f . g) s)
    )
  ,
    ( fromString (name <> " at most one target")
    , property $ do
        s <- forAll genS
        assert (length (toListOf t s) <= 1)
    )
  ]