{-# 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
, propful
, compose
, allTrue
, allOf1
, pair
, fun
, traced
, tracedShow
, traceFailShow
, traceFail
, forced
, equals
, bool
, pattern (:=>)
, (?)
)
where
import Prelude hiding (and, fail, or)
import Control.Concurrent (myThreadId)
import Control.Exception
import Control.Monad hiding (fail)
import Data.Foldable (toList)
import Data.Functor.Const
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, ensure
-- that the structures of the two functors match and apply all of the properties
-- to all of the values.
-- Generalized version of `list`.
propful ::
(HasCallStack, Eq (f ()), Functor f, Foldable f) =>
f (Prop a) ->
Prop (f a)
propful props values
| void props == void values =
list (toList props) (toList values)
| otherwise =
fail ("shape equal to that of" <> PP.pretty (anythingToTextPretty props)) 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
-- | 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
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)
-- | Higher precedence '$', to work well with '&'.
-- The intended use is something like `x & match _Right ? equals 2`.
(?) :: (a -> b) -> a -> b
(?) = ($)
infixr 8 ?