filepather-0.8.0.0: test/OpticsTests.hs

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}

{- | The laws of the classy optics of every data type: the coverage of each
sum by its generator, the manifest of each data type, and the laws of the
kind of every instance of every name, including the identity instances of
names and the inherited instances.

'FilePather' and 'Tracked' hold functions, so they are observed by applying
them to a generated file path, and trail.
-}
module OpticsTests (
  opticsTests,
) where

import Control.Lens (cloneLens, from, has, set, view)
import Control.Monad.Reader (ReaderT, runReaderT)
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Gens
import Hedgehog
import Hedgehog.Function (Fn, apply, fn)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Laws
import System.FilePather
import Prelude hiding (cycle)

opticsTests :: Laws
opticsTests =
  [ ("cover Repetition", prop_coverRepetition)
  , ("cover Cycle", prop_coverCycle)
  , ("inherits", prop_inherits)
  ]
    -- Identity instances of names, for their target types
    <> identityLaws "stepName String" stepName genName
    <> identityLaws "stepInput FilePath" stepInput genPath
    <> identityLaws "steps [Step]" steps (Gen.list (Range.linear 0 3) genStep)
    <> identityLaws "once ()" once (pure ())
    <> identityLaws "repeatable ()" repeatable (pure ())
    <> identityLaws "file FilePath" file genPath
    <> [("pathFunction (FilePath -> f a) identity", prop_identityPathFunction)]
    -- Step
    <> manifestLaw "lawNamesStep" lawNamesStep genStep
    <> identityLaws "step Step" step genStep
    <> lensLaws "stepName Step" stepName genStep genName
    <> lensLaws "stepInput Step" stepInput genStep genPath
    -- Trail
    <> manifestLaw "lawNamesTrail" lawNamesTrail genTrail
    <> identityLaws "trail Trail" trail genTrail
    <> lensLaws "steps Trail" steps genTrail (Gen.list (Range.linear 0 3) genStep)
    -- Repetition
    <> manifestLaw "lawNamesRepetition" lawNamesRepetition genRepetition
    <> identityLaws "repetition Repetition" repetition genRepetition
    <> prismLaws "once Repetition" once genRepetition (pure ())
    <> prismLaws "repeatable Repetition" repeatable genRepetition (pure ())
    -- ReproducesInput
    <> manifestLaw "lawNamesReproducesInput" lawNamesReproducesInput genReproducesInput
    <> identityLaws "reproducesInput ReproducesInput" reproducesInput genReproducesInput
    <> lensLaws "file ReproducesInput" file genReproducesInput genPath
    <> lensLaws "step ReproducesInput" step genReproducesInput genStep
    <> lensLaws "trail ReproducesInput" trail genReproducesInput genTrail
    <> lensLaws "stepName ReproducesInput" stepName genReproducesInput genName
    <> lensLaws "stepInput ReproducesInput" stepInput genReproducesInput genPath
    <> lensLaws "steps ReproducesInput" steps genReproducesInput (Gen.list (Range.linear 0 3) genStep)
    -- RepeatsStep
    <> manifestLaw "lawNamesRepeatsStep" lawNamesRepeatsStep genRepeatsStep
    <> identityLaws "repeatsStep RepeatsStep" repeatsStep genRepeatsStep
    <> lensLaws "step RepeatsStep" step genRepeatsStep genStep
    <> lensLaws "trail RepeatsStep" trail genRepeatsStep genTrail
    <> lensLaws "stepName RepeatsStep" stepName genRepeatsStep genName
    <> lensLaws "stepInput RepeatsStep" stepInput genRepeatsStep genPath
    <> lensLaws "steps RepeatsStep" steps genRepeatsStep (Gen.list (Range.linear 0 3) genStep)
    -- Cycle
    <> manifestLaw "lawNamesCycle" lawNamesCycle genCycle
    <> identityLaws "cycle Cycle" cycle genCycle
    <> prismLaws "reproducesInput Cycle" reproducesInput genCycle genReproducesInput
    <> prismLaws "repeatsStep Cycle" repeatsStep genCycle genRepeatsStep
    <> affineLaws "file Cycle" file genCycle genPath
    <> affineLaws "step Cycle" step genCycle genStep
    <> affineLaws "trail Cycle" trail genCycle genTrail
    <> affineLaws "stepName Cycle" stepName genCycle genName
    <> affineLaws "stepInput Cycle" stepInput genCycle genPath
    <> affineLaws "steps Cycle" steps genCycle (Gen.list (Range.linear 0 3) genStep)
    -- FilePather
    <> [ ("lawNamesFilePather == id", prop_lawNamesFilePather)
       , ("filePather FilePather identity", prop_identityFilePather)
       , ("pathFunction FilePather view . set", prop_pathFunctionViewSet)
       , ("pathFunction FilePather set . view", prop_pathFunctionSetView)
       , ("pathFunction FilePather set . set", prop_pathFunctionSetSet)
       , -- Tracked
         ("lawNamesTracked == id", prop_lawNamesTracked)
       , ("tracked Tracked identity", prop_identityTracked)
       , ("filePather Tracked view . set", prop_filePatherTrackedViewSet)
       , ("filePather Tracked set . view", prop_filePatherTrackedSetView)
       , ("filePather Tracked set . set", prop_filePatherTrackedSetSet)
       , ("pathFunction Tracked view . set", prop_pathFunctionTrackedViewSet)
       , ("pathFunction Tracked set . view", prop_pathFunctionTrackedSetView)
       , ("pathFunction Tracked set . set", prop_pathFunctionTrackedSetSet)
       ]

