filepather-0.7.0.0: test/Laws.hs

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

-- | Laws of lenses and prisms.
module Laws (
  Laws,
  lensLaws,
  prismLaws,
) where

import Control.Lens (ALens', APrism', cloneLens, clonePrism, preview, review, set, view)
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
    )
  ]