skeletest-0.3.0: src/Skeletest/Internal/Predicate.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeData #-}
{-# LANGUAGE TypeFamilies #-}
module Skeletest.Internal.Predicate (
Predicate,
PredicateResult (..),
runPredicate,
renderPredicate,
-- * General
anything,
-- * Ord
eq,
gt,
gte,
lt,
lte,
-- * Data types
just,
nothing,
left,
right,
list,
IsPredTuple (..),
tup,
con,
conMatches,
-- * Numeric
approx,
tol,
Tolerance (..),
-- * Combinators
(<<<),
(>>>),
not,
(&&),
(||),
and,
or,
-- * Containers
any,
all,
elem,
-- * Subsequences
HasSubsequences (..),
hasPrefix,
hasInfix,
hasSuffix,
-- * IO
returns,
throws,
-- * Functions
Fun (..),
IsoChecker (..),
(===),
isoWith,
-- * Snapshot testing
matchesSnapshot,
) where
import Control.Monad.IO.Class (MonadIO)
import Data.Foldable (toList)
import Data.Foldable1 qualified as Foldable1
import Data.Functor.Const (Const (..))
import Data.Functor.Identity (Identity (..))
import Data.Kind (Type)
import Data.List qualified as List
import Data.List.NonEmpty qualified as NonEmpty
import Data.Maybe (isJust, isNothing, listToMaybe)
import Data.Proxy (Proxy (..))
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Typeable (Typeable)
import Debug.RecoverRTTI (anythingToString)
import GHC.Generics ((:*:) (..))
import GHC.Stack qualified as GHC
import Skeletest.Internal.CLI (getFlag)
import Skeletest.Internal.Error (invariantViolation)
import Skeletest.Internal.Snapshot (
SnapshotContext (..),
SnapshotResult (..),
SnapshotUpdateFlag (..),
checkSnapshot,
getAndIncSnapshotIndex,
getSnapshotRenderers,
updateSnapshot,
)
import Skeletest.Internal.TestInfo (getTestInfo)
import Skeletest.Internal.Utils.Diff (showLineDiff)
import Skeletest.Internal.Utils.HList (HList (..))
import Skeletest.Internal.Utils.HList qualified as HList
import Skeletest.Prop.Gen (Gen)
import Skeletest.Prop.Internal (PropertyM, forAll)
import UnliftIO (MonadUnliftIO)
import UnliftIO.Exception (Exception, displayException, try)
import Prelude hiding (abs, all, and, any, elem, not, or, (&&), (||))
import Prelude qualified
data Predicate m a = Predicate
{ predicateFunc :: a -> m PredicateFuncResult
, predicateDisp :: Text
-- ^ The rendered representation of the predicate
, predicateDispNeg :: Text
-- ^ The rendered representation of the negation of the predicate
}
data PredicateResult
= PredicateSuccess
| PredicateFail Text
runPredicate :: (Monad m) => Predicate m a -> a -> m PredicateResult
runPredicate Predicate{..} val = do
PredicateFuncResult{..} <- predicateFunc val
pure $
if predicateSuccess
then PredicateSuccess
else
let failCtx =
FailCtx
{ failCtxExpected = predicateDisp
, failCtxActual = render val
}
in PredicateFail . withFailCtx failCtx predicateShowFailCtx $ predicateExplain
renderPredicate :: Predicate m a -> Text
renderPredicate = predicateDisp
data PredicateFuncResult = PredicateFuncResult
{ predicateSuccess :: Bool
, predicateExplain :: Text
-- ^ The explanation of the result.
--
-- If predicateSuccess is true, this is the message to show if the
-- success is unexpected. If predicatesSuccess is false, this is
-- the message to show on the failure.
, predicateShowFailCtx :: ShowFailCtx
-- ^ See 'ShowFailCtx'.
}
-- | Should a predicate show the context of the failure?
--
-- When failing `P.left (P.eq 1)`, the failure should show just the specific
-- thing that failed, e.g. `1 ≠ 2`, but we should show the general context
-- as well, e.g. `Expected: Left (= 1), Got: Left 2`. Primitive predicates
-- should generally start as NoFailCtx, then higher-order predicates should
-- upgrade it to ShowFailCtx. Predicates that explicitly want to hide the
-- context should set HideFailCtx.
data ShowFailCtx
= NoFailCtx
| ShowFailCtx
| HideFailCtx
deriving (Eq, Ord)
shouldShowFailCtx :: ShowFailCtx -> Bool
shouldShowFailCtx = \case
NoFailCtx -> False
ShowFailCtx -> True
HideFailCtx -> False
data FailCtx = FailCtx
{ failCtxExpected :: Text
, failCtxActual :: Text
}
renderFailCtx :: FailCtx -> Text
renderFailCtx FailCtx{..} =
Text.intercalate "\n" $
[ "Expected:"
, indent failCtxExpected
, ""
, "Got:"
, indent failCtxActual
]
withFailCtx :: FailCtx -> ShowFailCtx -> Text -> Text
withFailCtx failCtx ctx s =
if shouldShowFailCtx ctx
then Text.intercalate "\n" [s, "", renderFailCtx failCtx]
else s
noCtx :: ShowFailCtx
noCtx = NoFailCtx
showMergedCtxs :: [PredicateFuncResult] -> ShowFailCtx
showMergedCtxs = max ShowFailCtx . maybe NoFailCtx Foldable1.maximum . NonEmpty.nonEmpty . map predicateShowFailCtx
showCtx :: PredicateFuncResult -> PredicateFuncResult
showCtx result = result{predicateShowFailCtx = max ShowFailCtx $ predicateShowFailCtx result}
{----- General -----}
-- | A predicate that matches any value
anything :: forall a m. (Monad m) => Predicate m a
anything =
Predicate
{ predicateFunc = \_ ->
pure
PredicateFuncResult
{ predicateSuccess = True
, predicateExplain = "anything"
, predicateShowFailCtx = noCtx
}
, predicateDisp = "anything"
, predicateDispNeg = "not anything"
}
{----- Ord -----}
-- | A predicate checking if the input is equal to the given value
--
-- >>> 1 `shouldSatisfy` P.eq 1
eq :: (Eq a, Monad m) => a -> Predicate m a
eq = mkPredicateOp "=" "≠" $ \actual expected -> actual == expected
-- | A predicate checking if the input is greater than the given value
--
-- >>> 1 `shouldSatisfy` P.gt 0
gt :: (Ord a, Monad m) => a -> Predicate m a
gt = mkPredicateOp ">" "≯" $ \actual expected -> actual > expected
-- | A predicate checking if the input is greater than or equal to the given value
--
-- >>> 1 `shouldSatisfy` P.gte 0
gte :: (Ord a, Monad m) => a -> Predicate m a
gte = mkPredicateOp "≥" "≱" $ \actual expected -> actual > expected Prelude.|| actual == expected
-- | A predicate checking if the input is less than the given value
--
-- >>> 1 `shouldSatisfy` P.lt 10
lt :: (Ord a, Monad m) => a -> Predicate m a
lt = mkPredicateOp "<" "≮" $ \actual expected -> actual < expected
-- | A predicate checking if the input is less than or equal to the given value
--
-- >>> 1 `shouldSatisfy` P.lte 10
lte :: (Ord a, Monad m) => a -> Predicate m a
lte = mkPredicateOp "≤" "≰" $ \actual expected -> actual < expected Prelude.|| actual == expected
{----- Data types -----}
-- | A predicate checking if the input is Just, wrapping a value matching the given predicate.
--
-- >>> Just 1 `shouldSatisfy` P.just (P.gt 0)
just :: (Monad m) => Predicate m a -> Predicate m (Maybe a)
just p = conMatches "Just" fieldNames toFields preds
where
fieldNames = Nothing
toFields = \case
Just x -> Just . HCons (pure x) $ HNil
_ -> Nothing
preds = HCons p HNil
-- | A predicate checking if the input is Nothing
--
-- >>> Nothing `shouldSatisfy` P.nothing
nothing :: (Monad m) => Predicate m (Maybe a)
nothing = conMatches "Nothing" fieldNames toFields preds
where
fieldNames = Nothing
toFields = \case
Nothing -> Just HNil
_ -> Nothing
preds = HNil
-- | A predicate checking if the input is Left, wrapping a value matching the given predicate.
--
-- >>> Left 1 `shouldSatisfy` P.left (P.gt 0)
left :: (Monad m) => Predicate m a -> Predicate m (Either a b)
left p = conMatches "Left" fieldNames toFields preds
where
fieldNames = Nothing
toFields = \case
Left x -> Just . HCons (pure x) $ HNil
_ -> Nothing
preds = HCons p HNil
-- | A predicate checking if the input is Right, wrapping a value matching the given predicate.
--
-- >>> Right 1 `shouldSatisfy` P.right (P.gt 0)
right :: (Monad m) => Predicate m b -> Predicate m (Either a b)
right p = conMatches "Right" fieldNames toFields preds
where
fieldNames = Nothing
toFields = \case
Right x -> Just . HCons (pure x) $ HNil
_ -> Nothing
preds = HCons p HNil
-- | A predicate checking if the input is a list matching exactly the given predicates.
--
-- >>> [1, 2, 3] `shouldSatisfy` P.list [P.eq 1, P.eq 2, P.eq 3]
-- >>> [1, 2, 3] `shouldNotSatisfy` P.list [P.eq 1, P.eq 2]
-- >>> [1, 2, 3] `shouldNotSatisfy` P.list [P.eq 1, P.eq 2, P.eq 3, P.eq 4]
--
-- @since 0.2.1
list :: (Monad m) => [Predicate m a] -> Predicate m [a]
list predList =
Predicate
{ predicateFunc = \actual ->
if length actual == length predList
then verifyAll listify <$> sequence (zipWith predicateFunc predList actual)
else
pure
PredicateFuncResult
{ predicateSuccess = False
, predicateExplain = "Got different number of elements"
, predicateShowFailCtx = ShowFailCtx
}
, predicateDisp = disp
, predicateDispNeg = dispNeg
}
where
listify vals = "[" <> Text.intercalate ", " vals <> "]"
disp = listify $ map predicateDisp predList
dispNeg = "not " <> disp
class IsTuple a where
type TupleArgs a :: [Type]
toHList :: a -> HList Identity (TupleArgs a)
instance IsTuple (a, b) where
type TupleArgs (a, b) = '[a, b]
toHList (a, b) = HCons (pure a) . HCons (pure b) $ HNil
instance IsTuple (a, b, c) where
type TupleArgs (a, b, c) = '[a, b, c]
toHList (a, b, c) = HCons (pure a) . HCons (pure b) . HCons (pure c) $ HNil
instance IsTuple (a, b, c, d) where
type TupleArgs (a, b, c, d) = '[a, b, c, d]
toHList (a, b, c, d) = HCons (pure a) . HCons (pure b) . HCons (pure c) . HCons (pure d) $ HNil
instance IsTuple (a, b, c, d, e) where
type TupleArgs (a, b, c, d, e) = '[a, b, c, d, e]
toHList (a, b, c, d, e) = HCons (pure a) . HCons (pure b) . HCons (pure c) . HCons (pure d) . HCons (pure e) $ HNil
instance IsTuple (a, b, c, d, e, f) where
type TupleArgs (a, b, c, d, e, f) = '[a, b, c, d, e, f]
toHList (a, b, c, d, e, f) = HCons (pure a) . HCons (pure b) . HCons (pure c) . HCons (pure d) . HCons (pure e) . HCons (pure f) $ HNil
class (IsTuple a) => IsPredTuple m a where
type ToPredTuple m a
toHListPred :: proxy a -> ToPredTuple m a -> HList (Predicate m) (TupleArgs a)
instance IsPredTuple m (a, b) where
type ToPredTuple m (a, b) = (Predicate m a, Predicate m b)
toHListPred _ (a, b) = HCons a . HCons b $ HNil
instance IsPredTuple m (a, b, c) where
type ToPredTuple m (a, b, c) = (Predicate m a, Predicate m b, Predicate m c)
toHListPred _ (a, b, c) = HCons a . HCons b . HCons c $ HNil
instance IsPredTuple m (a, b, c, d) where
type ToPredTuple m (a, b, c, d) = (Predicate m a, Predicate m b, Predicate m c, Predicate m d)
toHListPred _ (a, b, c, d) = HCons a . HCons b . HCons c . HCons d $ HNil
instance IsPredTuple m (a, b, c, d, e) where
type ToPredTuple m (a, b, c, d, e) = (Predicate m a, Predicate m b, Predicate m c, Predicate m d, Predicate m e)
toHListPred _ (a, b, c, d, e) = HCons a . HCons b . HCons c . HCons d . HCons e $ HNil
instance IsPredTuple m (a, b, c, d, e, f) where
type ToPredTuple m (a, b, c, d, e, f) = (Predicate m a, Predicate m b, Predicate m c, Predicate m d, Predicate m e, Predicate m f)
toHListPred _ (a, b, c, d, e, f) = HCons a . HCons b . HCons c . HCons d . HCons e . HCons f $ HNil
-- | A predicate checking if the input matches a tuple matching the given predicates.
-- Works for tuples up to 6 elements.
--
-- >>> (1, 10, "hello world") `shouldSatisfy` P.tup (P.eq 1, P.gt 2, P.hasPrefix "hello ")
tup :: forall a m. (IsPredTuple m a, Monad m) => ToPredTuple m a -> Predicate m a
tup predTup =
Predicate
{ predicateFunc = \actual ->
verifyAll tupify <$> runPredicates preds (toHList actual)
, predicateDisp = disp
, predicateDispNeg = dispNeg
}
where
preds = toHListPred (Proxy @a) predTup
tupify vals = "(" <> Text.intercalate ", " vals <> ")"
disp = tupify $ HList.toListWith predicateDisp preds
dispNeg = "not " <> disp
-- | A predicate checking if the input matches the given constructor.
--
-- It takes one argument, which is the constructor, except with all fields
-- taking a Predicate instead of the normal value. Skeletest will rewrite
-- the expression so it typechecks correctly.
--
-- >>> User "user1" "user1@example.com" `shouldSatisfy` P.con User{name = P.eq "user1", email = P.contains "@"}
--
-- Record fields that are omitted are not checked at all; i.e.
-- @P.con Foo{}@ and @P.con Foo{a = P.anything}@ are equivalent.
--
-- Positional arguments work also, as well as dollar signs.
--
-- >>> let email = P.con $ Email P.anything (P.eq "example.com")
-- >>> user `shouldSatisfy` P.con User{email = email}
con :: a -> Predicate m a
con =
-- A placeholder that will be replaced with conMatches in the plugin.
invariantViolation "P.con was not replaced"
-- | A predicate for checking that a value matches the given constructor.
-- Assumes that the arguments correctly match the constructor being tested,
-- so it should not be written directly, only generated from `con`.
conMatches ::
(Monad m) =>
String ->
Maybe (HList (Const String) fields) ->
(a -> Maybe (HList Identity fields)) ->
HList (Predicate m) fields ->
Predicate m a
conMatches conNameS mFieldNames deconstruct preds =
Predicate
{ predicateFunc = \actual ->
case deconstruct actual of
Just fields -> verifyAll consify <$> runPredicates preds fields
Nothing ->
pure
PredicateFuncResult
{ predicateSuccess = False
, predicateExplain = render actual <> " " <> dispNeg
, predicateShowFailCtx = noCtx
}
, predicateDisp = disp
, predicateDispNeg = dispNeg
}
where
conName = Text.pack conNameS
disp = "matches " <> predsDisp
dispNeg = "does not match " <> predsDisp
predsDisp = consify $ HList.toListWith predicateDisp preds
-- consify ["= 1", "anything"] => User{id = (= 1), name = anything}
-- consify ["= 1", "anything"] => Foo (= 1) anything
consify vals =
case HList.uncheck <$> mFieldNames of
Nothing -> Text.unwords $ conName : map parens vals
Just fieldNames ->
let fields = zipWith (\field v -> Text.pack field <> " = " <> parens v) fieldNames vals
in conName <> "{" <> Text.intercalate ", " fields <> "}"
{----- Numeric -----}
-- | A predicate checking if the input is equal to the given value within some tolerance.
--
-- Useful for checking equality with floats, which might not be exactly equal.
-- For more information, see: https://jvns.ca/blog/2023/01/13/examples-of-floating-point-problems/.
--
-- >>> (0.1 + 0.2) `shouldSatisfy` P.approx P.tol 0.3
-- >>> (0.1 + 0.2) `shouldSatisfy` P.approx P.tol{P.rel = Just 1e-6} 0.3
-- >>> (0.1 + 0.2) `shouldSatisfy` P.approx P.tol{P.abs = 1e-12} 0.3
-- >>> (0.1 + 0.2) `shouldSatisfy` P.approx P.tol{P.rel = Just 1e-6, P.abs = 1e-12} 0.3
-- >>> (0.1 + 0.2) `shouldSatisfy` P.approx P.tol{P.rel = Nothing} 0.3
-- >>> (0.1 + 0.2) `shouldSatisfy` P.approx P.tol{P.rel = Nothing, P.abs = 1e-12} 0.3
approx :: (Fractional a, Ord a, Monad m) => Tolerance -> a -> Predicate m a
approx Tolerance{..} =
mkPredicateOp "≈" "≉" $ \actual expected ->
Prelude.abs (actual - expected) <= getTolerance expected
where
mRelTol = fromTol <$> rel
absTol = fromTol abs
getTolerance expected =
case mRelTol of
Just relTol -> max (relTol * Prelude.abs expected) absTol
Nothing -> absTol
fromTol x
| x < 0 = error $ "tolerance can't be negative: " <> show x
| otherwise = fromRational x
-- | The tolerance to use in 'approx'.
--
-- An input satisfies a tolerance if it's within the relative tolerance
-- (rel * input) or the absolute tolerance of the reference value.
data Tolerance = Tolerance
{ rel :: Maybe Rational
-- ^ If provided, the relative tolerance. Defaults to 1e-6.
, abs :: Rational
-- ^ The absolute tolerance. Defaults to 1e-12.
}
-- | The default tolerance for 'approx'.
tol :: Tolerance
tol = Tolerance{rel = Just 1e-6, abs = 1e-12}
{----- Combinators -----}
infixr 1 <<<, >>>
-- | A predicate checking if the input matches the given predicate, after applying the given function.
--
-- >>> "hello" `shouldSatisfy` (P.eq 5 P.<<< length)
(<<<) :: (Monad m) => Predicate m a -> (b -> a) -> Predicate m b
Predicate{..} <<< f =
Predicate
{ predicateFunc = fmap showCtx . predicateFunc . f
, predicateDisp
, predicateDispNeg
}
-- | Same as '<<<', except with the arguments flipped.
--
-- >>> "hello" `shouldSatisfy` (length P.>>> P.eq 5)
(>>>) :: (Monad m) => (b -> a) -> Predicate m a -> Predicate m b
(>>>) = flip (<<<)
-- | A predicate checking if the input does not match the given predicate
--
-- >>> Just 2 `shouldSatisfy` P.just (P.not (P.eq 1))
not :: (Monad m) => Predicate m a -> Predicate m a
not Predicate{..} =
Predicate
{ predicateFunc = \actual -> do
result <- showCtx <$> predicateFunc actual
pure result{predicateSuccess = Prelude.not $ predicateSuccess result}
, predicateDisp = predicateDispNeg
, predicateDispNeg = predicateDisp
}
-- | A predicate checking if the input matches both of the given predicates
--
-- >>> 1 `shouldSatisfy` P.gt 0 P.&& P.lt 2
(&&) :: (Monad m) => Predicate m a -> Predicate m a -> Predicate m a
p1 && p2 = and [p1, p2]
-- | A predicate checking if the input matches one of the given predicates
--
-- >>> 1 `shouldSatisfy` P.lt 5 P.|| P.gt 10
(||) :: (Monad m) => Predicate m a -> Predicate m a -> Predicate m a
p1 || p2 = or [p1, p2]
-- | A predicate checking if the input matches all of the given predicates
--
-- >>> 1 `shouldSatisfy` P.and [P.gt 0, P.lt 2]
and :: (Monad m) => [Predicate m a] -> Predicate m a
and preds =
Predicate
{ predicateFunc = \actual ->
verifyAll (const "All predicates passed") <$> mapM (\p -> predicateFunc p actual) preds
, predicateDisp = andify predList
, predicateDispNeg = "At least one failure:\n" <> andify predList
}
where
andify = Text.intercalate "\nand "
predList = map (parens . predicateDisp) preds
-- | A predicate checking if the input matches any of the given predicates
--
-- >>> 1 `shouldSatisfy` P.or [P.lt 5, P.gt 10]
or :: (Monad m) => [Predicate m a] -> Predicate m a
or preds =
Predicate
{ predicateFunc = \actual ->
verifyAny (const "No predicates passed") <$> mapM (\p -> predicateFunc p actual) preds
, predicateDisp = orify predList
, predicateDispNeg = "All failures:\n" <> orify predList
}
where
orify = Text.intercalate "\nor "
predList = map (parens . predicateDisp) preds
{----- Containers -----}
-- | A predicate checking if the input is a list-like type where some element matches the given predicate.
--
-- >>> [1, 2, 3] `shouldSatisfy` P.any (P.eq 1)
any :: (Foldable t, Monad m) => Predicate m a -> Predicate m (t a)
any Predicate{..} =
Predicate
{ predicateFunc = \actual ->
verifyAny (const "No values matched") <$> mapM predicateFunc (toList actual)
, predicateDisp = "at least one element matching " <> parens predicateDisp
, predicateDispNeg = "no elements matching " <> parens predicateDisp
}
-- | A predicate checking if the input is a list-like type where all elements match the given predicate.
--
-- >>> [1, 2, 3] `shouldSatisfy` P.all (P.gt 0)
all :: (Foldable t, Monad m) => Predicate m a -> Predicate m (t a)
all Predicate{..} =
Predicate
{ predicateFunc = \actual ->
verifyAll (const "All values matched") <$> mapM predicateFunc (toList actual)
, predicateDisp = "all elements matching " <> parens predicateDisp
, predicateDispNeg = "some elements not matching " <> parens predicateDisp
}
-- | A predicate checking if the input is a list-like type where the given element is present.
-- Equivalent to @P.any . P.eq@.
--
-- >>> [1, 2, 3] `shouldSatisfy` P.elem 1
elem :: (Eq a, Foldable t, Monad m) => a -> Predicate m (t a)
elem = any . eq
{----- Subsequences -----}
class HasSubsequences a where
isPrefixOf :: a -> a -> Bool
isInfixOf :: a -> a -> Bool
isSuffixOf :: a -> a -> Bool
instance (Eq a) => HasSubsequences [a] where
isPrefixOf = List.isPrefixOf
isInfixOf = List.isInfixOf
isSuffixOf = List.isSuffixOf
instance HasSubsequences Text where
isPrefixOf = Text.isPrefixOf
isInfixOf = Text.isInfixOf
isSuffixOf = Text.isSuffixOf
-- | A predicate checking if the input has the given prefix
--
-- >>> [1, 2, 3] `shouldSatisfy` P.hasPrefix [1, 2]
-- >>> "hello world" `shouldSatisfy` P.hasPrefix "hello "
hasPrefix :: (HasSubsequences a, Monad m) => a -> Predicate m a
hasPrefix prefix =
Predicate
{ predicateFunc = \val -> do
let success = prefix `isPrefixOf` val
pure
PredicateFuncResult
{ predicateSuccess = success
, predicateExplain =
if success
then render val <> " " <> disp
else render val <> " " <> dispNeg
, predicateShowFailCtx = noCtx
}
, predicateDisp = disp
, predicateDispNeg = dispNeg
}
where
disp = "has prefix " <> render prefix
dispNeg = "does not have prefix " <> render prefix
-- | A predicate checking if the input contains the given subsequence
--
-- >>> [1, 2, 3] `shouldSatisfy` P.hasInfix [2]
-- >>> "hello world" `shouldSatisfy` P.hasInfix "ello"
hasInfix :: (HasSubsequences a, Monad m) => a -> Predicate m a
hasInfix elems =
Predicate
{ predicateFunc = \val -> do
let success = elems `isInfixOf` val
pure
PredicateFuncResult
{ predicateSuccess = success
, predicateExplain =
if success
then render val <> " " <> disp
else render val <> " " <> dispNeg
, predicateShowFailCtx = noCtx
}
, predicateDisp = disp
, predicateDispNeg = dispNeg
}
where
disp = "has infix " <> render elems
dispNeg = "does not have infix " <> render elems
-- | A predicate checking if the input has the given suffix
--
-- >>> [1, 2, 3] `shouldSatisfy` P.hasSuffix [2, 3]
-- >>> "hello world" `shouldSatisfy` P.hasSuffix " world"
hasSuffix :: (HasSubsequences a, Monad m) => a -> Predicate m a
hasSuffix suffix =
Predicate
{ predicateFunc = \val -> do
let success = suffix `isSuffixOf` val
pure
PredicateFuncResult
{ predicateSuccess = success
, predicateExplain =
if success
then render val <> " " <> disp
else render val <> " " <> dispNeg
, predicateShowFailCtx = noCtx
}
, predicateDisp = disp
, predicateDispNeg = dispNeg
}
where
disp = "has suffix " <> render suffix
dispNeg = "does not have suffix " <> render suffix
{----- IO -----}
-- | A predicate checking if the input is an IO action that returns a value matching the given predicate.
--
-- >>> pure 1 `shouldSatisfy` P.returns (P.eq 1)
returns :: (MonadIO m) => Predicate m a -> Predicate m (m a)
returns Predicate{..} =
Predicate
{ predicateFunc = \io -> do
x <- io
PredicateFuncResult{..} <- predicateFunc x
pure
PredicateFuncResult
{ predicateSuccess = predicateSuccess
, predicateExplain =
if predicateSuccess
then predicateExplain
else
let failCtx =
FailCtx
{ failCtxExpected = predicateDisp
, failCtxActual = render x
}
in withFailCtx failCtx predicateShowFailCtx predicateExplain
, predicateShowFailCtx = HideFailCtx
}
, predicateDisp = predicateDisp
, predicateDispNeg = predicateDispNeg
}
-- | A predicate checking if the input is an IO action that throws an exception matching the given predicate.
--
-- >>> throwIO MyException `shouldSatisfy` P.throws (P.eq MyException)
throws :: (Exception e, MonadUnliftIO m) => Predicate m e -> Predicate m (m a)
throws Predicate{..} =
Predicate
{ predicateFunc = \io ->
try io >>= \case
Left e -> do
PredicateFuncResult{..} <- predicateFunc e
pure
PredicateFuncResult
{ predicateSuccess = predicateSuccess
, predicateExplain =
if predicateSuccess
then predicateExplain
else
let failCtx =
FailCtx
{ failCtxExpected = disp
, failCtxActual = Text.pack $ displayException e
}
in withFailCtx failCtx predicateShowFailCtx predicateExplain
, predicateShowFailCtx = HideFailCtx
}
Right x ->
pure
PredicateFuncResult
{ predicateSuccess = False
, predicateExplain =
renderFailCtx
FailCtx
{ failCtxExpected = disp
, failCtxActual = render x
}
, predicateShowFailCtx = HideFailCtx
}
, predicateDisp = disp
, predicateDispNeg = dispNeg
}
where
disp = "throws (" <> predicateDisp <> ")"
dispNeg = "does not throw (" <> predicateDisp <> ")"
{----- Functions -----}
data Fun a b = Fun String (a -> b)
data IsoChecker a b = IsoChecker (Fun a b) (Fun a b)
-- | Verify if two functions are isomorphic.
--
-- @
-- prop "reverse . reverse === id" $ do
-- let genList = Gen.list (Range.linear 0 10) $ Gen.int (Range.linear 0 1000)
-- (reverse . reverse) P.=== id \`shouldSatisfy\` P.isoWith genList
-- @
(===) :: (a -> b) -> (a -> b) -> IsoChecker a b
f === g = IsoChecker (Fun "lhs" f) (Fun "rhs" g)
infix 2 ===
-- | See '(===)'.
isoWith :: (GHC.HasCallStack, Show a, Eq b) => Gen a -> Predicate PropertyM (IsoChecker a b)
isoWith gen =
Predicate
{ predicateFunc = \(IsoChecker (Fun f1DispS f1) (Fun f2DispS f2)) -> do
a <- GHC.withFrozenCallStack $ forAll gen
let
f1Disp = Text.pack f1DispS
f2Disp = Text.pack f2DispS
b1 = f1 a
b2 = f2 a
aDisp = parens $ render a
b1Disp = parens $ render b1
b2Disp = parens $ render b2
pure
PredicateFuncResult
{ predicateSuccess = b1 == b2
, predicateExplain =
Text.intercalate "\n" $
[ b1Disp <> " " <> (if b1 == b2 then "=" else "≠") <> " " <> b2Disp
, "where"
, indent $ b1Disp <> " = " <> f1Disp <> " " <> aDisp
, indent $ b2Disp <> " = " <> f2Disp <> " " <> aDisp
]
, predicateShowFailCtx = HideFailCtx
}
, predicateDisp = disp
, predicateDispNeg = dispNeg
}
where
disp = "isomorphic"
dispNeg = "not isomorphic"
{----- Snapshot -----}
-- | A predicate checking if the input matches the snapshot.
-- See the "Snapshot tests" section in the README.
--
-- >>> user `shouldSatisfy` P.matchesSnapshot
matchesSnapshot :: (Typeable a, MonadIO m) => Predicate m a
matchesSnapshot =
Predicate
{ predicateFunc = \actual -> do
SnapshotUpdateFlag doUpdate <- getFlag
testInfo <- getTestInfo
snapshotIndex <- getAndIncSnapshotIndex
renderers <- getSnapshotRenderers
let ctx =
SnapshotContext
{ snapshotRenderers = renderers
, snapshotTestInfo = testInfo
, snapshotIndex
}
result <-
if doUpdate
then updateSnapshot ctx actual >> pure SnapshotMatches
else checkSnapshot ctx actual
pure
PredicateFuncResult
{ predicateSuccess = result == SnapshotMatches
, predicateExplain =
case result of
SnapshotMissing -> "Snapshot does not exist. Update snapshot with --update."
SnapshotMatches -> "Matches snapshot"
SnapshotDiff snapshot renderedActual ->
Text.intercalate "\n" $
[ "Result differed from snapshot. Update snapshot with --update."
, showLineDiff ("expected", snapshot) ("actual", renderedActual)
]
, predicateShowFailCtx = HideFailCtx
}
, predicateDisp = "matches snapshot"
, predicateDispNeg = "does not match snapshot"
}
{----- Utilities -----}
mkPredicateOp ::
(Monad m) =>
-- | operator
Text ->
-- | negative operator
Text ->
-- | actual -> expected -> success
(a -> a -> Bool) ->
-- | expected
a ->
Predicate m a
mkPredicateOp op negOp f expected =
Predicate
{ predicateFunc = \actual -> do
let success = f actual expected
pure
PredicateFuncResult
{ predicateSuccess = success
, predicateExplain =
if success
then render actual <> " " <> disp
else render actual <> " " <> dispNeg
, predicateShowFailCtx = noCtx
}
, predicateDisp = disp
, predicateDispNeg = dispNeg
}
where
disp = op <> " " <> render expected
dispNeg = negOp <> " " <> render expected
runPredicates :: (Monad m) => HList (Predicate m) xs -> HList Identity xs -> m [PredicateFuncResult]
runPredicates preds = HList.toListWithM run . HList.hzip preds
where
run :: (Predicate m :*: Identity) a -> m PredicateFuncResult
run (p :*: Identity x) = predicateFunc p x
verifyAll :: ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult
verifyAll mergeMessages results =
PredicateFuncResult
{ predicateSuccess = isNothing firstFailure
, predicateExplain =
case firstFailure of
Just p -> predicateExplain p
Nothing -> mergeMessages $ map predicateExplain results
, predicateShowFailCtx = showMergedCtxs results
}
where
firstFailure = listToMaybe $ filter (Prelude.not . predicateSuccess) results
verifyAny :: ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult
verifyAny mergeMessages results =
PredicateFuncResult
{ predicateSuccess = isJust firstSuccess
, predicateExplain =
case firstSuccess of
Just p -> predicateExplain p
Nothing -> mergeMessages $ map predicateExplain results
, predicateShowFailCtx = showMergedCtxs results
}
where
firstSuccess = listToMaybe $ filter predicateSuccess results
render :: a -> Text
render = Text.pack . anythingToString
-- | Add parentheses if the given input contains spaces.
parens :: Text -> Text
parens s =
if " " `Text.isInfixOf` s
then "(" <> s <> ")"
else s
indent :: Text -> Text
indent = Text.intercalate "\n" . map (" " <>) . Text.splitOn "\n"