prop_coverRepetition :: Property
prop_coverRepetition =
  property $
    do
      x <- forAll genRepetition
      cover 10 "once" (has once x)
      cover 10 "repeatable" (has repeatable x)

prop_coverCycle :: Property
prop_coverCycle =
  property $
    do
      x <- forAll genCycle
      cover 10 "reproducesInput" (has reproducesInput x)
      cover 10 "repeatsStep" (has repeatsStep x)

-- | The checks of inheritance compile, so each is @()@.
prop_inherits :: Property
prop_inherits =
  withTests 1 . property $
    concat [inheritsReproducesInput, inheritsRepeatsStep, inheritsCycle, inheritsTracked] === replicate 7 ()

-- FilePather, observed at a file path

genFilePather :: Gen (Fn Int [Int])
genFilePather =
  genFilePatherList

-- | A function from file paths, to set with 'pathFunction'.
genPathFunction :: Gen (Fn Int [Int])
genPathFunction =
  fn genIntList

pathFunctionOf :: Fn Int [Int] -> FilePath -> [Int]
pathFunctionOf f =
  apply f . pathKey

at :: FilePather f a -> FilePath -> f a
at =
  view (cloneLens pathFunction)

prop_identityPathFunction :: Property
prop_identityPathFunction =
  property $
    do
      g <- pathFunctionOf <$> forAll genPathFunction
      h <- pathFunctionOf <$> forAll genPathFunction
      p <- forAll genPath
      view (cloneLens pathFunction) g p === g p
      set pathFunction h g p === h p

prop_lawNamesFilePather :: Property
prop_lawNamesFilePather =
  property $
    do
      x <- toFilePather <$> forAll genFilePather
      p <- forAll genPath
      at (lawNamesFilePather x) p === at x p

prop_identityFilePather :: Property
prop_identityFilePather =
  property $
    do
      x <- toFilePather <$> forAll genFilePather
      y <- toFilePather <$> forAll genFilePather
      p <- forAll genPath
      at (view (cloneLens filePather) x) p === at x p
      at (set filePather y x) p === at y p

prop_pathFunctionViewSet :: Property
prop_pathFunctionViewSet =
  property $
    do
      x <- toFilePather <$> forAll genFilePather
      g <- pathFunctionOf <$> forAll genPathFunction
      p <- forAll genPath
      view (cloneLens pathFunction) (set pathFunction g x) p === g p

prop_pathFunctionSetView :: Property
prop_pathFunctionSetView =
  property $
    do
      x <- toFilePather <$> forAll genFilePather
      p <- forAll genPath
      at (set pathFunction (view (cloneLens pathFunction) x) x) p === at x p

prop_pathFunctionSetSet :: Property
prop_pathFunctionSetSet =
  property $
    do
      x <- toFilePather <$> forAll genFilePather
      g <- pathFunctionOf <$> forAll genPathFunction
      h <- pathFunctionOf <$> forAll genPathFunction
      p <- forAll genPath
      at (set pathFunction h (set pathFunction g x)) p === at (set pathFunction h x) p

