{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}

-- | Combinators for constructing and running properties.
module Test.Mutagen.Property
  ( -- * Property arguments
    IsArgs
  , Args (..)
  , Result (..)
  , pattern Passed
  , pattern Failed
  , pattern Discarded
  , Prop
  , unProp
  , mapProp
  , protectProp
  , (==>)
  , discardAfter
  , IsProp (..)
  , Property (..)
  , mapProperty
  , forAll
  , expectFailure
  , Testable (..)
  )
where

import Data.Typeable (Typeable, cast)
import System.Timeout (timeout)
import Test.Mutagen.Exception (AnException, discard, isDiscard, tryEvaluateIO)
import Test.Mutagen.Fragment (Fragmentable (..))
import Test.Mutagen.Lazy (Lazy (..))
import Test.Mutagen.Mutation (Mutable (..))
import Test.QuickCheck (Arbitrary, Gen, arbitrary)
import Unsafe.Coerce (unsafeCoerce)

{-------------------------------------------------------------------------------
-- * Property arguments
-------------------------------------------------------------------------------}

-- | Constraints needed for types that can be used as property arguments.
type IsArgs a =
  ( Show a
  , Eq a
  , Ord a
  , Typeable a
  , Arbitrary a
  , Fragmentable a
  , Mutable a
  , Lazy a
  )

-- | Test arguments hidden behind an existential.
data Args = forall a. (IsArgs a) => Args a

instance Show Args where
  show :: Args -> String
show (Args a
arg) = a -> String
forall a. Show a => a -> String
show a
arg

instance Mutable Args where
  mutate :: Mutation Args
mutate (Args a
a) = (a -> Args) -> Mutant a -> Mutant Args
forall a b. (a -> b) -> Mutant a -> Mutant b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Args
forall a. IsArgs a => a -> Args
Args (Mutant a -> Mutant Args) -> [Mutant a] -> [Mutant Args]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mutation a
forall x. Mutable x => Mutation x
mutate a
a
  inside :: Pos -> (forall x. Mutable x => Mutation x) -> Mutation Args
inside Pos
pos forall x. Mutable x => Mutation x
mut (Args a
a) = (a -> Args) -> Mutant a -> Mutant Args
forall a b. (a -> b) -> Mutant a -> Mutant b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Args
forall a. IsArgs a => a -> Args
Args (Mutant a -> Mutant Args) -> [Mutant a] -> [Mutant Args]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pos -> (forall x. Mutable x => Mutation x) -> Mutation a
forall a.
Mutable a =>
Pos -> (forall x. Mutable x => Mutation x) -> Mutation a
inside Pos
pos Mutation x
forall x. Mutable x => Mutation x
mut a
a
  positions :: Args -> Tree Pos
positions (Args a
a) = a -> Tree Pos
forall a. Mutable a => a -> Tree Pos
positions a
a

instance Lazy Args where
  lazy :: Args -> Args
lazy (Args a
a) = a -> Args
forall a. IsArgs a => a -> Args
Args (a -> a
forall a. Lazy a => a -> a
lazy a
a)
  lazyNode :: Pos -> Args -> Args
lazyNode Pos
pre (Args a
a) = a -> Args
forall a. IsArgs a => a -> Args
Args (Pos -> a -> a
forall a. Lazy a => Pos -> a -> a
lazyNode Pos
pre a
a)

instance Eq Args where
  Args a
a == :: Args -> Args -> Bool
== Args a
b =
    case a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
b of
      Maybe a
Nothing -> Bool
False
      Just a
b' -> a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b'

instance Ord Args where
  compare :: Args -> Args -> Ordering
compare (Args a
a) (Args a
b) =
    case a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
b of
      Just a
b' -> a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b'
      Maybe a
Nothing -> Ordering
LT

instance Fragmentable Args where
  fragmentize :: Args -> Set Fragment
fragmentize (Args a
a) = a -> Set Fragment
forall a. Fragmentable a => a -> Set Fragment
fragmentize a
a

{-------------------------------------------------------------------------------
-- * Property results
-------------------------------------------------------------------------------}

