filepather-0.7.0.0: test/TrackedTests.hs

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

{- | Laws of the instances of 'Tracked', of the steps that check a trail, and
of the optics of trails and cycles.

A 'Tracked' value is a function of a trail and a file path, so it is observed
by applying it to a generated trail and file path. Functions are generated
with hedgehog-fn.
-}
module TrackedTests (
  trackedTests,
) where

import Control.Applicative (Alternative (..), Const (..))
import Control.Lens (from, view, _Cons, _Snoc)
import Control.Monad ((>=>))
import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Reader (ask, asks, local)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Writer (Writer, listen, runWriter, tell)
import Control.Selective ((<*?))
import Data.Functor (($>))
import Data.Functor.Alt ((<!>))
import Data.Functor.Apply ((<.>))
import Data.Functor.Bind ((>>-))
import Data.Functor.Contravariant (contramap)
import Data.Functor.Identity (Identity (..))
import Data.Functor.Plus (zero)
import Gens (genFnInt, genInt, genIntList, genPath, pathKey)
import Hedgehog
import Hedgehog.Function (Fn, apply, fn)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Laws (Laws, lensLaws, prismLaws)
import System.FilePather
import Witherable (mapMaybe)

-- | The result of running a 'Tracked' value.
type Result a = Either Cycle (Outputs, a)

-- | Run a 'Tracked' value.
at :: Tracked f a -> Trail -> FilePath -> f (Result a)
at =
  view trackedFunction

-- | Make a 'Tracked' value from its function.
mk :: (Trail -> FilePath -> f (Result a)) -> Tracked f a
mk =
  view (from trackedFunction)

-- | An 'Int' that is determined by a trail and a file path.
key :: Trail -> FilePath -> Int
key t p =
  pathKey (p <> show t)

genName :: Gen String
genName =
  Gen.element ["prepare", "pdf page 1", "libreoffice pdf", "image png", "book"]

genStep :: Gen Step
genStep =
  Step <$> genName <*> genPath

genTrail :: Gen Trail
genTrail =
  Trail <$> Gen.list (Range.linear 0 3) genStep

genCycle :: Gen Cycle
genCycle =
  Gen.choice
    [ ReproducesInput <$> genPath <*> genStep <*> genTrail
    , RepeatsStep <$> genStep <*> genTrail
    ]

genOutputs :: Gen Outputs
genOutputs =
  Gen.list (Range.linear 0 2) ((,) <$> genPath <*> genStep)

genResult :: Gen a -> Gen (Result a)
genResult genA =
  Gen.frequency [(1, Left <$> genCycle), (4, fmap Right ((,) <$> genOutputs <*> genA))]

-- | A function to make a 'Tracked' value in @[]@.
genTrackedList :: Gen (Fn Int [Result Int])
genTrackedList =
  fn (Gen.list (Range.linear 0 2) (genResult genInt))

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

genTrackedMaybe :: Gen (Fn Int (Maybe (Result Int)))
genTrackedMaybe =
  fn (Gen.maybe (genResult genInt))

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

toTracked :: Fn Int (f (Result a)) -> Tracked f a
toTracked f =
  mk (\t p -> apply f (key t p))

toTrackedFn :: Fn Int [Result (Fn Int Int)] -> Tracked [] (Int -> Int)
toTrackedFn f =
  mk (\t p -> fmap (fmap (fmap apply)) (apply f (key t p)))

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

kleisli :: Fn (Int, Int) [Result Int] -> Int -> Tracked [] Int
kleisli g a =
  mk (\t p -> apply g (a, key t p))

-- | A 'Tracked' value that is stopped by a cycle.
stopped :: (Applicative f) => Cycle -> Tracked f a
stopped c =
  mk (\_ _ -> pure (Left c))

-- | A step that records that it ran.
ran :: FilePather (Writer [String]) ()
ran =
  FilePather (\_ -> tell ["ran"])