-- Tracked, observed at a trail and a file path

type Result a = Either Cycle (Outputs, a)

genResult :: Gen (Result Int)
genResult =
  Gen.frequency
    [ (1, Left <$> genCycle)
    , (4, fmap Right ((,) <$> Gen.list (Range.linear 0 2) ((,) <$> genPath <*> genStep) <*> genInt))
    ]

genTracked :: Gen (Fn Int [Result Int])
genTracked =
  fn (Gen.list (Range.linear 0 2) genResult)

toTracked :: Fn Int [Result Int] -> Tracked [] Int
toTracked f =
  view (from trackedFunction) (\t p -> apply f (pathKey (p <> show t)))

run :: Tracked f a -> Trail -> FilePath -> f (Result a)
run =
  view trackedFunction

prop_lawNamesTracked :: Property
prop_lawNamesTracked =
  property $
    do
      x <- toTracked <$> forAll genTracked
      t <- forAll genTrail
      p <- forAll genPath
      run (lawNamesTracked x) t p === run x t p

prop_identityTracked :: Property
prop_identityTracked =
  property $
    do
      x <- toTracked <$> forAll genTracked
      y <- toTracked <$> forAll genTracked
      t <- forAll genTrail
      p <- forAll genPath
      run (view (cloneLens tracked) x) t p === run x t p
      run (set tracked y x) t p === run y t p

-- | The type constructor of the 'FilePather' of a 'Tracked' value in @[]@.
type Inner = ReaderT Trail (ExceptT Cycle [])

runInner :: Inner a -> Trail -> [Either Cycle a]
runInner r t =
  runExceptT (runReaderT r t)

{- | The 'FilePather' of a generated 'Tracked' value, to set with
'filePather'.
-}
genTrackedFilePather :: PropertyT IO (FilePather Inner (Outputs, Int))
genTrackedFilePather =
  view (cloneLens filePather) . toTracked <$> forAll genTracked

prop_filePatherTrackedViewSet :: Property
prop_filePatherTrackedViewSet =
  property $
    do
      x <- toTracked <$> forAll genTracked
      y <- genTrackedFilePather
      t <- forAll genTrail
      p <- forAll genPath
      runInner (at (view (cloneLens filePather) (set filePather y x)) p) t === runInner (at y p) t

prop_filePatherTrackedSetView :: Property
prop_filePatherTrackedSetView =
  property $
    do
      x <- toTracked <$> forAll genTracked
      t <- forAll genTrail
      p <- forAll genPath
      run (set filePather (view (cloneLens filePather) x) x) t p === run x t p

prop_filePatherTrackedSetSet :: Property
prop_filePatherTrackedSetSet =
  property $
    do
      x <- toTracked <$> forAll genTracked
      y <- genTrackedFilePather
      z <- genTrackedFilePather
      t <- forAll genTrail
      p <- forAll genPath
      run (set filePather z (set filePather y x)) t p === run (set filePather z x) t p

prop_pathFunctionTrackedViewSet :: Property
prop_pathFunctionTrackedViewSet =
  property $
    do
      x <- toTracked <$> forAll genTracked
      y <- at <$> genTrackedFilePather
      t <- forAll genTrail
      p <- forAll genPath
      runInner (view (cloneLens pathFunction) (set pathFunction y x) p) t === runInner (y p) t

prop_pathFunctionTrackedSetView :: Property
prop_pathFunctionTrackedSetView =
  property $
    do
      x <- toTracked <$> forAll genTracked
      t <- forAll genTrail
      p <- forAll genPath
      run (set pathFunction (view (cloneLens pathFunction) x) x) t p === run x t p

prop_pathFunctionTrackedSetSet :: Property
prop_pathFunctionTrackedSetSet =
  property $
    do
      x <- toTracked <$> forAll genTracked
      y <- at <$> genTrackedFilePather
      z <- at <$> genTrackedFilePather
      t <- forAll genTrail
      p <- forAll genPath
      run (set pathFunction z (set pathFunction y x)) t p === run (set pathFunction z x) t p