{-# 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 UnliftIO (MonadUnliftIO)
import UnliftIO.Exception (Exception, displayException, try)
import Prelude hiding (abs, all, and, any, elem, not, or, (&&), (||))
import Prelude qualified

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)

data Predicate m a = Predicate
  { forall (m :: * -> *) a. Predicate m a -> a -> m PredicateFuncResult
predicateFunc :: a -> m PredicateFuncResult
  , forall (m :: * -> *) a. Predicate m a -> Text
predicateDisp :: Text
  -- ^ The rendered representation of the predicate
  , forall (m :: * -> *) a. Predicate m a -> Text
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 :: forall (m :: * -> *) a.
Monad m =>
Predicate m a -> a -> m PredicateResult
runPredicate Predicate{Text
a -> m PredicateFuncResult
predicateFunc :: forall (m :: * -> *) a. Predicate m a -> a -> m PredicateFuncResult
predicateDisp :: forall (m :: * -> *) a. Predicate m a -> Text
predicateDispNeg :: forall (m :: * -> *) a. Predicate m a -> Text
predicateFunc :: a -> m PredicateFuncResult
predicateDisp :: Text
predicateDispNeg :: Text
..} a
val = do
  PredicateFuncResult{..} <- a -> m PredicateFuncResult
predicateFunc a
val
  pure $
    if predicateSuccess
      then PredicateSuccess
      else
        let failCtx =
              FailCtx
                { failCtxExpected :: Text
failCtxExpected = Text
predicateDisp
                , failCtxActual :: Text
failCtxActual = a -> Text
forall a. a -> Text
render a
val
                }
         in PredicateFail . withFailCtx failCtx predicateShowFailCtx $ predicateExplain

renderPredicate :: Predicate m a -> Text
renderPredicate :: forall (m :: * -> *) a. Predicate m a -> Text
renderPredicate = Predicate m a -> Text
forall (m :: * -> *) a. Predicate m a -> Text
predicateDisp

data PredicateFuncResult = PredicateFuncResult
  { PredicateFuncResult -> Bool
predicateSuccess :: Bool
  , PredicateFuncResult -> Text
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.
  , PredicateFuncResult -> ShowFailCtx
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 (ShowFailCtx -> ShowFailCtx -> Bool
(ShowFailCtx -> ShowFailCtx -> Bool)
-> (ShowFailCtx -> ShowFailCtx -> Bool) -> Eq ShowFailCtx
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShowFailCtx -> ShowFailCtx -> Bool
== :: ShowFailCtx -> ShowFailCtx -> Bool
$c/= :: ShowFailCtx -> ShowFailCtx -> Bool
/= :: ShowFailCtx -> ShowFailCtx -> Bool
Eq, Eq ShowFailCtx
Eq ShowFailCtx =>
(ShowFailCtx -> ShowFailCtx -> Ordering)
-> (ShowFailCtx -> ShowFailCtx -> Bool)
-> (ShowFailCtx -> ShowFailCtx -> Bool)
-> (ShowFailCtx -> ShowFailCtx -> Bool)
-> (ShowFailCtx -> ShowFailCtx -> Bool)
-> (ShowFailCtx -> ShowFailCtx -> ShowFailCtx)
-> (ShowFailCtx -> ShowFailCtx -> ShowFailCtx)
-> Ord ShowFailCtx
ShowFailCtx -> ShowFailCtx -> Bool
ShowFailCtx -> ShowFailCtx -> Ordering
ShowFailCtx -> ShowFailCtx -> ShowFailCtx
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ShowFailCtx -> ShowFailCtx -> Ordering
compare :: ShowFailCtx -> ShowFailCtx -> Ordering
$c< :: ShowFailCtx -> ShowFailCtx -> Bool
< :: ShowFailCtx -> ShowFailCtx -> Bool
$c<= :: ShowFailCtx -> ShowFailCtx -> Bool
<= :: ShowFailCtx -> ShowFailCtx -> Bool
$c> :: ShowFailCtx -> ShowFailCtx -> Bool
> :: ShowFailCtx -> ShowFailCtx -> Bool
$c>= :: ShowFailCtx -> ShowFailCtx -> Bool
>= :: ShowFailCtx -> ShowFailCtx -> Bool
$cmax :: ShowFailCtx -> ShowFailCtx -> ShowFailCtx
max :: ShowFailCtx -> ShowFailCtx -> ShowFailCtx
$cmin :: ShowFailCtx -> ShowFailCtx -> ShowFailCtx
min :: ShowFailCtx -> ShowFailCtx -> ShowFailCtx
Ord)

shouldShowFailCtx :: ShowFailCtx -> Bool
shouldShowFailCtx :: ShowFailCtx -> Bool
shouldShowFailCtx = \case
  ShowFailCtx
NoFailCtx -> Bool
False
  ShowFailCtx
ShowFailCtx -> Bool
True
  ShowFailCtx
HideFailCtx -> Bool
False

data FailCtx = FailCtx
  { FailCtx -> Text
failCtxExpected :: Text
  , FailCtx -> Text
failCtxActual :: Text
  }

renderFailCtx :: FailCtx -> Text
renderFailCtx :: FailCtx -> Text
renderFailCtx FailCtx{Text
failCtxExpected :: FailCtx -> Text
failCtxActual :: FailCtx -> Text
failCtxExpected :: Text
failCtxActual :: Text
..} =
  Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
    [ Text
"Expected:"
    , Text -> Text
indent Text
failCtxExpected
    , Text
""
    , Text
"Got:"
    , Text -> Text
indent Text
failCtxActual
    ]

withFailCtx :: FailCtx -> ShowFailCtx -> Text -> Text
withFailCtx :: FailCtx -> ShowFailCtx -> Text -> Text
withFailCtx FailCtx
failCtx ShowFailCtx
ctx Text
s =
  if ShowFailCtx -> Bool
shouldShowFailCtx ShowFailCtx
ctx
    then Text -> [Text] -> Text
Text.intercalate Text
"\n" [Text
s, Text
"", FailCtx -> Text
renderFailCtx FailCtx
failCtx]
    else Text
s

noCtx :: ShowFailCtx
noCtx :: ShowFailCtx
noCtx = ShowFailCtx
NoFailCtx

showMergedCtxs :: [PredicateFuncResult] -> ShowFailCtx
showMergedCtxs :: [PredicateFuncResult] -> ShowFailCtx
showMergedCtxs = ShowFailCtx -> ShowFailCtx -> ShowFailCtx
forall a. Ord a => a -> a -> a
max ShowFailCtx
ShowFailCtx (ShowFailCtx -> ShowFailCtx)
-> ([PredicateFuncResult] -> ShowFailCtx)
-> [PredicateFuncResult]
-> ShowFailCtx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowFailCtx
-> (NonEmpty ShowFailCtx -> ShowFailCtx)
-> Maybe (NonEmpty ShowFailCtx)
-> ShowFailCtx
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ShowFailCtx
NoFailCtx NonEmpty ShowFailCtx -> ShowFailCtx
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable1 t, Ord a) => t a -> a
Foldable1.maximum (Maybe (NonEmpty ShowFailCtx) -> ShowFailCtx)
-> ([PredicateFuncResult] -> Maybe (NonEmpty ShowFailCtx))
-> [PredicateFuncResult]
-> ShowFailCtx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ShowFailCtx] -> Maybe (NonEmpty ShowFailCtx)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty ([ShowFailCtx] -> Maybe (NonEmpty ShowFailCtx))
-> ([PredicateFuncResult] -> [ShowFailCtx])
-> [PredicateFuncResult]
-> Maybe (NonEmpty ShowFailCtx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PredicateFuncResult -> ShowFailCtx)
-> [PredicateFuncResult] -> [ShowFailCtx]
forall a b. (a -> b) -> [a] -> [b]
map PredicateFuncResult -> ShowFailCtx
predicateShowFailCtx

showCtx :: PredicateFuncResult -> PredicateFuncResult
showCtx :: PredicateFuncResult -> PredicateFuncResult
showCtx PredicateFuncResult
result = PredicateFuncResult
result{predicateShowFailCtx = max ShowFailCtx $ predicateShowFailCtx result}

{----- General -----}

