{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fexpose-all-unfoldings #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeApplications #-}
-- | This library is based on the notion of a property, a function `a -> IO ()`,
-- which can be transformed and composed. They act as a sort of compositional
-- "matcher language". Composing these property transformers is meant to be
-- analogous to composing optics and there are utilities for using property
-- transformers with (lens-style) optics.
-- Designed for qualified import except for operators.
-- >>> import PropertyMatchers qualified as P
-- >>> import PropertyMatchers (pattern (:=>), (?))
module PropertyMatchers
( Assertion
, Boolish(..)
, fail
, succeed
, branch
, PropertyException(..)
, Prop
, PT
, Getting
, match
, list
, alignExact
, alignLax
, elem
, compose
, checkAll
, anyOf
, allOf1
, pair
, fun
, throws
, traced
, tracedShow
, traceFailShow
, traceFail
, forced
, equals
, notEquals
, lt
, lte
, gt
, gte
, pattern (:=>)
, (?)
)
where
import Prelude hiding (and, elem, fail, or)
import Control.Concurrent (myThreadId)
import Control.Exception
import Control.Monad (void)
import qualified Data.Align as Align
import Data.Functor.Const
import Data.These
import Data.Typeable
import Debug.Trace
import GHC.Stack
import Control.DeepSeq (NFData, force)
import qualified Data.Text.Lazy as TL
import Data.Functor.Rep (Representable (..))
import qualified "pretty-simple" Text.Pretty.Simple as Pretty.Simple
import qualified "prettyprinter" Prettyprinter as PP
import qualified "prettyprinter" Prettyprinter.Render.String as PP
import "recover-rtti" Debug.RecoverRTTI (anythingToString)
import Data.IORef
-- $setup
-- >>> :set -XOverloadedStrings -XTypeApplications
-- >>> import Control.Lens
-- >>> import Data.Function ((&))
-- >>> import Data.Bool (bool)
-- >>> import qualified Data.List as List
-- >>> import System.IO.Unsafe (unsafePerformIO)
-- >>> :{
-- failureMessage x
-- = try @PropertyException x
-- & unsafePerformIO
-- & over _Left prettyExnWithoutCallStack
-- :}
--
-- >>> :{
-- contains message exnMsg = bool
-- (fail ("message starting with " <> PP.pretty message))
-- succeed
-- (message `List.isInfixOf` exnMsg)
-- exnMsg
-- :}
--
-- | Returned by all properties.
-- Enables applying properties using `>>=` and `Data.Function.&`, for example, in a do-block.
type Assertion = IO ()
-- | Internal, mostly the same as `catch` in safe-exceptions.
--
trySync :: Exception e => IO a -> IO (Either e a)
trySync act = catches (Right <$> act)
-- explicitly do not handle async exceptions.
-- otherwise, a thread being killed may appear as a property failure.
[ Handler $ \(ex :: SomeAsyncException) -> do
tid <- myThreadId
throwTo tid ex
evaluate (error "unreachable")
, Handler $ \(ex :: e) ->
return $ Left ex
]
-------------------------------------------------------------------------------
anythingToTextPretty :: a -> TL.Text
anythingToTextPretty = Pretty.Simple.pStringOpt opts . anythingToString
where
opts = Pretty.Simple.defaultOutputOptionsNoColor
{ Pretty.Simple.outputOptionsIndentAmount = 2
, Pretty.Simple.outputOptionsPageWidth = 120
, Pretty.Simple.outputOptionsCompact = True
, Pretty.Simple.outputOptionsCompactParens = True
, Pretty.Simple.outputOptionsInitialIndent = 0
}
-- | The exception thrown by properties of type `Assertion` by default.
-- Other non-async exceptions will work fine too.
--
data PropertyException
= forall actual ann. PropertyFailed !CallStack (PP.Doc ann) actual
| forall actual. NoBranchMatched !CallStack actual
deriving (Typeable)
instance PP.Pretty PropertyException where
pretty exn@(PropertyFailed cs _expected _actual) =
prettyExnWithoutCallStack exn
<> PP.hardline <> PP.pretty (prettyCallStack cs)
pretty exn@(NoBranchMatched cs _actual) =
prettyExnWithoutCallStack exn
<> PP.hardline <> PP.pretty (prettyCallStack cs)
-- | Internal. Used for doctests.
prettyExnWithoutCallStack :: PropertyException -> PP.Doc ann
prettyExnWithoutCallStack (PropertyFailed _cs expected actual) =
PP.group
( PP.line'
<> PP.flatAlt "Actual:" "Actual value"
<> PP.softline <> PP.pretty prettyActual
<> PP.line' <> PP.line
<> PP.flatAlt "Expected:" "but expected"
<> PP.softline <> PP.unAnnotate expected
)
where
prettyActual = anythingToTextPretty actual
prettyExnWithoutCallStack (NoBranchMatched _cs actual) =
PP.group
( PP.line'
<> PP.flatAlt "Actual:" "Actual value"
<> PP.softline <> PP.pretty prettyActual
<> PP.line' <> PP.line
<> "did not match any branches"
)
where
prettyActual = anythingToTextPretty actual
instance Exception PropertyException where
displayException =
PP.renderString . PP.layoutSmart PP.defaultLayoutOptions . PP.pretty
instance Show PropertyException where
show = displayException
-- | Failed property. Includes documentation of the failed property,
-- as well as the asserted-on value for printing to the user.
--
-- >>> let actual = 42
-- >>> :{
-- actual
-- & fail (PP.pretty "something else")
-- & failureMessage
-- :}
-- Left Actual value 42 but expected something else
fail :: HasCallStack => PP.Doc ann -> a -> IO x
fail expected actual = throwIO (PropertyFailed (popCallStack callStack) expected actual)
-- | Always-successful property, equivalent to @\_ -> pure ()@.
--
-- >>> let actual = 42
-- >>> succeed actual
--
succeed :: actual -> Assertion
succeed _ = pure ()
{-# INLINE CONLIKE succeed #-}
-- | Class for combining properties and property results.
-- `or` and `and` should each be associative, idempotent, more or less
-- commutative (because there may be multiple falsy values) and distribute
-- over one another.
--
class Boolish p where
or :: p -> p -> p
and :: p -> p -> p
{-# MINIMAL or, and #-}
infixr 3 `and`
infixr 2 `or`
instance Boolish a => Boolish (e -> a) where
or :: Boolish a => (e -> a) -> (e -> a) -> e -> a
(f `or` f') e = f e `or` f' e
(f `and` f') e = f e `and` f' e
{-# INLINE or #-}
{-# INLINE and #-}
instance a ~ () => Boolish (IO a) where
or x y = do
catches x
[ Handler $ \(ex :: SomeAsyncException) -> do
tid <- myThreadId
throwTo tid ex
, Handler $ \(_ex :: SomeException) -> y
]
and = (>>)
{-# INLINE and #-}
-- | Non-backtracking branching. Use this to improve error messages and
-- performance by avoiding testing properties that can never succeed.
--
branch :: (HasCallStack, Foldable t) => t (PT a b, Prop a) -> Prop b
branch bs actual = foldr
(\(cond, alt) fallback -> do
triggeredRef <- newIORef False
branchResult <- trySync @SomeException
(cond (\i -> writeIORef triggeredRef True >> alt i) actual)
triggered <- readIORef triggeredRef
-- if `cond` called its input predicate,
-- that predicate may have failed or succeeded, and we
-- commit to that result.
-- if `cond` didn't call its input predicate, it counts
-- as a success, but if it fails, we do not commit to that.
case branchResult of
Left exception
| triggered -> throwIO exception
| otherwise -> fallback
Right successfulResult -> succeed successfulResult
)
(throwIO (NoBranchMatched (popCallStack callStack) actual))
bs
{-# INLINABLE branch #-}
-- | A convenient alias for properties.
--
type Prop a = a -> Assertion
-- | Property transformers form a category where composition is ordinary function composition.
-- Forms a category with `.` and `id`.
--
type PT a b = Prop a -> Prop b
-- | Ported from `lens` just for `match`.
--
type Getting r s a = (a -> Const r a) -> s -> Const r s
-- | Require that a @Prism@ or any other @Fold@ matches, and apply the property
-- to its target, only succeeding if there's exactly one target.
--
match
:: (HasCallStack)
=> Getting [a] s a
-> PT a s
match f p s =
case f (Const . pure) s of
Const [x] -> p x
_ -> fail "fold to match" s
-- | Given a list of properties and a list of values, ensure that each property
-- holds for each respective value. Fails if the two lists have different
-- lengths.
--
-- >>> [1, 2, 3] & list [equals 1, equals 2, equals 3]
-- >>> -- succeeds
-- >>> :{
-- [1]
-- & list [equals 1, equals 2, equals 3]
-- & failureMessage
-- :}
-- Left Actual value [ 1 ] but expected list with length 3
--
list :: (HasCallStack) => [Prop a] -> [a] -> Assertion
list ps xs
| psl == length xs = foldr and (succeed xs) (zipWith ($) ps xs)
| otherwise = fail ("list with length " <> PP.pretty psl) xs
where
psl = length ps
-- | Given a functor-full of properties, and a functor-full of values, align
-- the two together and apply all of the properties to the values pointwise.
-- If there is any misalignment between the two, fail.
--
-- Generalized version of `list`:
--
-- > list = alignExact
--
-- Example:
--
-- > P.alignExact (Map.singleton "a" (P.equals 2)) (Map.singleton "2" 2) -- success
-- > P.alignExact Map.empty (Map.singleton "2" 2) -- failure
-- > P.alignExact (Map.singleton "a" (P.equals 2)) Map.empty -- failure
--
alignExact
:: (HasCallStack, Traversable f, Align.Semialign f) =>
f (Prop a) ->
Prop (f a)
alignExact props values =
sequence_ $ Align.alignWith
(\case
This _extraProp -> fail ("no extra elements relative to " <> PP.pretty (anythingToTextPretty $ void props)) values
That _extraValue -> fail ("no missing elements relative to " <> PP.pretty (anythingToTextPretty $ void props)) values
These prop value -> prop value
)
props values
-- | Given a functor-full of properties and a functor-full of values
-- (and a property for excess values) align the properties and values and apply
-- the props to the values pointwise. If there is any misalignment between the two:
--
-- - if there's a value with no corresponding prop, apply the excess property to it
-- - if there's a prop with no corresponding value, pass the property `Nothing`
--
-- Generalized version of `alignExact`:
--
-- > alignExact props values =
-- > alignLax (P.fail "no extra elements") (P.match _Just <$> props) values
--
-- Examples:
--
-- > P.alignLax
-- > (P.lt 5)
-- > (Map.fromList ["k" :=> P.match _Just ? P.lt 3, "g" :=> P.match _Just ? P.gt 4])
-- > (Map.fromList [("k", 2), ("g", 5), ("h", 1)]) -- succeed
alignLax
:: (Traversable f, Align.Semialign f) =>
Prop a ->
f (Prop (Maybe a)) ->
Prop (f a)
alignLax excess props values = sequence_ $ Align.alignWith
(\case
This prop -> prop Nothing
That extraValue -> excess extraValue
These prop value -> prop (Just value)
)
props values
-- | Given a property and a traversable functor-full of values,
-- succeed if the property succeeds on at least one of the values.
--
elem
:: (HasCallStack, Traversable f) =>
Prop a ->
Prop (f a)
elem prop values
| null values = fail "nonempty value" values
| otherwise = foldr1 or $ prop <$> values
-- | Given a representable functor-full of properties, and a functor-full of values,
-- yield a representable functor-full of booleans. Similar to 'alignExact'.
--
compose ::
Representable f =>
f (Prop a) ->
f a ->
f Assertion
compose pr fa = tabulate (\r -> index pr r $ index fa r)
-- | Test all properties against one value.
--
-- >>> 1 & checkAll [succeed, equals 2] & failureMessage
-- Left Actual value 1 but expected 2
--
checkAll :: (Foldable f) => f (Prop a) -> Prop a
checkAll ps a = foldr (\p r -> p a `and` r) (succeed a) ps
{-# INLINABLE checkAll #-}
-- | Test that a property succeeds against at least one value behind a
-- generalized getter. The corresponding 'allOf' is just 'Control.Lens.traverseOf_'.
--
anyOf
:: HasCallStack
=> Getting [a] s a
-> PT a s
anyOf g p vs =
foldr (\x r -> p x `or` r) (succeed vs) vsList
where
Const vsList = g (Const . pure) vs
-- | Check that a property is true for all values behind a generalized getter
-- and that there's at least one value for which it's true.
--
allOf1
:: (HasCallStack)
=> Getting [a] s a
-> PT a s
allOf1 g p vs
| [] <- vsList = fail "non-empty for fold" vs
| otherwise =
foldr (\x r -> p x `and` r) (succeed vs) vsList
where
Const vsList = g (Const . pure) vs
-- | A pair of properties, made into a property of pairs.
--
pair :: Prop a -> Prop b -> Prop (a, b)
pair f s (a, b) = f a `and` s b
-- | Flipped function composition; @pf f@ for a function @f@ is a property transformer
-- such that @pf f p i == p (f i)@.
fun :: (a -> b) -> PT b a
fun f p = p . f
-- | Assert that some computation throws an exception, and test that the
-- exception has some property.
throws :: Exception e => Prop e -> Prop (IO a)
throws p actual = trySync actual >>= \case
Left e -> p e
Right r -> fail "a failed computation" r
-- | Prints the input of a property, if the property fails, using `Show`.
-- Requires that the property's output type can be checked for failure.
traceFailShow :: Show a => PT a a
traceFailShow = traceFail show
-- | Prints the input of a property over functions, if the property fails.
-- Requires that the property's output type can be checked for failure.
traceFail :: (a -> String) -> PT a a
traceFail s p a =
assess (p a) $ traceIO (s a)
-- | Internal. Run an extra effect if the input assertion fails.
--
assess :: Assertion -> IO () -> Assertion
assess x eff = trySync @SomeException x >>= either (\ex -> eff >> throwIO ex) return
-- | Prints the input of a property, for debugging.
--
traced :: Show a => (a -> String) -> PT a a
traced s p a = trace (s a) (p a)
-- | Prints the input of a property, for debugging.
--
tracedShow :: Show a => PT a a
tracedShow = traced show
-- | Property which triggers full evaluation of its input and succeeds.
-- Useful for testing that an exception isn't thrown.
forced :: (NFData a) => Prop a
forced a = force a `seq` succeed a
-- | The property of being equal to some expected value.
--
equals :: (HasCallStack, Show a, Eq a) => a -> Prop a
equals expected actual
| expected == actual = succeed actual
| otherwise = fail (PP.viaShow expected) actual
-- | The property of not being equal to some expected value.
--
notEquals :: (HasCallStack, Show a, Eq a) => a -> Prop a
notEquals expected actual
| expected /= actual = succeed actual
| otherwise = fail ("not equal to " <> PP.viaShow expected) actual
-- | The property of being less than some expected value.
--
lt :: (HasCallStack, Show a, Ord a) => a -> Prop a
lt expected actual
| actual < expected = succeed actual
| otherwise = fail ("less than " <> PP.viaShow expected) actual
-- | The property of being greater than some expected value.
--
gt :: (HasCallStack, Show a, Ord a) => a -> Prop a
gt expected actual
| actual > expected = succeed actual
| otherwise = fail ("greater than " <> PP.viaShow expected) actual
-- | The property of being less than or equal to some expected value.
--
lte :: (HasCallStack, Show a, Ord a) => a -> Prop a
lte expected actual
| actual <= expected = succeed actual
| otherwise = fail ("less than/equal to " <> PP.viaShow expected) actual
-- | The property of being greater than or equal to some expected value.
--
gte :: (HasCallStack, Show a, Ord a) => a -> Prop a
gte expected actual
| actual >= expected = succeed actual
| otherwise = fail ("greater than/equal to " <> PP.viaShow expected) actual
-- | Sugar for tupling.
-- The intended use is something like
-- '(x :: Either Int Int) & branch [match _Left :=> equals 1, match _Right :=> equals 2]'
--
pattern (:=>) :: a -> b -> (a, b)
pattern a :=> b = (a, b)
infixr 7 :=>
-- | Higher precedence '$', to work well with 'Data.Function.&'.
-- The intended use is something like 'x & match _Right ? equals 2'.
--
(?) :: (a -> b) -> a -> b
(?) = ($)
infixr 8 ?