trackedTests :: Laws
trackedTests =
  [ ("Functor identity", prop_functorIdentity)
  , ("Functor composition", prop_functorComposition)
  , ("Applicative identity", prop_applicativeIdentity)
  , ("Applicative composition", prop_applicativeComposition)
  , ("Applicative homomorphism", prop_applicativeHomomorphism)
  , ("Applicative interchange", prop_applicativeInterchange)
  , ("Apply agrees with Applicative", prop_applyAgrees)
  , ("Monad left identity", prop_monadLeftIdentity)
  , ("Monad right identity", prop_monadRightIdentity)
  , ("Monad associativity", prop_monadAssociativity)
  , ("Bind agrees with Monad", prop_bindAgrees)
  , ("Alternative left identity", prop_alternativeLeftIdentity)
  , ("Alternative right identity", prop_alternativeRightIdentity)
  , ("Alternative associativity", prop_alternativeAssociativity)
  , ("Alt and Plus agree with Alternative", prop_altAgrees)
  , ("Semigroup associativity", prop_semigroupAssociativity)
  , ("Monoid identity", prop_monoidIdentity)
  , ("Filterable identity", prop_filterableIdentity)
  , ("Filterable composition", prop_filterableComposition)
  , ("Filterable keeps a cycle", prop_filterableCycle)
  , ("Selective identity", prop_selectiveIdentity)
  , ("MonadReader ask", prop_ask)
  , ("MonadReader local", prop_local)
  , ("MonadTrans lift . pure", prop_liftPure)
  , ("MonadTrans lift bind", prop_liftBind)
  , ("MonadError catchError . throwError", prop_catchThrow)
  , ("MonadError does not catch a cycle", prop_catchCycle)
  , ("MonadWriter listen . tell", prop_listenTell)
  , ("Contravariant identity", prop_contravariantIdentity)
  , ("<|> propagates a cycle", prop_altCycle)
  , ("<> propagates a cycle, and stops", prop_semigroupCycle)
  , ("step records its outputs", prop_stepOutputs)
  , ("step stops a repeated step before running", prop_stepRepeats)
  , ("step stops a reproduced input before running", prop_stepReproduces)
  , ("stepWith Repeatable allows a repeated step", prop_stepRepeatable)
  , ("step' stops after running", prop_step'Stops)
  , ("whenPath const False", prop_whenPathFalse)
  , ("whenTrail const True", prop_whenTrailTrue)
  , ("onPath", prop_onPath)
  , ("askTrail", prop_askTrail)
  , ("untracked", prop_untracked)
  , ("hoistTracked id", prop_hoistIdentity)
  ]
    <> lensLaws "stepName" stepName genStep genName
    <> lensLaws "stepInput" stepInput genStep genPath
    <> lensLaws "cycleStep" cycleStep genCycle genStep
    <> lensLaws "cycleTrail" cycleTrail genCycle genTrail
    <> prismLaws "_ReproducesInput" _ReproducesInput genCycle ((,,) <$> genPath <*> genStep <*> genTrail)
    <> prismLaws "_RepeatsStep" _RepeatsStep genCycle ((,) <$> genStep <*> genTrail)
    <> prismLaws "_Once" _Once (Gen.element [Once, Repeatable]) (pure ())
    <> prismLaws "_Repeatable" _Repeatable (Gen.element [Once, Repeatable]) (pure ())
    <> prismLaws "Trail _Cons" _Cons genTrail ((,) <$> genStep <*> genTrail)
    <> prismLaws "Trail _Snoc" _Snoc genTrail ((,) <$> genTrail <*> genStep)

prop_functorIdentity :: Property
prop_functorIdentity =
  property $
    do
      x <- forAll genTrackedList
      t <- forAll genTrail
      p <- forAll genPath
      at (fmap id (toTracked x)) t p === at (toTracked x) t p

prop_functorComposition :: Property
prop_functorComposition =
  property $
    do
      x <- forAll genTrackedList
      f <- forAll genFnInt
      g <- forAll genFnInt
      t <- forAll genTrail
      p <- forAll genPath
      at (fmap (apply f . apply g) (toTracked x)) t p === at (fmap (apply f) (fmap (apply g) (toTracked x))) t p

prop_applicativeIdentity :: Property
prop_applicativeIdentity =
  property $
    do
      x <- forAll genTrackedList
      t <- forAll genTrail
      p <- forAll genPath
      at (pure id <*> toTracked x) t p === at (toTracked x) t p

prop_applicativeComposition :: Property
prop_applicativeComposition =
  property $
    do
      u <- forAll genTrackedListFn
      v <- forAll genTrackedListFn
      w <- forAll genTrackedList
      t <- forAll genTrail
      p <- forAll genPath
      let (u', v', w') = (toTrackedFn u, toTrackedFn v, toTracked w)
      at (pure (.) <*> u' <*> v' <*> w') t p === at (u' <*> (v' <*> w')) t p

prop_applicativeHomomorphism :: Property
prop_applicativeHomomorphism =
  property $
    do
      f <- forAll genFnInt
      x <- forAll genInt
      t <- forAll genTrail
      p <- forAll genPath
      at (pure (apply f) <*> pure x :: Tracked [] Int) t p === at (pure (apply f x)) t p

prop_applicativeInterchange :: Property
prop_applicativeInterchange =
  property $
    do
      u <- forAll genTrackedListFn
      y <- forAll genInt
      t <- forAll genTrail
      p <- forAll genPath
      at (toTrackedFn u <*> pure y) t p === at (pure ($ y) <*> toTrackedFn u) t p

prop_applyAgrees :: Property
prop_applyAgrees =
  property $
    do
      u <- forAll genTrackedListFn
      w <- forAll genTrackedList
      t <- forAll genTrail
      p <- forAll genPath
      at (toTrackedFn u <.> toTracked w) t p === at (toTrackedFn u <*> toTracked w) t p

prop_monadLeftIdentity :: Property
prop_monadLeftIdentity =
  property $
    do
      a <- forAll genInt
      k <- forAll genKleisli
      t <- forAll genTrail
      p <- forAll genPath
      at (pure a >>= kleisli k) t p === at (kleisli k a) t p

prop_monadRightIdentity :: Property
prop_monadRightIdentity =
  property $
    do
      m <- forAll genTrackedList
      t <- forAll genTrail
      p <- forAll genPath
      at (toTracked m >>= pure) t p === at (toTracked m) t p

prop_monadAssociativity :: Property
prop_monadAssociativity =
  property $
    do
      m <- forAll genTrackedList
      k <- forAll genKleisli
      h <- forAll genKleisli
      t <- forAll genTrail
      p <- forAll genPath
      at ((toTracked m >>= kleisli k) >>= kleisli h) t p === at (toTracked m >>= (kleisli k >=> kleisli h)) t p

prop_bindAgrees :: Property
prop_bindAgrees =
  property $
    do
      m <- forAll genTrackedList
      k <- forAll genKleisli
      t <- forAll genTrail
      p <- forAll genPath
      at (toTracked m >>- kleisli k) t p === at (toTracked m >>= kleisli k) t p

prop_alternativeLeftIdentity :: Property
prop_alternativeLeftIdentity =
  property $
    do
      x <- forAll genTrackedList
      t <- forAll genTrail
      p <- forAll genPath
      at (empty <|> toTracked x) t p === at (toTracked x) t p

prop_alternativeRightIdentity :: Property
prop_alternativeRightIdentity =
  property $
    do
      x <- forAll genTrackedList
      t <- forAll genTrail
      p <- forAll genPath
      at (toTracked x <|> empty) t p === at (toTracked x) t p

prop_alternativeAssociativity :: Property
prop_alternativeAssociativity =
  property $
    do
      x <- forAll genTrackedMaybe
      y <- forAll genTrackedMaybe
      z <- forAll genTrackedMaybe
      t <- forAll genTrail
      p <- forAll genPath
      let (x', y', z') = (toTracked x, toTracked y, toTracked z)
      at ((x' <|> y') <|> z') t p === at (x' <|> (y' <|> z')) t p

prop_altAgrees :: Property
prop_altAgrees =
  property $
    do
      x <- forAll genTrackedList
      y <- forAll genTrackedList
      t <- forAll genTrail
      p <- forAll genPath
      at (toTracked x <!> toTracked y) t p === at (toTracked x <|> toTracked y) t p
      at (zero :: Tracked [] Int) t p === at empty t p

prop_semigroupAssociativity :: Property
prop_semigroupAssociativity =
  property $
    do
      x <- forAll genTrackedMonoid
      y <- forAll genTrackedMonoid
      z <- forAll genTrackedMonoid
      t <- forAll genTrail
      p <- forAll genPath
      let (x', y', z') = (toTracked x, toTracked y, toTracked z)
      at ((x' <> y') <> z') t p === at (x' <> (y' <> z')) t p

prop_monoidIdentity :: Property
prop_monoidIdentity =
  property $
    do
      x <- forAll genTrackedMonoid
      t <- forAll genTrail
      p <- forAll genPath
      at (mempty <> toTracked x) t p === at (toTracked x) t p
      at (toTracked x <> mempty) t p === at (toTracked x) t p

prop_filterableIdentity :: Property
prop_filterableIdentity =
  property $
    do
      x <- forAll genTrackedList
      t <- forAll genTrail
      p <- forAll genPath
      at (mapMaybe Just (toTracked x)) t p === at (toTracked x) t p

prop_filterableComposition :: Property
prop_filterableComposition =
  property $
    do
      x <- forAll genTrackedList
      f <- forAll (fn (Gen.maybe genInt) :: Gen (Fn Int (Maybe Int)))
      g <- forAll (fn (Gen.maybe genInt) :: Gen (Fn Int (Maybe Int)))
      t <- forAll genTrail
      p <- forAll genPath
      at (mapMaybe (apply f) (mapMaybe (apply g) (toTracked x))) t p === at (mapMaybe (apply g >=> apply f) (toTracked x)) t p

prop_filterableCycle :: Property
prop_filterableCycle =
  property $
    do
      c <- forAll genCycle
      t <- forAll genTrail
      p <- forAll genPath
      at (mapMaybe (const Nothing :: Int -> Maybe Int) (stopped c)) t p === [Left c]

prop_selectiveIdentity :: Property
prop_selectiveIdentity =
  property $
    do
      x <- forAll (fn (Gen.list (Range.linear 0 2) (genResult (Gen.either genInt genInt))) :: Gen (Fn Int [Result (Either Int Int)]))
      t <- forAll genTrail
      p <- forAll genPath
      at (toTracked x <*? pure id) t p === at (either id id <$> toTracked x) t p

prop_ask :: Property
prop_ask =
  property $
    do
      t <- forAll genTrail
      p <- forAll genPath
      at (ask :: Tracked Identity FilePath) t p === Identity (Right ([], p))

prop_local :: Property
prop_local =
  property $
    do
      f <- forAll (fn genPath :: Gen (Fn Int String))
      t <- forAll genTrail
      p <- forAll genPath
      let g = apply f . pathKey
      at (local g ask :: Tracked Identity FilePath) t p === at (asks g) t p

prop_liftPure :: Property
prop_liftPure =
  property $
    do
      a <- forAll genInt
      t <- forAll genTrail
      p <- forAll genPath
      at (lift (pure a) :: Tracked [] Int) t p === at (pure a) t p

prop_liftBind :: Property
prop_liftBind =
  property $
    do
      m <- forAll genIntList
      f <- forAll (fn genIntList :: Gen (Fn Int [Int]))
      t <- forAll genTrail
      p <- forAll genPath
      at (lift (m >>= apply f)) t p === at (lift m >>= (lift . apply f)) t p

prop_catchThrow :: Property
prop_catchThrow =
  property $
    do
      e <- forAll genInt
      h <- forAll (fn (genResult genInt) :: Gen (Fn Int (Result Int)))
      t <- forAll genTrail
      p <- forAll genPath
      let handler x = mk (\_ _ -> Right (apply h x)) :: Tracked (Either Int) Int
      at (catchError (throwError e) handler) t p === at (handler e) t p

prop_catchCycle :: Property
prop_catchCycle =
  property $
    do
      c <- forAll genCycle
      t <- forAll genTrail
      p <- forAll genPath
      at (catchError (stopped c) (const (pure 1)) :: Tracked (Either Int) Int) t p === Right (Left c)

prop_listenTell :: Property
prop_listenTell =
  property $
    do
      w <- forAll genIntList
      t <- forAll genTrail
      p <- forAll genPath
      runWriter (at (listen (tell w) :: Tracked (Writer [Int]) ((), [Int])) t p) === runWriter (at (tell w $> ((), w)) t p)

prop_contravariantIdentity :: Property
prop_contravariantIdentity =
  property $
    do
      h <- forAll (fn genIntList :: Gen (Fn Int [Int]))
      t <- forAll genTrail
      p <- forAll genPath
      let x = mk (\t' p' -> Const (apply h (key t' p'))) :: Tracked (Const [Int]) Int
      getConst (at (contramap id x) t p) === getConst (at x t p)

prop_altCycle :: Property
prop_altCycle =
  property $
    do
      c <- forAll genCycle
      y <- forAll genTrackedMaybe
      t <- forAll genTrail
      p <- forAll genPath
      at (stopped c <|> toTracked y) t p === Just (Left c)

prop_semigroupCycle :: Property
prop_semigroupCycle =
  property $
    do
      c <- forAll genCycle
      t <- forAll genTrail
      p <- forAll genPath
      let x = lift (tell ["x"]) *> stopped c :: Tracked (Writer [String]) ()
          y = lift (tell ["y"])
      runWriter (at (x <> y) t p) === (Left c, ["x"])

prop_stepOutputs :: Property
prop_stepOutputs =
  property $
    do
      p <- forAll genPath
      runWriter (at (step "copy" (\q -> [q <> ".bak"]) ran) (Trail []) p) === (Right ([(p <> ".bak", Step "copy" p)], ()), ["ran"])

prop_stepRepeats :: Property
prop_stepRepeats =
  property $
    do
      t <- forAll genTrail
      q <- forAll genPath
      p <- forAll genPath
      let t' = Trail [Step "copy" q] <> t
      runWriter (at (step "copy" (\r -> [r <> ".bak"]) ran) t' p) === (Left (RepeatsStep (Step "copy" p) t'), [])

prop_stepReproduces :: Property
prop_stepReproduces =
  property $
    do
      q <- forAll genPath
      p <- forAll genPath
      let t = Trail [Step "prepare" q]
      runWriter (at (step "unprepare" (const [q]) ran) t p) === (Left (ReproducesInput q (Step "unprepare" p) t), [])

prop_stepRepeatable :: Property
prop_stepRepeatable =
  property $
    do
      q <- forAll genPath
      p <- forAll genPath
      let t = Trail [Step "copy" q]
      fmap fst (fst (runWriter (at (stepWith Repeatable "copy" (\r -> [r <> ".bak"]) ran) t p))) === Right [(p <> ".bak", Step "copy" p)]

prop_step'Stops :: Property
prop_step'Stops =
  property $
    do
      q <- forAll genPath
      p <- forAll genPath
      let t = Trail [Step "prepare" q]
      runWriter (at (step' "unprepare" (([q], ()) <$ ran)) t p) === (Left (ReproducesInput q (Step "unprepare" p) t), ["ran"])

prop_whenPathFalse :: Property
prop_whenPathFalse =
  property $
    do
      x <- forAll genTrackedMonoid
      t <- forAll genTrail
      p <- forAll genPath
      at (whenPath (const False) (toTracked x)) t p === [Right ([], [])]

prop_whenTrailTrue :: Property
prop_whenTrailTrue =
  property $
    do
      x <- forAll genTrackedMonoid
      t <- forAll genTrail
      p <- forAll genPath
      at (whenTrail (const True) (toTracked x)) t p === at (toTracked x) t p

prop_onPath :: Property
prop_onPath =
  property $
    do
      x <- forAll genTrackedList
      t <- forAll genTrail
      p <- forAll genPath
      q <- forAll genPath
      at (onPath q (toTracked x)) t p === at (toTracked x) t q

prop_askTrail :: Property
prop_askTrail =
  property $
    do
      t <- forAll genTrail
      p <- forAll genPath
      at (askTrail :: Tracked Identity Trail) t p === Identity (Right ([], t))

prop_untracked :: Property
prop_untracked =
  property $
    do
      t <- forAll genTrail
      p <- forAll genPath
      at (untracked (asks length) :: Tracked Identity Int) t p === Identity (Right ([], length p))

prop_hoistIdentity :: Property
prop_hoistIdentity =
  property $
    do
      x <- forAll genTrackedList
      t <- forAll genTrail
      p <- forAll genPath
      at (hoistTracked id (toTracked x)) t p === at (toTracked x) t p