-- | A predicate that matches any value
anything :: (Monad m) => Predicate m a
anything :: forall (m :: * -> *) a. Monad m => Predicate m a
anything =
  Predicate
    { predicateFunc :: a -> m PredicateFuncResult
predicateFunc = \a
_ ->
        PredicateFuncResult -> m PredicateFuncResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          PredicateFuncResult
            { predicateSuccess :: Bool
predicateSuccess = Bool
True
            , predicateExplain :: Text
predicateExplain = Text
"anything"
            , predicateShowFailCtx :: ShowFailCtx
predicateShowFailCtx = ShowFailCtx
noCtx
            }
    , predicateDisp :: Text
predicateDisp = Text
"anything"
    , predicateDispNeg :: Text
predicateDispNeg = Text
"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 :: forall a (m :: * -> *). (Eq a, Monad m) => a -> Predicate m a
eq = Text -> Text -> (a -> a -> Bool) -> a -> Predicate m a
forall (m :: * -> *) a.
Monad m =>
Text -> Text -> (a -> a -> Bool) -> a -> Predicate m a
mkPredicateOp Text
"=" Text
"≠" ((a -> a -> Bool) -> a -> Predicate m a)
-> (a -> a -> Bool) -> a -> Predicate m a
forall a b. (a -> b) -> a -> b
$ \a
actual a
expected -> a
actual a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
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 :: forall a (m :: * -> *). (Ord a, Monad m) => a -> Predicate m a
gt = Text -> Text -> (a -> a -> Bool) -> a -> Predicate m a
forall (m :: * -> *) a.
Monad m =>
Text -> Text -> (a -> a -> Bool) -> a -> Predicate m a
mkPredicateOp Text
">" Text
"≯" ((a -> a -> Bool) -> a -> Predicate m a)
-> (a -> a -> Bool) -> a -> Predicate m a
forall a b. (a -> b) -> a -> b
$ \a
actual a
expected -> a
actual a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
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 :: forall a (m :: * -> *). (Ord a, Monad m) => a -> Predicate m a
gte = Text -> Text -> (a -> a -> Bool) -> a -> Predicate m a
forall (m :: * -> *) a.
Monad m =>
Text -> Text -> (a -> a -> Bool) -> a -> Predicate m a
mkPredicateOp Text
"≥" Text
"≱" ((a -> a -> Bool) -> a -> Predicate m a)
-> (a -> a -> Bool) -> a -> Predicate m a
forall a b. (a -> b) -> a -> b
$ \a
actual a
expected -> a
actual a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
expected Bool -> Bool -> Bool
Prelude.|| a
actual a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
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 :: forall a (m :: * -> *). (Ord a, Monad m) => a -> Predicate m a
lt = Text -> Text -> (a -> a -> Bool) -> a -> Predicate m a
forall (m :: * -> *) a.
Monad m =>
Text -> Text -> (a -> a -> Bool) -> a -> Predicate m a
mkPredicateOp Text
"<" Text
"≮" ((a -> a -> Bool) -> a -> Predicate m a)
-> (a -> a -> Bool) -> a -> Predicate m a
forall a b. (a -> b) -> a -> b
$ \a
actual a
expected -> a
actual a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
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 :: forall a (m :: * -> *). (Ord a, Monad m) => a -> Predicate m a
lte = Text -> Text -> (a -> a -> Bool) -> a -> Predicate m a
forall (m :: * -> *) a.
Monad m =>
Text -> Text -> (a -> a -> Bool) -> a -> Predicate m a
mkPredicateOp Text
"≤" Text
"≰" ((a -> a -> Bool) -> a -> Predicate m a)
-> (a -> a -> Bool) -> a -> Predicate m a
forall a b. (a -> b) -> a -> b
$ \a
actual a
expected -> a
actual a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
expected Bool -> Bool -> Bool
Prelude.|| a
actual a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
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 :: forall (m :: * -> *) a.
Monad m =>
Predicate m a -> Predicate m (Maybe a)
just Predicate m a
p = String
-> Maybe (HList (Const String) '[a])
-> (Maybe a -> Maybe (HList Identity '[a]))
-> HList (Predicate m) '[a]
-> Predicate m (Maybe a)
forall (m :: * -> *) (fields :: [*]) a.
Monad m =>
String
-> Maybe (HList (Const String) fields)
-> (a -> Maybe (HList Identity fields))
-> HList (Predicate m) fields
-> Predicate m a
conMatches String
"Just" Maybe (HList (Const String) '[a])
forall {a}. Maybe a
fieldNames Maybe a -> Maybe (HList Identity '[a])
forall {x}. Maybe x -> Maybe (HList Identity '[x])
toFields HList (Predicate m) '[a]
preds
  where
    fieldNames :: Maybe a
fieldNames = Maybe a
forall {a}. Maybe a
Nothing
    toFields :: Maybe x -> Maybe (HList Identity '[x])
toFields = \case
      Just x
x -> HList Identity '[x] -> Maybe (HList Identity '[x])
forall a. a -> Maybe a
Just (HList Identity '[x] -> Maybe (HList Identity '[x]))
-> (HList Identity '[] -> HList Identity '[x])
-> HList Identity '[]
-> Maybe (HList Identity '[x])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity x -> HList Identity '[] -> HList Identity '[x]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (x -> Identity x
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
x) (HList Identity '[] -> Maybe (HList Identity '[x]))
-> HList Identity '[] -> Maybe (HList Identity '[x])
forall a b. (a -> b) -> a -> b
$ HList Identity '[]
forall {k} (f :: k -> *). HList f '[]
HNil
      Maybe x
_ -> Maybe (HList Identity '[x])
forall {a}. Maybe a
Nothing
    preds :: HList (Predicate m) '[a]
preds = Predicate m a
-> HList (Predicate m) '[] -> HList (Predicate m) '[a]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m a
p HList (Predicate m) '[]
forall {k} (f :: k -> *). HList f '[]
HNil

-- | A predicate checking if the input is Nothing
--
-- >>> Nothing `shouldSatisfy` P.nothing
nothing :: (Monad m) => Predicate m (Maybe a)
nothing :: forall (m :: * -> *) a. Monad m => Predicate m (Maybe a)
nothing = String
-> Maybe (HList (Const String) '[])
-> (Maybe a -> Maybe (HList Identity '[]))
-> HList (Predicate m) '[]
-> Predicate m (Maybe a)
forall (m :: * -> *) (fields :: [*]) a.
Monad m =>
String
-> Maybe (HList (Const String) fields)
-> (a -> Maybe (HList Identity fields))
-> HList (Predicate m) fields
-> Predicate m a
conMatches String
"Nothing" Maybe (HList (Const String) '[])
forall {a}. Maybe a
fieldNames Maybe a -> Maybe (HList Identity '[])
forall {k} {a} {f :: k -> *}. Maybe a -> Maybe (HList f '[])
toFields HList (Predicate m) '[]
forall {k} (f :: k -> *). HList f '[]
preds
  where
    fieldNames :: Maybe a
fieldNames = Maybe a
forall {a}. Maybe a
Nothing
    toFields :: Maybe a -> Maybe (HList f '[])
toFields = \case
      Maybe a
Nothing -> HList f '[] -> Maybe (HList f '[])
forall a. a -> Maybe a
Just HList f '[]
forall {k} (f :: k -> *). HList f '[]
HNil
      Maybe a
_ -> Maybe (HList f '[])
forall {a}. Maybe a
Nothing
    preds :: HList f '[]
preds = HList f '[]
forall {k} (f :: k -> *). HList f '[]
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 :: forall (m :: * -> *) a b.
Monad m =>
Predicate m a -> Predicate m (Either a b)
left Predicate m a
p = String
-> Maybe (HList (Const String) '[a])
-> (Either a b -> Maybe (HList Identity '[a]))
-> HList (Predicate m) '[a]
-> Predicate m (Either a b)
forall (m :: * -> *) (fields :: [*]) a.
Monad m =>
String
-> Maybe (HList (Const String) fields)
-> (a -> Maybe (HList Identity fields))
-> HList (Predicate m) fields
-> Predicate m a
conMatches String
"Left" Maybe (HList (Const String) '[a])
forall {a}. Maybe a
fieldNames Either a b -> Maybe (HList Identity '[a])
forall {x} {b}. Either x b -> Maybe (HList Identity '[x])
toFields HList (Predicate m) '[a]
preds
  where
    fieldNames :: Maybe a
fieldNames = Maybe a
forall {a}. Maybe a
Nothing
    toFields :: Either x b -> Maybe (HList Identity '[x])
toFields = \case
      Left x
x -> HList Identity '[x] -> Maybe (HList Identity '[x])
forall a. a -> Maybe a
Just (HList Identity '[x] -> Maybe (HList Identity '[x]))
-> (HList Identity '[] -> HList Identity '[x])
-> HList Identity '[]
-> Maybe (HList Identity '[x])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity x -> HList Identity '[] -> HList Identity '[x]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (x -> Identity x
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
x) (HList Identity '[] -> Maybe (HList Identity '[x]))
-> HList Identity '[] -> Maybe (HList Identity '[x])
forall a b. (a -> b) -> a -> b
$ HList Identity '[]
forall {k} (f :: k -> *). HList f '[]
HNil
      Either x b
_ -> Maybe (HList Identity '[x])
forall {a}. Maybe a
Nothing
    preds :: HList (Predicate m) '[a]
preds = Predicate m a
-> HList (Predicate m) '[] -> HList (Predicate m) '[a]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m a
p HList (Predicate m) '[]
forall {k} (f :: k -> *). HList f '[]
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 :: forall (m :: * -> *) b a.
Monad m =>
Predicate m b -> Predicate m (Either a b)
right Predicate m b
p = String
-> Maybe (HList (Const String) '[b])
-> (Either a b -> Maybe (HList Identity '[b]))
-> HList (Predicate m) '[b]
-> Predicate m (Either a b)
forall (m :: * -> *) (fields :: [*]) a.
Monad m =>
String
-> Maybe (HList (Const String) fields)
-> (a -> Maybe (HList Identity fields))
-> HList (Predicate m) fields
-> Predicate m a
conMatches String
"Right" Maybe (HList (Const String) '[b])
forall {a}. Maybe a
fieldNames Either a b -> Maybe (HList Identity '[b])
forall {a} {x}. Either a x -> Maybe (HList Identity '[x])
toFields HList (Predicate m) '[b]
preds
  where
    fieldNames :: Maybe a
fieldNames = Maybe a
forall {a}. Maybe a
Nothing
    toFields :: Either a x -> Maybe (HList Identity '[x])
toFields = \case
      Right x
x -> HList Identity '[x] -> Maybe (HList Identity '[x])
forall a. a -> Maybe a
Just (HList Identity '[x] -> Maybe (HList Identity '[x]))
-> (HList Identity '[] -> HList Identity '[x])
-> HList Identity '[]
-> Maybe (HList Identity '[x])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity x -> HList Identity '[] -> HList Identity '[x]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (x -> Identity x
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
x) (HList Identity '[] -> Maybe (HList Identity '[x]))
-> HList Identity '[] -> Maybe (HList Identity '[x])
forall a b. (a -> b) -> a -> b
$ HList Identity '[]
forall {k} (f :: k -> *). HList f '[]
HNil
      Either a x
_ -> Maybe (HList Identity '[x])
forall {a}. Maybe a
Nothing
    preds :: HList (Predicate m) '[b]
preds = Predicate m b
-> HList (Predicate m) '[] -> HList (Predicate m) '[b]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m b
p HList (Predicate m) '[]
forall {k} (f :: k -> *). HList f '[]
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 :: forall (m :: * -> *) a.
Monad m =>
[Predicate m a] -> Predicate m [a]
list [Predicate m a]
predList =
  Predicate
    { predicateFunc :: [a] -> m PredicateFuncResult
predicateFunc = \[a]
actual ->
        if [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
actual Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Predicate m a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Predicate m a]
predList
          then ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult
verifyAll [Text] -> Text
listify ([PredicateFuncResult] -> PredicateFuncResult)
-> m [PredicateFuncResult] -> m PredicateFuncResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [m PredicateFuncResult] -> m [PredicateFuncResult]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((Predicate m a -> a -> m PredicateFuncResult)
-> [Predicate m a] -> [a] -> [m PredicateFuncResult]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Predicate m a -> a -> m PredicateFuncResult
forall (m :: * -> *) a. Predicate m a -> a -> m PredicateFuncResult
predicateFunc [Predicate m a]
predList [a]
actual)
          else
            PredicateFuncResult -> m PredicateFuncResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              PredicateFuncResult
                { predicateSuccess :: Bool
predicateSuccess = Bool
False
                , predicateExplain :: Text
predicateExplain = Text
"Got different number of elements"
                , predicateShowFailCtx :: ShowFailCtx
predicateShowFailCtx = ShowFailCtx
ShowFailCtx
                }
    , predicateDisp :: Text
predicateDisp = Text
disp
    , predicateDispNeg :: Text
predicateDispNeg = Text
dispNeg
    }
  where
    listify :: [Text] -> Text
listify [Text]
vals = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
vals Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
    disp :: Text
disp = [Text] -> Text
listify ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Predicate m a -> Text) -> [Predicate m a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Predicate m a -> Text
forall (m :: * -> *) a. Predicate m a -> Text
predicateDisp [Predicate m a]
predList
    dispNeg :: Text
dispNeg = Text
"not " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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) -> HList Identity (TupleArgs (a, b))
toHList (a
a, b
b) = Identity a -> HList Identity '[b] -> HList Identity '[a, b]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (a -> Identity a
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) (HList Identity '[b] -> HList Identity (TupleArgs (a, b)))
-> (HList Identity '[] -> HList Identity '[b])
-> HList Identity '[]
-> HList Identity (TupleArgs (a, b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity b -> HList Identity '[] -> HList Identity '[b]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (b -> Identity b
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b) (HList Identity '[] -> HList Identity (TupleArgs (a, b)))
-> HList Identity '[] -> HList Identity (TupleArgs (a, b))
forall a b. (a -> b) -> a -> b
$ HList Identity '[]
forall {k} (f :: k -> *). HList f '[]
HNil
instance IsTuple (a, b, c) where
  type TupleArgs (a, b, c) = '[a, b, c]
  toHList :: (a, b, c) -> HList Identity (TupleArgs (a, b, c))
toHList (a
a, b
b, c
c) = Identity a -> HList Identity '[b, c] -> HList Identity '[a, b, c]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (a -> Identity a
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) (HList Identity '[b, c] -> HList Identity (TupleArgs (a, b, c)))
-> (HList Identity '[] -> HList Identity '[b, c])
-> HList Identity '[]
-> HList Identity (TupleArgs (a, b, c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity b -> HList Identity '[c] -> HList Identity '[b, c]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (b -> Identity b
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b) (HList Identity '[c] -> HList Identity '[b, c])
-> (HList Identity '[] -> HList Identity '[c])
-> HList Identity '[]
-> HList Identity '[b, c]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity c -> HList Identity '[] -> HList Identity '[c]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (c -> Identity c
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
c) (HList Identity '[] -> HList Identity (TupleArgs (a, b, c)))
-> HList Identity '[] -> HList Identity (TupleArgs (a, b, c))
forall a b. (a -> b) -> a -> b
$ HList Identity '[]
forall {k} (f :: k -> *). HList f '[]
HNil
instance IsTuple (a, b, c, d) where
  type TupleArgs (a, b, c, d) = '[a, b, c, d]
  toHList :: (a, b, c, d) -> HList Identity (TupleArgs (a, b, c, d))
toHList (a
a, b
b, c
c, d
d) = Identity a
-> HList Identity '[b, c, d] -> HList Identity '[a, b, c, d]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (a -> Identity a
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) (HList Identity '[b, c, d]
 -> HList Identity (TupleArgs (a, b, c, d)))
-> (HList Identity '[] -> HList Identity '[b, c, d])
-> HList Identity '[]
-> HList Identity (TupleArgs (a, b, c, d))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity b -> HList Identity '[c, d] -> HList Identity '[b, c, d]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (b -> Identity b
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b) (HList Identity '[c, d] -> HList Identity '[b, c, d])
-> (HList Identity '[] -> HList Identity '[c, d])
-> HList Identity '[]
-> HList Identity '[b, c, d]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity c -> HList Identity '[d] -> HList Identity '[c, d]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (c -> Identity c
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
c) (HList Identity '[d] -> HList Identity '[c, d])
-> (HList Identity '[] -> HList Identity '[d])
-> HList Identity '[]
-> HList Identity '[c, d]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity d -> HList Identity '[] -> HList Identity '[d]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (d -> Identity d
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure d
d) (HList Identity '[] -> HList Identity (TupleArgs (a, b, c, d)))
-> HList Identity '[] -> HList Identity (TupleArgs (a, b, c, d))
forall a b. (a -> b) -> a -> b
$ HList Identity '[]
forall {k} (f :: k -> *). HList f '[]
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) -> HList Identity (TupleArgs (a, b, c, d, e))
toHList (a
a, b
b, c
c, d
d, e
e) = Identity a
-> HList Identity '[b, c, d, e] -> HList Identity '[a, b, c, d, e]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (a -> Identity a
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) (HList Identity '[b, c, d, e]
 -> HList Identity (TupleArgs (a, b, c, d, e)))
-> (HList Identity '[] -> HList Identity '[b, c, d, e])
-> HList Identity '[]
-> HList Identity (TupleArgs (a, b, c, d, e))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity b
-> HList Identity '[c, d, e] -> HList Identity '[b, c, d, e]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (b -> Identity b
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b) (HList Identity '[c, d, e] -> HList Identity '[b, c, d, e])
-> (HList Identity '[] -> HList Identity '[c, d, e])
-> HList Identity '[]
-> HList Identity '[b, c, d, e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity c -> HList Identity '[d, e] -> HList Identity '[c, d, e]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (c -> Identity c
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
c) (HList Identity '[d, e] -> HList Identity '[c, d, e])
-> (HList Identity '[] -> HList Identity '[d, e])
-> HList Identity '[]
-> HList Identity '[c, d, e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity d -> HList Identity '[e] -> HList Identity '[d, e]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (d -> Identity d
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure d
d) (HList Identity '[e] -> HList Identity '[d, e])
-> (HList Identity '[] -> HList Identity '[e])
-> HList Identity '[]
-> HList Identity '[d, e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity e -> HList Identity '[] -> HList Identity '[e]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (e -> Identity e
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure e
e) (HList Identity '[] -> HList Identity (TupleArgs (a, b, c, d, e)))
-> HList Identity '[] -> HList Identity (TupleArgs (a, b, c, d, e))
forall a b. (a -> b) -> a -> b
$ HList Identity '[]
forall {k} (f :: k -> *). HList f '[]
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) -> HList Identity (TupleArgs (a, b, c, d, e, f))
toHList (a
a, b
b, c
c, d
d, e
e, f
f) = Identity a
-> HList Identity '[b, c, d, e, f]
-> HList Identity '[a, b, c, d, e, f]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (a -> Identity a
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a) (HList Identity '[b, c, d, e, f]
 -> HList Identity (TupleArgs (a, b, c, d, e, f)))
-> (HList Identity '[] -> HList Identity '[b, c, d, e, f])
-> HList Identity '[]
-> HList Identity (TupleArgs (a, b, c, d, e, f))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity b
-> HList Identity '[c, d, e, f] -> HList Identity '[b, c, d, e, f]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (b -> Identity b
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b) (HList Identity '[c, d, e, f] -> HList Identity '[b, c, d, e, f])
-> (HList Identity '[] -> HList Identity '[c, d, e, f])
-> HList Identity '[]
-> HList Identity '[b, c, d, e, f]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity c
-> HList Identity '[d, e, f] -> HList Identity '[c, d, e, f]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (c -> Identity c
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure c
c) (HList Identity '[d, e, f] -> HList Identity '[c, d, e, f])
-> (HList Identity '[] -> HList Identity '[d, e, f])
-> HList Identity '[]
-> HList Identity '[c, d, e, f]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity d -> HList Identity '[e, f] -> HList Identity '[d, e, f]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (d -> Identity d
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure d
d) (HList Identity '[e, f] -> HList Identity '[d, e, f])
-> (HList Identity '[] -> HList Identity '[e, f])
-> HList Identity '[]
-> HList Identity '[d, e, f]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity e -> HList Identity '[f] -> HList Identity '[e, f]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (e -> Identity e
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure e
e) (HList Identity '[f] -> HList Identity '[e, f])
-> (HList Identity '[] -> HList Identity '[f])
-> HList Identity '[]
-> HList Identity '[e, f]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity f -> HList Identity '[] -> HList Identity '[f]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons (f -> Identity f
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure f
f) (HList Identity '[]
 -> HList Identity (TupleArgs (a, b, c, d, e, f)))
-> HList Identity '[]
-> HList Identity (TupleArgs (a, b, c, d, e, f))
forall a b. (a -> b) -> a -> b
$ HList Identity '[]
forall {k} (f :: k -> *). HList 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 :: forall (proxy :: * -> *).
proxy (a, b)
-> ToPredTuple m (a, b) -> HList (Predicate m) (TupleArgs (a, b))
toHListPred proxy (a, b)
_ (Predicate m a
a, Predicate m b
b) = Predicate m a
-> HList (Predicate m) '[b] -> HList (Predicate m) '[a, b]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m a
a (HList (Predicate m) '[b]
 -> HList (Predicate m) (TupleArgs (a, b)))
-> (HList (Predicate m) '[] -> HList (Predicate m) '[b])
-> HList (Predicate m) '[]
-> HList (Predicate m) (TupleArgs (a, b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m b
-> HList (Predicate m) '[] -> HList (Predicate m) '[b]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m b
b (HList (Predicate m) '[] -> HList (Predicate m) (TupleArgs (a, b)))
-> HList (Predicate m) '[]
-> HList (Predicate m) (TupleArgs (a, b))
forall a b. (a -> b) -> a -> b
$ HList (Predicate m) '[]
forall {k} (f :: k -> *). HList f '[]
HNil
instance IsPredTuple m (a, b, c) where
  type ToPredTuple m (a, b, c) = (Predicate m a, Predicate m b, Predicate m c)
  toHListPred :: forall (proxy :: * -> *).
proxy (a, b, c)
-> ToPredTuple m (a, b, c)
-> HList (Predicate m) (TupleArgs (a, b, c))
toHListPred proxy (a, b, c)
_ (Predicate m a
a, Predicate m b
b, Predicate m c
c) = Predicate m a
-> HList (Predicate m) '[b, c] -> HList (Predicate m) '[a, b, c]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m a
a (HList (Predicate m) '[b, c]
 -> HList (Predicate m) (TupleArgs (a, b, c)))
-> (HList (Predicate m) '[] -> HList (Predicate m) '[b, c])
-> HList (Predicate m) '[]
-> HList (Predicate m) (TupleArgs (a, b, c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m b
-> HList (Predicate m) '[c] -> HList (Predicate m) '[b, c]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m b
b (HList (Predicate m) '[c] -> HList (Predicate m) '[b, c])
-> (HList (Predicate m) '[] -> HList (Predicate m) '[c])
-> HList (Predicate m) '[]
-> HList (Predicate m) '[b, c]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m c
-> HList (Predicate m) '[] -> HList (Predicate m) '[c]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m c
c (HList (Predicate m) '[]
 -> HList (Predicate m) (TupleArgs (a, b, c)))
-> HList (Predicate m) '[]
-> HList (Predicate m) (TupleArgs (a, b, c))
forall a b. (a -> b) -> a -> b
$ HList (Predicate m) '[]
forall {k} (f :: k -> *). HList f '[]
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 :: forall (proxy :: * -> *).
proxy (a, b, c, d)
-> ToPredTuple m (a, b, c, d)
-> HList (Predicate m) (TupleArgs (a, b, c, d))
toHListPred proxy (a, b, c, d)
_ (Predicate m a
a, Predicate m b
b, Predicate m c
c, Predicate m d
d) = Predicate m a
-> HList (Predicate m) '[b, c, d]
-> HList (Predicate m) '[a, b, c, d]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m a
a (HList (Predicate m) '[b, c, d]
 -> HList (Predicate m) (TupleArgs (a, b, c, d)))
-> (HList (Predicate m) '[] -> HList (Predicate m) '[b, c, d])
-> HList (Predicate m) '[]
-> HList (Predicate m) (TupleArgs (a, b, c, d))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m b
-> HList (Predicate m) '[c, d] -> HList (Predicate m) '[b, c, d]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m b
b (HList (Predicate m) '[c, d] -> HList (Predicate m) '[b, c, d])
-> (HList (Predicate m) '[] -> HList (Predicate m) '[c, d])
-> HList (Predicate m) '[]
-> HList (Predicate m) '[b, c, d]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m c
-> HList (Predicate m) '[d] -> HList (Predicate m) '[c, d]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m c
c (HList (Predicate m) '[d] -> HList (Predicate m) '[c, d])
-> (HList (Predicate m) '[] -> HList (Predicate m) '[d])
-> HList (Predicate m) '[]
-> HList (Predicate m) '[c, d]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m d
-> HList (Predicate m) '[] -> HList (Predicate m) '[d]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m d
d (HList (Predicate m) '[]
 -> HList (Predicate m) (TupleArgs (a, b, c, d)))
-> HList (Predicate m) '[]
-> HList (Predicate m) (TupleArgs (a, b, c, d))
forall a b. (a -> b) -> a -> b
$ HList (Predicate m) '[]
forall {k} (f :: k -> *). HList f '[]
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 :: forall (proxy :: * -> *).
proxy (a, b, c, d, e)
-> ToPredTuple m (a, b, c, d, e)
-> HList (Predicate m) (TupleArgs (a, b, c, d, e))
toHListPred proxy (a, b, c, d, e)
_ (Predicate m a
a, Predicate m b
b, Predicate m c
c, Predicate m d
d, Predicate m e
e) = Predicate m a
-> HList (Predicate m) '[b, c, d, e]
-> HList (Predicate m) '[a, b, c, d, e]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m a
a (HList (Predicate m) '[b, c, d, e]
 -> HList (Predicate m) (TupleArgs (a, b, c, d, e)))
-> (HList (Predicate m) '[] -> HList (Predicate m) '[b, c, d, e])
-> HList (Predicate m) '[]
-> HList (Predicate m) (TupleArgs (a, b, c, d, e))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m b
-> HList (Predicate m) '[c, d, e]
-> HList (Predicate m) '[b, c, d, e]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m b
b (HList (Predicate m) '[c, d, e]
 -> HList (Predicate m) '[b, c, d, e])
-> (HList (Predicate m) '[] -> HList (Predicate m) '[c, d, e])
-> HList (Predicate m) '[]
-> HList (Predicate m) '[b, c, d, e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m c
-> HList (Predicate m) '[d, e] -> HList (Predicate m) '[c, d, e]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m c
c (HList (Predicate m) '[d, e] -> HList (Predicate m) '[c, d, e])
-> (HList (Predicate m) '[] -> HList (Predicate m) '[d, e])
-> HList (Predicate m) '[]
-> HList (Predicate m) '[c, d, e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m d
-> HList (Predicate m) '[e] -> HList (Predicate m) '[d, e]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m d
d (HList (Predicate m) '[e] -> HList (Predicate m) '[d, e])
-> (HList (Predicate m) '[] -> HList (Predicate m) '[e])
-> HList (Predicate m) '[]
-> HList (Predicate m) '[d, e]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m e
-> HList (Predicate m) '[] -> HList (Predicate m) '[e]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m e
e (HList (Predicate m) '[]
 -> HList (Predicate m) (TupleArgs (a, b, c, d, e)))
-> HList (Predicate m) '[]
-> HList (Predicate m) (TupleArgs (a, b, c, d, e))
forall a b. (a -> b) -> a -> b
$ HList (Predicate m) '[]
forall {k} (f :: k -> *). HList f '[]
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 :: forall (proxy :: * -> *).
proxy (a, b, c, d, e, f)
-> ToPredTuple m (a, b, c, d, e, f)
-> HList (Predicate m) (TupleArgs (a, b, c, d, e, f))
toHListPred proxy (a, b, c, d, e, f)
_ (Predicate m a
a, Predicate m b
b, Predicate m c
c, Predicate m d
d, Predicate m e
e, Predicate m f
f) = Predicate m a
-> HList (Predicate m) '[b, c, d, e, f]
-> HList (Predicate m) '[a, b, c, d, e, f]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m a
a (HList (Predicate m) '[b, c, d, e, f]
 -> HList (Predicate m) (TupleArgs (a, b, c, d, e, f)))
-> (HList (Predicate m) '[]
    -> HList (Predicate m) '[b, c, d, e, f])
-> HList (Predicate m) '[]
-> HList (Predicate m) (TupleArgs (a, b, c, d, e, f))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m b
-> HList (Predicate m) '[c, d, e, f]
-> HList (Predicate m) '[b, c, d, e, f]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m b
b (HList (Predicate m) '[c, d, e, f]
 -> HList (Predicate m) '[b, c, d, e, f])
-> (HList (Predicate m) '[] -> HList (Predicate m) '[c, d, e, f])
-> HList (Predicate m) '[]
-> HList (Predicate m) '[b, c, d, e, f]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m c
-> HList (Predicate m) '[d, e, f]
-> HList (Predicate m) '[c, d, e, f]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m c
c (HList (Predicate m) '[d, e, f]
 -> HList (Predicate m) '[c, d, e, f])
-> (HList (Predicate m) '[] -> HList (Predicate m) '[d, e, f])
-> HList (Predicate m) '[]
-> HList (Predicate m) '[c, d, e, f]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m d
-> HList (Predicate m) '[e, f] -> HList (Predicate m) '[d, e, f]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m d
d (HList (Predicate m) '[e, f] -> HList (Predicate m) '[d, e, f])
-> (HList (Predicate m) '[] -> HList (Predicate m) '[e, f])
-> HList (Predicate m) '[]
-> HList (Predicate m) '[d, e, f]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m e
-> HList (Predicate m) '[f] -> HList (Predicate m) '[e, f]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m e
e (HList (Predicate m) '[f] -> HList (Predicate m) '[e, f])
-> (HList (Predicate m) '[] -> HList (Predicate m) '[f])
-> HList (Predicate m) '[]
-> HList (Predicate m) '[e, f]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m f
-> HList (Predicate m) '[] -> HList (Predicate m) '[f]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> HList f xs1 -> HList f (x : xs1)
HCons Predicate m f
f (HList (Predicate m) '[]
 -> HList (Predicate m) (TupleArgs (a, b, c, d, e, f)))
-> HList (Predicate m) '[]
-> HList (Predicate m) (TupleArgs (a, b, c, d, e, f))
forall a b. (a -> b) -> a -> b
$ HList (Predicate m) '[]
forall {k} (f :: k -> *). HList 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 :: forall a (m :: * -> *).
(IsPredTuple m a, Monad m) =>
ToPredTuple m a -> Predicate m a
tup ToPredTuple m a
predTup =
  Predicate
    { predicateFunc :: a -> m PredicateFuncResult
predicateFunc = \a
actual ->
        ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult
verifyAll [Text] -> Text
tupify ([PredicateFuncResult] -> PredicateFuncResult)
-> m [PredicateFuncResult] -> m PredicateFuncResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HList (Predicate m) (TupleArgs a)
-> HList Identity (TupleArgs a) -> m [PredicateFuncResult]
forall (m :: * -> *) (xs :: [*]).
Monad m =>
HList (Predicate m) xs
-> HList Identity xs -> m [PredicateFuncResult]
runPredicates HList (Predicate m) (TupleArgs a)
preds (a -> HList Identity (TupleArgs a)
forall a. IsTuple a => a -> HList Identity (TupleArgs a)
toHList a
actual)
    , predicateDisp :: Text
predicateDisp = Text
disp
    , predicateDispNeg :: Text
predicateDispNeg = Text
dispNeg
    }
  where
    preds :: HList (Predicate m) (TupleArgs a)
preds = Proxy a -> ToPredTuple m a -> HList (Predicate m) (TupleArgs a)
forall (proxy :: * -> *).
proxy a -> ToPredTuple m a -> HList (Predicate m) (TupleArgs a)
forall (m :: * -> *) a (proxy :: * -> *).
IsPredTuple m a =>
proxy a -> ToPredTuple m a -> HList (Predicate m) (TupleArgs a)
toHListPred (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a) ToPredTuple m a
predTup
    tupify :: [Text] -> Text
tupify [Text]
vals = Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
vals Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    disp :: Text
disp = [Text] -> Text
tupify ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (forall x. Predicate m x -> Text)
-> HList (Predicate m) (TupleArgs a) -> [Text]
forall {k} (f :: k -> *) y (xs :: [k]).
(forall (x :: k). f x -> y) -> HList f xs -> [y]
HList.toListWith Predicate m x -> Text
forall x. Predicate m x -> Text
forall (m :: * -> *) a. Predicate m a -> Text
predicateDisp HList (Predicate m) (TupleArgs a)
preds
    dispNeg :: Text
dispNeg = Text
"not " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
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.
con :: a -> Predicate m a
con :: forall a (m :: * -> *). a -> Predicate m a
con =
  -- A placeholder that will be replaced with conMatches in the plugin.
  String -> a -> Predicate m a
forall a. String -> a
invariantViolation String
"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 :: forall (m :: * -> *) (fields :: [*]) a.
Monad m =>
String
-> Maybe (HList (Const String) fields)
-> (a -> Maybe (HList Identity fields))
-> HList (Predicate m) fields
-> Predicate m a
conMatches String
conNameS Maybe (HList (Const String) fields)
mFieldNames a -> Maybe (HList Identity fields)
deconstruct HList (Predicate m) fields
preds =
  Predicate
    { predicateFunc :: a -> m PredicateFuncResult
predicateFunc = \a
actual ->
        case a -> Maybe (HList Identity fields)
deconstruct a
actual of
          Just HList Identity fields
fields -> ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult
verifyAll [Text] -> Text
consify ([PredicateFuncResult] -> PredicateFuncResult)
-> m [PredicateFuncResult] -> m PredicateFuncResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HList (Predicate m) fields
-> HList Identity fields -> m [PredicateFuncResult]
forall (m :: * -> *) (xs :: [*]).
Monad m =>
HList (Predicate m) xs
-> HList Identity xs -> m [PredicateFuncResult]
runPredicates HList (Predicate m) fields
preds HList Identity fields
fields
          Maybe (HList Identity fields)
Nothing ->
            PredicateFuncResult -> m PredicateFuncResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              PredicateFuncResult
                { predicateSuccess :: Bool
predicateSuccess = Bool
False
                , predicateExplain :: Text
predicateExplain = a -> Text
forall a. a -> Text
render a
actual Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dispNeg
                , predicateShowFailCtx :: ShowFailCtx
predicateShowFailCtx = ShowFailCtx
noCtx
                }
    , predicateDisp :: Text
predicateDisp = Text
disp
    , predicateDispNeg :: Text
predicateDispNeg = Text
dispNeg
    }
  where
    conName :: Text
conName = String -> Text
Text.pack String
conNameS
    disp :: Text
disp = Text
"matches " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
predsDisp
    dispNeg :: Text
dispNeg = Text
"does not match " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
predsDisp
    predsDisp :: Text
predsDisp = [Text] -> Text
consify ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (forall x. Predicate m x -> Text)
-> HList (Predicate m) fields -> [Text]
forall {k} (f :: k -> *) y (xs :: [k]).
(forall (x :: k). f x -> y) -> HList f xs -> [y]
HList.toListWith Predicate m x -> Text
forall x. Predicate m x -> Text
forall (m :: * -> *) a. Predicate m a -> Text
predicateDisp HList (Predicate m) fields
preds

    -- consify ["= 1", "anything"] => User{id = (= 1), name = anything}
    -- consify ["= 1", "anything"] => Foo (= 1) anything
    consify :: [Text] -> Text
consify [Text]
vals =
      case HList (Const String) fields -> [String]
forall {k} a (xs :: [k]). HList (Const a) xs -> [a]
HList.uncheck (HList (Const String) fields -> [String])
-> Maybe (HList (Const String) fields) -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (HList (Const String) fields)
mFieldNames of
        Maybe [String]
Nothing -> [Text] -> Text
Text.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text
conName Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
parens [Text]
vals
        Just [String]
fieldNames ->
          let fields :: [Text]
fields = (String -> Text -> Text) -> [String] -> [Text] -> [Text]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
field Text
v -> String -> Text
Text.pack String
field Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
parens Text
v) [String]
fieldNames [Text]
vals
           in Text
conName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"{" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
", " [Text]
fields Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"}"

{----- 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 :: forall a (m :: * -> *).
(Fractional a, Ord a, Monad m) =>
Tolerance -> a -> Predicate m a
approx Tolerance{Maybe Rational
Rational
rel :: Maybe Rational
abs :: Rational
abs :: Tolerance -> Rational
rel :: Tolerance -> Maybe Rational
..} =
  Text -> Text -> (a -> a -> Bool) -> a -> Predicate m a
forall (m :: * -> *) a.
Monad m =>
Text -> Text -> (a -> a -> Bool) -> a -> Predicate m a
mkPredicateOp Text
"≈" Text
"≉" ((a -> a -> Bool) -> a -> Predicate m a)
-> (a -> a -> Bool) -> a -> Predicate m a
forall a b. (a -> b) -> a -> b
$ \a
actual a
expected ->
    a -> a
forall a. Num a => a -> a
Prelude.abs (a
actual a -> a -> a
forall a. Num a => a -> a -> a
- a
expected) a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a -> a
getTolerance a
expected
  where
    mRelTol :: Maybe a
mRelTol = Rational -> a
forall {a}. Fractional a => Rational -> a
fromTol (Rational -> a) -> Maybe Rational -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Rational
rel
    absTol :: a
absTol = Rational -> a
forall {a}. Fractional a => Rational -> a
fromTol Rational
abs
    getTolerance :: a -> a
getTolerance a
expected =
      case Maybe a
mRelTol of
        Just a
relTol -> a -> a -> a
forall a. Ord a => a -> a -> a
max (a
relTol a -> a -> a
forall a. Num a => a -> a -> a
* a -> a
forall a. Num a => a -> a
Prelude.abs a
expected) a
absTol
        Maybe a
Nothing -> a
absTol

    fromTol :: Rational -> a
fromTol Rational
x
      | Rational
x Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0 = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"tolerance can't be negative: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Rational -> String
forall a. Show a => a -> String
show Rational
x
      | Bool
otherwise = Rational -> a
forall {a}. Fractional a => Rational -> a
fromRational Rational
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
  { Tolerance -> Maybe Rational
rel :: Maybe Rational
  -- ^ If provided, the relative tolerance. Defaults to 1e-6.
  , Tolerance -> Rational
abs :: Rational
  -- ^ The absolute tolerance. Defaults to 1e-12.
  }

-- | The default tolerance for 'approx'.
tol :: Tolerance
tol :: Tolerance
tol = Tolerance{rel :: Maybe Rational
rel = Rational -> Maybe Rational
forall a. a -> Maybe a
Just Rational
1e-6, abs :: Rational
abs = Rational
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{Text
a -> m PredicateFuncResult
predicateFunc :: forall (m :: * -> *) a. Predicate m a -> a -> m PredicateFuncResult
predicateDisp :: forall (m :: * -> *) a. Predicate m a -> Text
predicateDispNeg :: forall (m :: * -> *) a. Predicate m a -> Text
predicateFunc :: a -> m PredicateFuncResult
predicateDisp :: Text
predicateDispNeg :: Text
..} <<< :: forall (m :: * -> *) a b.
Monad m =>
Predicate m a -> (b -> a) -> Predicate m b
<<< b -> a
f =
  Predicate
    { predicateFunc :: b -> m PredicateFuncResult
predicateFunc = (PredicateFuncResult -> PredicateFuncResult)
-> m PredicateFuncResult -> m PredicateFuncResult
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PredicateFuncResult -> PredicateFuncResult
showCtx (m PredicateFuncResult -> m PredicateFuncResult)
-> (b -> m PredicateFuncResult) -> b -> m PredicateFuncResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m PredicateFuncResult
predicateFunc (a -> m PredicateFuncResult)
-> (b -> a) -> b -> m PredicateFuncResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
f
    , Text
predicateDisp :: Text
predicateDisp :: Text
predicateDisp
    , Text
predicateDispNeg :: Text
predicateDispNeg :: Text
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
>>> :: forall (m :: * -> *) b a.
Monad m =>
(b -> a) -> Predicate m a -> Predicate m b
(>>>) = (Predicate m a -> (b -> a) -> Predicate m b)
-> (b -> a) -> Predicate m a -> Predicate m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip Predicate m a -> (b -> a) -> Predicate m b
forall (m :: * -> *) a b.
Monad m =>
Predicate m a -> (b -> a) -> Predicate m b
(<<<)

-- | 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 :: forall (m :: * -> *) a. Monad m => Predicate m a -> Predicate m a
not Predicate{Text
a -> m PredicateFuncResult
predicateFunc :: forall (m :: * -> *) a. Predicate m a -> a -> m PredicateFuncResult
predicateDisp :: forall (m :: * -> *) a. Predicate m a -> Text
predicateDispNeg :: forall (m :: * -> *) a. Predicate m a -> Text
predicateFunc :: a -> m PredicateFuncResult
predicateDisp :: Text
predicateDispNeg :: Text
..} =
  Predicate
    { predicateFunc :: a -> m PredicateFuncResult
predicateFunc = \a
actual -> do
        result <- PredicateFuncResult -> PredicateFuncResult
showCtx (PredicateFuncResult -> PredicateFuncResult)
-> m PredicateFuncResult -> m PredicateFuncResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> m PredicateFuncResult
predicateFunc a
actual
        pure result{predicateSuccess = Prelude.not $ predicateSuccess result}
    , predicateDisp :: Text
predicateDisp = Text
predicateDispNeg
    , predicateDispNeg :: Text
predicateDispNeg = Text
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
Predicate m a
p1 && :: forall (m :: * -> *) a.
Monad m =>
Predicate m a -> Predicate m a -> Predicate m a
&& Predicate m a
p2 = [Predicate m a] -> Predicate m a
forall (m :: * -> *) a. Monad m => [Predicate m a] -> Predicate m a
and [Predicate m a
p1, Predicate m a
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
Predicate m a
p1 || :: forall (m :: * -> *) a.
Monad m =>
Predicate m a -> Predicate m a -> Predicate m a
|| Predicate m a
p2 = [Predicate m a] -> Predicate m a
forall (m :: * -> *) a. Monad m => [Predicate m a] -> Predicate m a
or [Predicate m a
p1, Predicate m a
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 :: forall (m :: * -> *) a. Monad m => [Predicate m a] -> Predicate m a
and [Predicate m a]
preds =
  Predicate
    { predicateFunc :: a -> m PredicateFuncResult
predicateFunc = \a
actual ->
        ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult
verifyAll (Text -> [Text] -> Text
forall a b. a -> b -> a
const Text
"All predicates passed") ([PredicateFuncResult] -> PredicateFuncResult)
-> m [PredicateFuncResult] -> m PredicateFuncResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Predicate m a -> m PredicateFuncResult)
-> [Predicate m a] -> m [PredicateFuncResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Predicate m a
p -> Predicate m a -> a -> m PredicateFuncResult
forall (m :: * -> *) a. Predicate m a -> a -> m PredicateFuncResult
predicateFunc Predicate m a
p a
actual) [Predicate m a]
preds
    , predicateDisp :: Text
predicateDisp = [Text] -> Text
andify [Text]
predList
    , predicateDispNeg :: Text
predicateDispNeg = Text
"At least one failure:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
andify [Text]
predList
    }
  where
    andify :: [Text] -> Text
andify = Text -> [Text] -> Text
Text.intercalate Text
"\nand "
    predList :: [Text]
predList = (Predicate m a -> Text) -> [Predicate m a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
parens (Text -> Text) -> (Predicate m a -> Text) -> Predicate m a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m a -> Text
forall (m :: * -> *) a. Predicate m a -> Text
predicateDisp) [Predicate m a]
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 :: forall (m :: * -> *) a. Monad m => [Predicate m a] -> Predicate m a
or [Predicate m a]
preds =
  Predicate
    { predicateFunc :: a -> m PredicateFuncResult
predicateFunc = \a
actual ->
        ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult
verifyAny (Text -> [Text] -> Text
forall a b. a -> b -> a
const Text
"No predicates passed") ([PredicateFuncResult] -> PredicateFuncResult)
-> m [PredicateFuncResult] -> m PredicateFuncResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Predicate m a -> m PredicateFuncResult)
-> [Predicate m a] -> m [PredicateFuncResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Predicate m a
p -> Predicate m a -> a -> m PredicateFuncResult
forall (m :: * -> *) a. Predicate m a -> a -> m PredicateFuncResult
predicateFunc Predicate m a
p a
actual) [Predicate m a]
preds
    , predicateDisp :: Text
predicateDisp = [Text] -> Text
orify [Text]
predList
    , predicateDispNeg :: Text
predicateDispNeg = Text
"All failures:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
orify [Text]
predList
    }
  where
    orify :: [Text] -> Text
orify = Text -> [Text] -> Text
Text.intercalate Text
"\nor "
    predList :: [Text]
predList = (Predicate m a -> Text) -> [Predicate m a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
parens (Text -> Text) -> (Predicate m a -> Text) -> Predicate m a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Predicate m a -> Text
forall (m :: * -> *) a. Predicate m a -> Text
predicateDisp) [Predicate m a]
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 :: forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
Predicate m a -> Predicate m (t a)
any Predicate{Text
a -> m PredicateFuncResult
predicateFunc :: forall (m :: * -> *) a. Predicate m a -> a -> m PredicateFuncResult
predicateDisp :: forall (m :: * -> *) a. Predicate m a -> Text
predicateDispNeg :: forall (m :: * -> *) a. Predicate m a -> Text
predicateFunc :: a -> m PredicateFuncResult
predicateDisp :: Text
predicateDispNeg :: Text
..} =
  Predicate
    { predicateFunc :: t a -> m PredicateFuncResult
predicateFunc = \t a
actual ->
        ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult
verifyAny (Text -> [Text] -> Text
forall a b. a -> b -> a
const Text
"No values matched") ([PredicateFuncResult] -> PredicateFuncResult)
-> m [PredicateFuncResult] -> m PredicateFuncResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> m PredicateFuncResult) -> [a] -> m [PredicateFuncResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> m PredicateFuncResult
predicateFunc (t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t a
actual)
    , predicateDisp :: Text
predicateDisp = Text
"at least one element matching " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
parens Text
predicateDisp
    , predicateDispNeg :: Text
predicateDispNeg = Text
"no elements matching " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
parens Text
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 :: forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
Predicate m a -> Predicate m (t a)
all Predicate{Text
a -> m PredicateFuncResult
predicateFunc :: forall (m :: * -> *) a. Predicate m a -> a -> m PredicateFuncResult
predicateDisp :: forall (m :: * -> *) a. Predicate m a -> Text
predicateDispNeg :: forall (m :: * -> *) a. Predicate m a -> Text
predicateFunc :: a -> m PredicateFuncResult
predicateDisp :: Text
predicateDispNeg :: Text
..} =
  Predicate
    { predicateFunc :: t a -> m PredicateFuncResult
predicateFunc = \t a
actual ->
        ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult
verifyAll (Text -> [Text] -> Text
forall a b. a -> b -> a
const Text
"All values matched") ([PredicateFuncResult] -> PredicateFuncResult)
-> m [PredicateFuncResult] -> m PredicateFuncResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> m PredicateFuncResult) -> [a] -> m [PredicateFuncResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> m PredicateFuncResult
predicateFunc (t a -> [a]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList t a
actual)
    , predicateDisp :: Text
predicateDisp = Text
"all elements matching " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
parens Text
predicateDisp
    , predicateDispNeg :: Text
predicateDispNeg = Text
"some elements not matching " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
parens Text
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 :: forall a (t :: * -> *) (m :: * -> *).
(Eq a, Foldable t, Monad m) =>
a -> Predicate m (t a)
elem = Predicate m a -> Predicate m (t a)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
Predicate m a -> Predicate m (t a)
any (Predicate m a -> Predicate m (t a))
-> (a -> Predicate m a) -> a -> Predicate m (t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Predicate m a
forall a (m :: * -> *). (Eq a, Monad m) => a -> Predicate m a
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 :: [a] -> [a] -> Bool
isPrefixOf = [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isPrefixOf
  isInfixOf :: [a] -> [a] -> Bool
isInfixOf = [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isInfixOf
  isSuffixOf :: [a] -> [a] -> Bool
isSuffixOf = [a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
List.isSuffixOf
instance HasSubsequences Text where
  isPrefixOf :: Text -> Text -> Bool
isPrefixOf = Text -> Text -> Bool
Text.isPrefixOf
  isInfixOf :: Text -> Text -> Bool
isInfixOf = Text -> Text -> Bool
Text.isInfixOf
  isSuffixOf :: Text -> Text -> Bool
isSuffixOf = Text -> Text -> Bool
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 :: forall a (m :: * -> *).
(HasSubsequences a, Monad m) =>
a -> Predicate m a
hasPrefix a
prefix =
  Predicate
    { predicateFunc :: a -> m PredicateFuncResult
predicateFunc = \a
val -> do
        let success :: Bool
success = a
prefix a -> a -> Bool
forall a. HasSubsequences a => a -> a -> Bool
`isPrefixOf` a
val
        PredicateFuncResult -> m PredicateFuncResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          PredicateFuncResult
            { predicateSuccess :: Bool
predicateSuccess = Bool
success
            , predicateExplain :: Text
predicateExplain =
                if Bool
success
                  then a -> Text
forall a. a -> Text
render a
val Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
disp
                  else a -> Text
forall a. a -> Text
render a
val Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dispNeg
            , predicateShowFailCtx :: ShowFailCtx
predicateShowFailCtx = ShowFailCtx
noCtx
            }
    , predicateDisp :: Text
predicateDisp = Text
disp
    , predicateDispNeg :: Text
predicateDispNeg = Text
dispNeg
    }
  where
    disp :: Text
disp = Text
"has prefix " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. a -> Text
render a
prefix
    dispNeg :: Text
dispNeg = Text
"does not have prefix " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. a -> Text
render a
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 :: forall a (m :: * -> *).
(HasSubsequences a, Monad m) =>
a -> Predicate m a
hasInfix a
elems =
  Predicate
    { predicateFunc :: a -> m PredicateFuncResult
predicateFunc = \a
val -> do
        let success :: Bool
success = a
elems a -> a -> Bool
forall a. HasSubsequences a => a -> a -> Bool
`isInfixOf` a
val
        PredicateFuncResult -> m PredicateFuncResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          PredicateFuncResult
            { predicateSuccess :: Bool
predicateSuccess = Bool
success
            , predicateExplain :: Text
predicateExplain =
                if Bool
success
                  then a -> Text
forall a. a -> Text
render a
val Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
disp
                  else a -> Text
forall a. a -> Text
render a
val Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dispNeg
            , predicateShowFailCtx :: ShowFailCtx
predicateShowFailCtx = ShowFailCtx
noCtx
            }
    , predicateDisp :: Text
predicateDisp = Text
disp
    , predicateDispNeg :: Text
predicateDispNeg = Text
dispNeg
    }
  where
    disp :: Text
disp = Text
"has infix " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. a -> Text
render a
elems
    dispNeg :: Text
dispNeg = Text
"does not have infix " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. a -> Text
render a
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 :: forall a (m :: * -> *).
(HasSubsequences a, Monad m) =>
a -> Predicate m a
hasSuffix a
suffix =
  Predicate
    { predicateFunc :: a -> m PredicateFuncResult
predicateFunc = \a
val -> do
        let success :: Bool
success = a
suffix a -> a -> Bool
forall a. HasSubsequences a => a -> a -> Bool
`isSuffixOf` a
val
        PredicateFuncResult -> m PredicateFuncResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          PredicateFuncResult
            { predicateSuccess :: Bool
predicateSuccess = Bool
success
            , predicateExplain :: Text
predicateExplain =
                if Bool
success
                  then a -> Text
forall a. a -> Text
render a
val Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
disp
                  else a -> Text
forall a. a -> Text
render a
val Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dispNeg
            , predicateShowFailCtx :: ShowFailCtx
predicateShowFailCtx = ShowFailCtx
noCtx
            }
    , predicateDisp :: Text
predicateDisp = Text
disp
    , predicateDispNeg :: Text
predicateDispNeg = Text
dispNeg
    }
  where
    disp :: Text
disp = Text
"has suffix " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. a -> Text
render a
suffix
    dispNeg :: Text
dispNeg = Text
"does not have suffix " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. a -> Text
render a
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 :: forall (m :: * -> *) a.
MonadIO m =>
Predicate m a -> Predicate m (m a)
returns Predicate{Text
a -> m PredicateFuncResult
predicateFunc :: forall (m :: * -> *) a. Predicate m a -> a -> m PredicateFuncResult
predicateDisp :: forall (m :: * -> *) a. Predicate m a -> Text
predicateDispNeg :: forall (m :: * -> *) a. Predicate m a -> Text
predicateFunc :: a -> m PredicateFuncResult
predicateDisp :: Text
predicateDispNeg :: Text
..} =
  Predicate
    { predicateFunc :: m a -> m PredicateFuncResult
predicateFunc = \m a
io -> do
        x <- m a
io
        PredicateFuncResult{..} <- predicateFunc x
        pure
          PredicateFuncResult
            { predicateSuccess = predicateSuccess
            , predicateExplain =
                if predicateSuccess
                  then predicateExplain
                  else
                    let failCtx =
                          FailCtx
                            { failCtxExpected :: Text
failCtxExpected = Text
predicateDisp
                            , failCtxActual :: Text
failCtxActual = a -> Text
forall a. a -> Text
render a
x
                            }
                     in withFailCtx failCtx predicateShowFailCtx predicateExplain
            , predicateShowFailCtx = HideFailCtx
            }
    , predicateDisp :: Text
predicateDisp = Text
predicateDisp
    , predicateDispNeg :: Text
predicateDispNeg = Text
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 :: forall e (m :: * -> *) a.
(Exception e, MonadUnliftIO m) =>
Predicate m e -> Predicate m (m a)
throws Predicate{Text
e -> m PredicateFuncResult
predicateFunc :: forall (m :: * -> *) a. Predicate m a -> a -> m PredicateFuncResult
predicateDisp :: forall (m :: * -> *) a. Predicate m a -> Text
predicateDispNeg :: forall (m :: * -> *) a. Predicate m a -> Text
predicateFunc :: e -> m PredicateFuncResult
predicateDisp :: Text
predicateDispNeg :: Text
..} =
  Predicate
    { predicateFunc :: m a -> m PredicateFuncResult
predicateFunc = \m a
io ->
        m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try m a
io m (Either e a)
-> (Either e a -> m PredicateFuncResult) -> m PredicateFuncResult
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left e
e -> do
            PredicateFuncResult{..} <- e -> m PredicateFuncResult
predicateFunc e
e
            pure
              PredicateFuncResult
                { predicateSuccess = predicateSuccess
                , predicateExplain =
                    if predicateSuccess
                      then predicateExplain
                      else
                        let failCtx =
                              FailCtx
                                { failCtxExpected :: Text
failCtxExpected = Text
disp
                                , failCtxActual :: Text
failCtxActual = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ e -> String
forall e. Exception e => e -> String
displayException e
e
                                }
                         in withFailCtx failCtx predicateShowFailCtx predicateExplain
                , predicateShowFailCtx = HideFailCtx
                }
          Right a
x ->
            PredicateFuncResult -> m PredicateFuncResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              PredicateFuncResult
                { predicateSuccess :: Bool
predicateSuccess = Bool
False
                , predicateExplain :: Text
predicateExplain =
                    FailCtx -> Text
renderFailCtx
                      FailCtx
                        { failCtxExpected :: Text
failCtxExpected = Text
disp
                        , failCtxActual :: Text
failCtxActual = a -> Text
forall a. a -> Text
render a
x
                        }
                , predicateShowFailCtx :: ShowFailCtx
predicateShowFailCtx = ShowFailCtx
HideFailCtx
                }
    , predicateDisp :: Text
predicateDisp = Text
disp
    , predicateDispNeg :: Text
predicateDispNeg = Text
dispNeg
    }
  where
    disp :: Text
disp = Text
"throws (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
predicateDisp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    dispNeg :: Text
dispNeg = Text
"does not throw (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
predicateDisp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"

{----- 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 (Gen.linear 0 10) $ Gen.int (Gen.linear 0 1000)
--   (reverse . reverse) P.=== id \`shouldSatisfy\` P.isoWith genList
-- @
(===) :: (a -> b) -> (a -> b) -> IsoChecker a b
a -> b
f === :: forall a b. (a -> b) -> (a -> b) -> IsoChecker a b
=== a -> b
g = Fun a b -> Fun a b -> IsoChecker a b
forall a b. Fun a b -> Fun a b -> IsoChecker a b
IsoChecker (String -> (a -> b) -> Fun a b
forall a b. String -> (a -> b) -> Fun a b
Fun String
"lhs" a -> b
f) (String -> (a -> b) -> Fun a b
forall a b. String -> (a -> b) -> Fun a b
Fun String
"rhs" a -> b
g)

infix 2 ===

-- | See '(===)'.
isoWith :: (GHC.HasCallStack, Show a, Eq b) => Gen a -> Predicate PropertyM (IsoChecker a b)
isoWith :: forall a b.
(HasCallStack, Show a, Eq b) =>
Gen a -> Predicate PropertyM (IsoChecker a b)
isoWith Gen a
gen =
  Predicate
    { predicateFunc :: IsoChecker a b -> PropertyM PredicateFuncResult
predicateFunc = \(IsoChecker (Fun String
f1DispS a -> b
f1) (Fun String
f2DispS a -> b
f2)) -> do
        a <- (HasCallStack => PropertyM a) -> PropertyM a
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => PropertyM a) -> PropertyM a)
-> (HasCallStack => PropertyM a) -> PropertyM a
forall a b. (a -> b) -> a -> b
$ Gen a -> PropertyM a
forall a. (HasCallStack, Show a) => Gen a -> PropertyM a
forAll Gen a
gen
        let
          f1Disp = String -> Text
Text.pack String
f1DispS
          f2Disp = String -> Text
Text.pack String
f2DispS
          b1 = a -> b
f1 a
a
          b2 = a -> b
f2 a
a
          aDisp = Text -> Text
parens (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. a -> Text
render a
a
          b1Disp = Text -> Text
parens (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ b -> Text
forall a. a -> Text
render b
b1
          b2Disp = Text -> Text
parens (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ b -> Text
forall a. a -> Text
render b
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 :: Text
predicateDisp = Text
disp
    , predicateDispNeg :: Text
predicateDispNeg = Text
dispNeg
    }
  where
    disp :: Text
disp = Text
"isomorphic"
    dispNeg :: Text
dispNeg = Text
"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 :: forall a (m :: * -> *). (Typeable a, MonadIO m) => Predicate m a
matchesSnapshot =
  Predicate
    { predicateFunc :: a -> m PredicateFuncResult
predicateFunc = \a
actual -> do
        SnapshotUpdateFlag doUpdate <- m SnapshotUpdateFlag
forall a (m :: * -> *). (MonadIO m, IsFlag a) => m a
getFlag
        testInfo <- getTestInfo
        snapshotIndex <- getAndIncSnapshotIndex
        renderers <- getSnapshotRenderers
        let ctx =
              SnapshotContext
                { snapshotRenderers :: [SnapshotRenderer]
snapshotRenderers = [SnapshotRenderer]
renderers
                , snapshotTestInfo :: TestInfo
snapshotTestInfo = TestInfo
testInfo
                , Int
snapshotIndex :: Int
snapshotIndex :: Int
snapshotIndex
                }

        result <-
          if doUpdate
            then updateSnapshot ctx actual >> pure SnapshotMatches
            else checkSnapshot ctx actual

        pure
          PredicateFuncResult
            { predicateSuccess = result == SnapshotMatches
            , predicateExplain =
                case result of
                  SnapshotResult
SnapshotMissing -> Text
"Snapshot does not exist. Update snapshot with --update."
                  SnapshotResult
SnapshotMatches -> Text
"Matches snapshot"
                  SnapshotDiff Text
snapshot Text
renderedActual ->
                    Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
                      [ Text
"Result differed from snapshot. Update snapshot with --update."
                      , (Text, Text) -> (Text, Text) -> Text
showLineDiff (Text
"expected", Text
snapshot) (Text
"actual", Text
renderedActual)
                      ]
            , predicateShowFailCtx = HideFailCtx
            }
    , predicateDisp :: Text
predicateDisp = Text
"matches snapshot"
    , predicateDispNeg :: Text
predicateDispNeg = Text
"does not match snapshot"
    }

{----- Utilities -----}

mkPredicateOp ::
  (Monad m) =>
  Text
  -- ^ operator
  -> Text
  -- ^ negative operator
  -> (a -> a -> Bool)
  -- ^ actual -> expected -> success
  -> a
  -- ^ expected
  -> Predicate m a
mkPredicateOp :: forall (m :: * -> *) a.
Monad m =>
Text -> Text -> (a -> a -> Bool) -> a -> Predicate m a
mkPredicateOp Text
op Text
negOp a -> a -> Bool
f a
expected =
  Predicate
    { predicateFunc :: a -> m PredicateFuncResult
predicateFunc = \a
actual -> do
        let success :: Bool
success = a -> a -> Bool
f a
actual a
expected
        PredicateFuncResult -> m PredicateFuncResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          PredicateFuncResult
            { predicateSuccess :: Bool
predicateSuccess = Bool
success
            , predicateExplain :: Text
predicateExplain =
                if Bool
success
                  then a -> Text
forall a. a -> Text
render a
actual Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
disp
                  else a -> Text
forall a. a -> Text
render a
actual Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dispNeg
            , predicateShowFailCtx :: ShowFailCtx
predicateShowFailCtx = ShowFailCtx
noCtx
            }
    , predicateDisp :: Text
predicateDisp = Text
disp
    , predicateDispNeg :: Text
predicateDispNeg = Text
dispNeg
    }
  where
    disp :: Text
disp = Text
op Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. a -> Text
render a
expected
    dispNeg :: Text
dispNeg = Text
negOp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall a. a -> Text
render a
expected

runPredicates :: (Monad m) => HList (Predicate m) xs -> HList Identity xs -> m [PredicateFuncResult]
runPredicates :: forall (m :: * -> *) (xs :: [*]).
Monad m =>
HList (Predicate m) xs
-> HList Identity xs -> m [PredicateFuncResult]
runPredicates HList (Predicate m) xs
preds = (forall x. (:*:) (Predicate m) Identity x -> m PredicateFuncResult)
-> HList (Predicate m :*: Identity) xs -> m [PredicateFuncResult]
forall {k} (m :: * -> *) (f :: k -> *) y (xs :: [k]).
Monad m =>
(forall (x :: k). f x -> m y) -> HList f xs -> m [y]
HList.toListWithM (:*:) (Predicate m) Identity x -> m PredicateFuncResult
forall x. (:*:) (Predicate m) Identity x -> m PredicateFuncResult
forall (m :: * -> *) a.
(:*:) (Predicate m) Identity a -> m PredicateFuncResult
run (HList (Predicate m :*: Identity) xs -> m [PredicateFuncResult])
-> (HList Identity xs -> HList (Predicate m :*: Identity) xs)
-> HList Identity xs
-> m [PredicateFuncResult]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HList (Predicate m) xs
-> HList Identity xs -> HList (Predicate m :*: Identity) xs
forall {k} (f :: k -> *) (xs :: [k]) (g :: k -> *).
HList f xs -> HList g xs -> HList (f :*: g) xs
HList.hzip HList (Predicate m) xs
preds
  where
    run :: (Predicate m :*: Identity) a -> m PredicateFuncResult
    run :: forall (m :: * -> *) a.
(:*:) (Predicate m) Identity a -> m PredicateFuncResult
run (Predicate m a
p :*: Identity a
x) = Predicate m a -> a -> m PredicateFuncResult
forall (m :: * -> *) a. Predicate m a -> a -> m PredicateFuncResult
predicateFunc Predicate m a
p a
x

verifyAll :: ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult
verifyAll :: ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult
verifyAll [Text] -> Text
mergeMessages [PredicateFuncResult]
results =
  PredicateFuncResult
    { predicateSuccess :: Bool
predicateSuccess = Maybe PredicateFuncResult -> Bool
forall a. Maybe a -> Bool
isNothing Maybe PredicateFuncResult
firstFailure
    , predicateExplain :: Text
predicateExplain =
        case Maybe PredicateFuncResult
firstFailure of
          Just PredicateFuncResult
p -> PredicateFuncResult -> Text
predicateExplain PredicateFuncResult
p
          Maybe PredicateFuncResult
Nothing -> [Text] -> Text
mergeMessages ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (PredicateFuncResult -> Text) -> [PredicateFuncResult] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map PredicateFuncResult -> Text
predicateExplain [PredicateFuncResult]
results
    , predicateShowFailCtx :: ShowFailCtx
predicateShowFailCtx = [PredicateFuncResult] -> ShowFailCtx
showMergedCtxs [PredicateFuncResult]
results
    }
  where
    firstFailure :: Maybe PredicateFuncResult
firstFailure = [PredicateFuncResult] -> Maybe PredicateFuncResult
forall a. [a] -> Maybe a
listToMaybe ([PredicateFuncResult] -> Maybe PredicateFuncResult)
-> [PredicateFuncResult] -> Maybe PredicateFuncResult
forall a b. (a -> b) -> a -> b
$ (PredicateFuncResult -> Bool)
-> [PredicateFuncResult] -> [PredicateFuncResult]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
Prelude.not (Bool -> Bool)
-> (PredicateFuncResult -> Bool) -> PredicateFuncResult -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PredicateFuncResult -> Bool
predicateSuccess) [PredicateFuncResult]
results

verifyAny :: ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult
verifyAny :: ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult
verifyAny [Text] -> Text
mergeMessages [PredicateFuncResult]
results =
  PredicateFuncResult
    { predicateSuccess :: Bool
predicateSuccess = Maybe PredicateFuncResult -> Bool
forall a. Maybe a -> Bool
isJust Maybe PredicateFuncResult
firstSuccess
    , predicateExplain :: Text
predicateExplain =
        case Maybe PredicateFuncResult
firstSuccess of
          Just PredicateFuncResult
p -> PredicateFuncResult -> Text
predicateExplain PredicateFuncResult
p
          Maybe PredicateFuncResult
Nothing -> [Text] -> Text
mergeMessages ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (PredicateFuncResult -> Text) -> [PredicateFuncResult] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map PredicateFuncResult -> Text
predicateExplain [PredicateFuncResult]
results
    , predicateShowFailCtx :: ShowFailCtx
predicateShowFailCtx = [PredicateFuncResult] -> ShowFailCtx
showMergedCtxs [PredicateFuncResult]
results
    }
  where
    firstSuccess :: Maybe PredicateFuncResult
firstSuccess = [PredicateFuncResult] -> Maybe PredicateFuncResult
forall a. [a] -> Maybe a
listToMaybe ([PredicateFuncResult] -> Maybe PredicateFuncResult)
-> [PredicateFuncResult] -> Maybe PredicateFuncResult
forall a b. (a -> b) -> a -> b
$ (PredicateFuncResult -> Bool)
-> [PredicateFuncResult] -> [PredicateFuncResult]
forall a. (a -> Bool) -> [a] -> [a]
filter PredicateFuncResult -> Bool
predicateSuccess [PredicateFuncResult]
results

render :: a -> Text
render :: forall a. a -> Text
render = String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. a -> String
anythingToString

-- | Add parentheses if the given input contains spaces.
parens :: Text -> Text
parens :: Text -> Text
parens Text
s =
  if Text
" " Text -> Text -> Bool
`Text.isInfixOf` Text
s
    then Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    else Text
s

indent :: Text -> Text
indent :: Text -> Text
indent = Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"\n"