{-# 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 transformer, the below
-- type @PT a b@, which is a function from @a@ to properties on @b@.
-- 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.
--
-- Some property transformers provided by other libraries:
-- `Data.Foldable.all`, `Data.Foldable.any` (base)
-- `either` (base)
-- `Control.Lens.allOf` (lens)
module PropertyMatchers
( Assertion
, Boolish(..)
, fail
, succeed
, branch
, PropertyException(..)
, Prop
, PT
, endingWith
, startingWith
, match
, atIndex
, list
, alignExact
, alignLax
, elem
, compose
, allTrue
, allOf1
, pair
, fun
, fails
, traced
, tracedShow
, traceFailShow
, traceFail
, forced
, equals
, lt
, lte
, gt
, gte
, bool
, pattern (:=>)
, (?)
)
where
import Prelude hiding (and, elem, fail, or)
import Control.Concurrent (myThreadId)
import Control.Exception
import qualified Data.Align as Align
import Data.Foldable (toList)
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
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
-- unreachable
return undefined
, 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 Show PropertyException where
show = displayException
instance Exception PropertyException where
displayException (PropertyFailed cs expected actual) =
PP.renderString $ PP.layoutSmart PP.defaultLayoutOptions $
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 <> expected
)
<> PP.hardline <> PP.pretty (prettyCallStack cs)
where
prettyActual = anythingToTextPretty actual
displayException (NoBranchMatched cs actual) =
PP.renderString $ PP.layoutSmart PP.defaultLayoutOptions $
PP.group
( PP.line'
<> PP.flatAlt "Actual:" "Actual value"
<> PP.softline <> PP.pretty prettyActual
<> PP.line' <> PP.line
<> "did not match any branches"
)
<> PP.hardline <> PP.pretty (prettyCallStack cs)
where
prettyActual = anythingToTextPretty actual
-- | Successful assertion. Includes documentation of the failed expectation,
-- as well as the asserted-on value for printing to the user.
-- Doubles as an always-failing property,
fail :: HasCallStack => PP.Doc ann -> Prop a
fail expected actual = throwIO (PropertyFailed (popCallStack callStack) expected actual)
-- | Always-successful property, equivalent to `\_ -> pure ()`.
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`.
-- Multiple are already provided by the standard library,
-- for instance `Data.Foldable.all` and `Data.Foldable.any`.
type PT a b = Prop a -> Prop b
-- | Operate on the last value in a foldable, or fail if it's not present.
endingWith :: (HasCallStack, Foldable f) => PT a (f a)
endingWith _ actual@(toList -> []) = fail "nonempty foldable" actual
endingWith p (toList -> xs) = p $ last xs
{-# INLINABLE endingWith #-}
-- | Operate on the first value in a foldable, or fail if it's not present.
startingWith :: (HasCallStack, Foldable f) => PT a (f a)
startingWith _ actual@(toList -> []) = fail "nonempty foldable" actual
startingWith p (toList -> (x : _)) = p x
{-# INLINABLE startingWith #-}
-- | Internal, 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
-- | Test the element of a foldable at some index.
atIndex :: (Foldable f) => Int -> PT a (f a)
atIndex k p = startingWith p . drop k . toList
-- | 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.
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`.
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 props)) values
That _extraValue -> fail ("no missing elements relative to " <> PP.pretty (anythingToTextPretty 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
-- them to each other pointwise. If there is any misalignment between the two:
-- * if there's an excess value, apply the excess property to it
-- * if there's a missing value, pass the corresponding property `Nothing`
-- Examples:
-- alignLax (Map.fromList ["k" :=> P.lt 3, "g" :=> P.match P.gt 4]) (Map.fromList )
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 `propful`.
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.
allTrue :: (Foldable f) => f (Prop a) -> Prop a
allTrue ps a = foldr (\p r -> p a `and` r) (succeed a) ps
{-# INLINABLE allTrue #-}
-- | 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 =
foldr (\x r -> p x `and` r) (succeed vs) vsList
| otherwise = fail "non-empty for fold" vs
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
fails :: Exception e => Prop e -> Prop (IO a)
fails 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, Eq a) => a -> Prop a
equals expected actual
| expected == actual = succeed actual
| otherwise = fail (PP.pretty (anythingToTextPretty expected)) actual
lt :: (HasCallStack, Ord a) => a -> Prop a
lt expected actual
| actual < expected = succeed actual
| otherwise = fail ("less than " <> PP.pretty (anythingToTextPretty expected)) actual
gt :: (HasCallStack, Ord a) => a -> Prop a
gt expected actual
| actual > expected = succeed actual
| otherwise = fail ("greater than " <> PP.pretty (anythingToTextPretty expected)) actual
gte :: (HasCallStack, Ord a) => a -> Prop a
gte expected actual
| actual >= expected = succeed actual
| otherwise = fail ("greater than/equal to " <> PP.pretty (anythingToTextPretty expected)) actual
lte :: (HasCallStack, Ord a) => a -> Prop a
lte expected actual
| actual <= expected = succeed actual
| otherwise = fail ("less than/equal to " <> PP.pretty (anythingToTextPretty expected)) actual
bool :: HasCallStack => Bool -> Assertion
bool b
| b = succeed b
| otherwise = fail (PP.pretty True) b
-- | 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 '&'.
-- The intended use is something like `x & match _Right ? equals 2`.
(?) :: (a -> b) -> a -> b
(?) = ($)
infixr 8 ?