-- | Result of executing a property.
data Result = Result
  { Result -> Maybe Bool
resultOk :: Maybe Bool
  -- ^ 'Just True' for passed, 'Just False' for failed, 'Nothing' for discarded
  , Result -> Maybe AnException
resultException :: Maybe AnException
  -- ^ Exception raised during evaluation, if any
  , Result -> Maybe String
resultReason :: Maybe String
  -- ^ Reason for failure or discarding, if any
  , Result -> Bool
resultExpect :: Bool
  -- ^ Whether the test was expected to pass or fail
  }
  deriving (Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
(Int -> Result -> ShowS)
-> (Result -> String) -> ([Result] -> ShowS) -> Show Result
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Result -> ShowS
showsPrec :: Int -> Result -> ShowS
$cshow :: Result -> String
show :: Result -> String
$cshowList :: [Result] -> ShowS
showList :: [Result] -> ShowS
Show)

{-# COMPLETE Passed, Failed, Discarded :: Result #-}

-- | Pattern synonyms for a successful t'Result'.
pattern Passed :: Result
pattern $mPassed :: forall {r}. Result -> ((# #) -> r) -> ((# #) -> r) -> r
Passed <- Result{resultOk = Just True}

-- | Pattern synonyms for a failed t'Result'.
pattern Failed :: Result
pattern $mFailed :: forall {r}. Result -> ((# #) -> r) -> ((# #) -> r) -> r
Failed <- Result{resultOk = Just False}

-- | Pattern synonyms for a discarded t'Result'.
pattern Discarded :: Result
pattern $mDiscarded :: forall {r}. Result -> ((# #) -> r) -> ((# #) -> r) -> r
Discarded <- Result{resultOk = Nothing}

-- ** Result constructors

bool :: Bool -> Result
bool :: Bool -> Result
bool Bool
b = Maybe Bool -> Maybe AnException -> Maybe String -> Bool -> Result
Result (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
b) Maybe AnException
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Bool
True

failed :: Result
failed :: Result
failed = Bool -> Result
bool Bool
False

discarded :: Result
discarded :: Result
discarded = Maybe Bool -> Maybe AnException -> Maybe String -> Bool -> Result
Result Maybe Bool
forall a. Maybe a
Nothing Maybe AnException
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Bool
True

exception :: AnException -> Result
exception :: AnException -> Result
exception AnException
e
  | AnException -> Bool
isDiscard AnException
e =
      Result
discarded
        { resultException = Just e
        , resultReason = Just "evaluated 'discard'"
        }
  | Bool
otherwise =
      Result
failed
        { resultException = Just e
        , resultReason = Just "exception"
        }

{-------------------------------------------------------------------------------
-- * Executable properties
-------------------------------------------------------------------------------}

-- | Executable properties as IO computations producing results.
newtype Prop = Prop
  { Prop -> IO Result
unProp :: IO Result
  -- ^ Extract the IO computation from a Prop.
  }

-- | Map a function over the result of a prop.
mapProp :: (Result -> Result) -> Prop -> Prop
mapProp :: (Result -> Result) -> Prop -> Prop
mapProp Result -> Result
f = IO Result -> Prop
Prop (IO Result -> Prop) -> (Prop -> IO Result) -> Prop -> Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Result -> Result) -> IO Result -> IO Result
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result -> Result
f (IO Result -> IO Result)
-> (Prop -> IO Result) -> Prop -> IO Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prop -> IO Result
unProp

-- | Protect a prop against exceptions during evaluation.
protectProp :: Prop -> Prop
protectProp :: Prop -> Prop
protectProp (Prop IO Result
io) = IO Result -> Prop
Prop (IO Result -> Prop) -> IO Result -> Prop
forall a b. (a -> b) -> a -> b
$ do
  let force :: Result -> Result
force Result
t = Result -> Maybe Bool
resultOk Result
t Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False Bool -> Result -> Result
forall a b. a -> b -> b
`seq` Result
t
  res <- IO Result -> IO (Either AnException Result)
forall a. IO a -> IO (Either AnException a)
tryEvaluateIO ((Result -> Result) -> IO Result -> IO Result
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Result -> Result
force IO Result
io)
  case res of
    Left AnException
e -> Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AnException -> Result
exception AnException
e)
    Right Result
r -> Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r

-- | Implication combinator for properties.
(==>) :: (IsProp a) => Bool -> a -> Prop
==> :: forall a. IsProp a => Bool -> a -> Prop
(==>) Bool
True a
post = a -> Prop
forall a. IsProp a => a -> Prop
prop a
post
(==>) Bool
False a
_ = Result -> Prop
forall a. IsProp a => a -> Prop
prop Result
discarded

infixr 2 ==>

-- | Discard a property if it takes more than some milliseconds.
discardAfter :: (IsProp a) => Int -> a -> Prop
discardAfter :: forall a. IsProp a => Int -> a -> Prop
discardAfter Int
millis a
a = IO Result -> Prop
Prop (IO Result -> Prop) -> IO Result -> Prop
forall a b. (a -> b) -> a -> b
$ do
  let iot :: IO Result
iot = Prop -> IO Result
unProp (a -> Prop
forall a. IsProp a => a -> Prop
prop a
a)
  mbt <- Int -> IO Result -> IO (Maybe Result)
forall a. Int -> IO a -> IO (Maybe a)
timeout (Int
millis Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000) IO Result
iot
  maybe discard return mbt

-- | Types that can produce props.
class IsProp a where
  prop :: a -> Prop

instance IsProp Prop where
  prop :: Prop -> Prop
prop = Prop -> Prop
forall a. a -> a
id

instance IsProp Result where
  prop :: Result -> Prop
prop Result
t = IO Result -> Prop
Prop (Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
t)

instance IsProp Bool where
  prop :: Bool -> Prop
prop Bool
b = IO Result -> Prop
Prop (Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Result
bool Bool
b))

instance (IsProp a) => IsProp (IO a) where
  prop :: IO a -> Prop
prop IO a
ior = IO Result -> Prop
Prop (IO Result -> Prop) -> IO Result -> Prop
forall a b. (a -> b) -> a -> b
$ do
    r <- IO a
ior
    unProp (prop r)

{-------------------------------------------------------------------------------
-- * Testable properties
-------------------------------------------------------------------------------}

-- | Properties encapsulating generators of arguments and runner functions.
data Property = Property (Gen Args) (Args -> Prop)

-- | Map a function over the inner executable t'Prop' of a property.
mapProperty :: (Prop -> Prop) -> Property -> Property
mapProperty :: (Prop -> Prop) -> Property -> Property
mapProperty Prop -> Prop
f (Property Gen Args
g Args -> Prop
p) = Gen Args -> (Args -> Prop) -> Property
Property Gen Args
g (Prop -> Prop
f (Prop -> Prop) -> (Args -> Prop) -> Args -> Prop
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Args -> Prop
p)

-- | Universal quantification over generated arguments.
forAll :: (IsArgs a, IsProp b) => Gen a -> (a -> b) -> Property
forAll :: forall a b. (IsArgs a, IsProp b) => Gen a -> (a -> b) -> Property
forAll Gen a
gen a -> b
f =
  Gen Args -> (Args -> Prop) -> Property
Property (a -> Args
forall a. IsArgs a => a -> Args
Args (a -> Args) -> Gen a -> Gen Args
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a
gen) ((Args -> Prop) -> Property) -> (Args -> Prop) -> Property
forall a b. (a -> b) -> a -> b
$ \(Args a
as) ->
    b -> Prop
forall a. IsProp a => a -> Prop
prop (a -> b
f (a -> a
forall a b. a -> b
unsafeCoerce a
as))

-- | Expect a property to fail.
expectFailure :: (Testable prop) => prop -> Property
expectFailure :: forall prop. Testable prop => prop -> Property
expectFailure prop
p =
  (Prop -> Prop) -> Property -> Property
mapProperty
    ((Result -> Result) -> Prop -> Prop
mapProp (\Result
test -> Result
test{resultExpect = False}))
    (prop -> Property
forall prop. Testable prop => prop -> Property
property prop
p)

-- ** Testable type class

-- | A class for testable properties.
class Testable a where
  property :: a -> Property

-- | Properties are trivially testable.
instance Testable Property where
  property :: Property -> Property
property Property
p = Property
p

instance Testable Bool where
  property :: Bool -> Property
property Bool
b = (() -> Bool) -> Property
forall prop. Testable prop => prop -> Property
property (\() -> Bool
b)

-- | Testable properties with one argument.
instance (IsArgs a, IsProp b) => Testable (a -> b) where
  property :: (a -> b) -> Property
property = Gen a -> (a -> b) -> Property
forall a b. (IsArgs a, IsProp b) => Gen a -> (a -> b) -> Property
forAll Gen a
forall a. Arbitrary a => Gen a
arbitrary