{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Hedgehog.Internal.Property (
Property(..)
, PropertyT(..)
, PropertyName(..)
, PropertyConfig(..)
, TestLimit(..)
, DiscardLimit(..)
, ShrinkLimit(..)
, ShrinkRetries(..)
, withTests
, withDiscards
, withShrinks
, withRetries
, property
, test
, forAll
, forAllT
, forAllWith
, forAllWithT
, discard
, Group(..)
, GroupName(..)
, MonadTest(..)
, Test
, TestT(..)
, Log(..)
, Failure(..)
, Diff(..)
, annotate
, annotateShow
, footnote
, footnoteShow
, failure
, success
, assert
, (===)
, (/==)
, eval
, evalM
, evalIO
, evalEither
, evalExceptT
, defaultConfig
, mapConfig
, failDiff
, failException
, failWith
, writeLog
, mkTest
, mkTestT
, runTest
, runTestT
) where
import Control.Applicative (Alternative(..))
import Control.Monad (MonadPlus(..))
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
import Control.Monad.Catch (SomeException(..), displayException)
import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Morph (MFunctor(..))
import Control.Monad.Primitive (PrimMonad(..))
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.State.Class (MonadState(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Cont (ContT)
import Control.Monad.Trans.Control (ComposeSt, defaultLiftBaseWith, defaultRestoreM)
import Control.Monad.Trans.Control (MonadBaseControl(..), MonadTransControl(..))
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
import Control.Monad.Trans.Identity (IdentityT)
import Control.Monad.Trans.Maybe (MaybeT)
import qualified Control.Monad.Trans.RWS.Lazy as Lazy
import qualified Control.Monad.Trans.RWS.Strict as Strict
import Control.Monad.Trans.Reader (ReaderT)
import Control.Monad.Trans.Resource (MonadResource(..))
import Control.Monad.Trans.Resource (ResourceT)
import qualified Control.Monad.Trans.State.Lazy as Lazy
import qualified Control.Monad.Trans.State.Strict as Strict
import qualified Control.Monad.Trans.Writer.Lazy as Lazy
import qualified Control.Monad.Trans.Writer.Strict as Strict
import qualified Data.Char as Char
import Data.Functor.Identity (Identity(..))
import qualified Data.List as List
import Data.Semigroup (Semigroup)
import Data.String (IsString)
import Data.Typeable (typeOf)
import Hedgehog.Internal.Distributive
import Hedgehog.Internal.Exception
import Hedgehog.Internal.Gen (Gen, GenT)
import qualified Hedgehog.Internal.Gen as Gen
import Hedgehog.Internal.Show
import Hedgehog.Internal.Source
import Language.Haskell.TH.Lift (deriveLift)
data Property =
Property {
propertyConfig :: !PropertyConfig
, propertyTest :: PropertyT IO ()
}
newtype PropertyT m a =
PropertyT {
unPropertyT :: TestT (GenT m) a
} deriving (
Functor
, Applicative
, Monad
, MonadIO
, MonadBase b
, MonadThrow
, MonadCatch
, MonadReader r
, MonadState s
, MonadError e
)
type Test =
TestT Identity
newtype TestT m a =
TestT {
unTest :: ExceptT Failure (Lazy.WriterT [Log] m) a
} deriving (
Functor
, Applicative
, MonadIO
, MonadBase b
, MonadThrow
, MonadCatch
, MonadReader r
, MonadState s
)
newtype PropertyName =
PropertyName {
unPropertyName :: String
} deriving (Eq, Ord, Show, IsString, Semigroup)
data PropertyConfig =
PropertyConfig {
propertyTestLimit :: !TestLimit
, propertyDiscardLimit :: !DiscardLimit
, propertyShrinkLimit :: !ShrinkLimit
, propertyShrinkRetries :: !ShrinkRetries
} deriving (Eq, Ord, Show)
newtype TestLimit =
TestLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
newtype DiscardLimit =
DiscardLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
newtype ShrinkLimit =
ShrinkLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
newtype ShrinkRetries =
ShrinkRetries Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
data Group =
Group {
groupName :: !GroupName
, groupProperties :: ![(PropertyName, Property)]
}
newtype GroupName =
GroupName {
unGroupName :: String
} deriving (Eq, Ord, Show, IsString, Semigroup)
data Log =
Annotation (Maybe Span) String
| Footnote String
deriving (Eq, Show)
data Failure =
Failure (Maybe Span) String (Maybe Diff)
deriving (Eq, Show)
data Diff =
Diff {
diffPrefix :: String
, diffRemoved :: String
, diffInfix :: String
, diffAdded :: String
, diffSuffix :: String
, diffValue :: ValueDiff
} deriving (Eq, Show)
instance Monad m => Monad (TestT m) where
return =
TestT . return
(>>=) m k =
TestT $
unTest m >>=
unTest . k
fail err =
TestT . ExceptT . pure . Left $ Failure Nothing err Nothing
instance MonadTrans TestT where
lift =
TestT . lift . lift
instance MFunctor TestT where
hoist f =
TestT . hoist (hoist f) . unTest
instance Distributive TestT where
type Transformer t TestT m = (
Transformer t (Lazy.WriterT [Log]) m
, Transformer t (ExceptT Failure) (Lazy.WriterT [Log] m)
)
distribute =
hoist TestT .
distribute .
hoist distribute .
unTest
instance PrimMonad m => PrimMonad (TestT m) where
type PrimState (TestT m) =
PrimState m
primitive =
lift . primitive
instance MonadError e m => MonadError e (TestT m) where
throwError =
lift . throwError
catchError m onErr =
TestT . ExceptT $
(runExceptT $ unTest m) `catchError`
(runExceptT . unTest . onErr)
instance MonadResource m => MonadResource (TestT m) where
liftResourceT =
lift . liftResourceT
instance MonadTransControl TestT where
type StT TestT a =
(Either Failure a, [Log])
liftWith f =
mkTestT . fmap (, []) . fmap Right $ f $ runTestT
restoreT =
mkTestT
instance MonadBaseControl b m => MonadBaseControl b (TestT m) where
type StM (TestT m) a =
ComposeSt TestT m a
liftBaseWith =
defaultLiftBaseWith
restoreM =
defaultRestoreM
class Monad m => MonadTest m where
liftTest :: Test a -> m a
instance Monad m => MonadTest (TestT m) where
liftTest =
hoist (pure . runIdentity)
instance MonadTest m => MonadTest (IdentityT m) where
liftTest =
lift . liftTest
instance MonadTest m => MonadTest (MaybeT m) where
liftTest =
lift . liftTest
instance MonadTest m => MonadTest (ExceptT x m) where
liftTest =
lift . liftTest
instance MonadTest m => MonadTest (ReaderT r m) where
liftTest =
lift . liftTest
instance MonadTest m => MonadTest (Lazy.StateT s m) where
liftTest =
lift . liftTest
instance MonadTest m => MonadTest (Strict.StateT s m) where
liftTest =
lift . liftTest
instance (MonadTest m, Monoid w) => MonadTest (Lazy.WriterT w m) where
liftTest =
lift . liftTest
instance (MonadTest m, Monoid w) => MonadTest (Strict.WriterT w m) where
liftTest =
lift . liftTest
instance (MonadTest m, Monoid w) => MonadTest (Lazy.RWST r w s m) where
liftTest =
lift . liftTest
instance (MonadTest m, Monoid w) => MonadTest (Strict.RWST r w s m) where
liftTest =
lift . liftTest
instance MonadTest m => MonadTest (ContT r m) where
liftTest =
lift . liftTest
instance MonadTest m => MonadTest (ResourceT m) where
liftTest =
lift . liftTest
mkTestT :: m (Either Failure a, [Log]) -> TestT m a
mkTestT =
TestT . ExceptT . Lazy.WriterT
mkTest :: (Either Failure a, [Log]) -> Test a
mkTest =
mkTestT . Identity
runTestT :: TestT m a -> m (Either Failure a, [Log])
runTestT =
Lazy.runWriterT . runExceptT . unTest
runTest :: Test a -> (Either Failure a, [Log])
runTest =
runIdentity . runTestT
writeLog :: MonadTest m => Log -> m ()
writeLog x =
liftTest $ mkTest (pure (), [x])
failWith :: (MonadTest m, HasCallStack) => Maybe Diff -> String -> m a
failWith diff msg =
liftTest $ mkTest (Left $ Failure (getCaller callStack) msg diff, [])
annotate :: (MonadTest m, HasCallStack) => String -> m ()
annotate x = do
writeLog $ Annotation (getCaller callStack) x
annotateShow :: (MonadTest m, Show a, HasCallStack) => a -> m ()
annotateShow x = do
withFrozenCallStack $ annotate (showPretty x)
footnote :: MonadTest m => String -> m ()
footnote =
writeLog . Footnote
footnoteShow :: (MonadTest m, Show a) => a -> m ()
footnoteShow =
writeLog . Footnote . showPretty
failDiff :: (MonadTest m, Show a, Show b, HasCallStack) => a -> b -> m ()
failDiff x y =
case valueDiff <$> mkValue x <*> mkValue y of
Nothing ->
withFrozenCallStack $
failWith Nothing $ unlines [
"━━━ Not Equal ━━━"
, showPretty x
, showPretty y
]
Just diff ->
withFrozenCallStack $
failWith (Just $ Diff "Failed (" "- lhs" "=/=" "+ rhs" ")" diff) ""
failException :: (MonadTest m, HasCallStack) => SomeException -> m a
failException (SomeException x) =
withFrozenCallStack $
failWith Nothing $ unlines [
"━━━ Exception: " ++ show (typeOf x) ++ " ━━━"
, List.dropWhileEnd Char.isSpace (displayException x)
]
failure :: (MonadTest m, HasCallStack) => m a
failure =
withFrozenCallStack $ failWith Nothing ""
success :: MonadTest m => m ()
success =
pure ()
assert :: (MonadTest m, HasCallStack) => Bool -> m ()
assert b = do
ok <- withFrozenCallStack $ eval b
if ok then
success
else
withFrozenCallStack failure
infix 4 ===
(===) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m ()
(===) x y = do
ok <- withFrozenCallStack $ eval (x == y)
if ok then
success
else
withFrozenCallStack $ failDiff x y
infix 4 /==
(/==) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m ()
(/==) x y = do
ok <- withFrozenCallStack $ eval (x /= y)
if ok then
success
else
withFrozenCallStack $
failWith Nothing $ unlines [
"━━━ Both equal to ━━━"
, showPretty x
]
eval :: (MonadTest m, HasCallStack) => a -> m a
eval x =
either (withFrozenCallStack failException) pure (tryEvaluate x)
evalM :: (MonadTest m, MonadCatch m, HasCallStack) => m a -> m a
evalM m =
either (withFrozenCallStack failException) pure =<< tryAll m
evalIO :: (MonadTest m, MonadIO m, HasCallStack) => IO a -> m a
evalIO m =
either (withFrozenCallStack failException) pure =<< liftIO (tryAll m)
evalEither :: (MonadTest m, Show x, HasCallStack) => Either x a -> m a
evalEither = \case
Left x ->
withFrozenCallStack $ failWith Nothing $ showPretty x
Right x ->
pure x
evalExceptT :: (MonadTest m, Show x, HasCallStack) => ExceptT x m a -> m a
evalExceptT m =
withFrozenCallStack evalEither =<< runExceptT m
instance MonadTrans PropertyT where
lift =
PropertyT . lift . lift
instance MFunctor PropertyT where
hoist f =
PropertyT . hoist (hoist f) . unPropertyT
instance Distributive PropertyT where
type Transformer t PropertyT m = (
Transformer t GenT m
, Transformer t TestT (GenT m)
)
distribute =
hoist PropertyT .
distribute .
hoist distribute .
unPropertyT
instance PrimMonad m => PrimMonad (PropertyT m) where
type PrimState (PropertyT m) =
PrimState m
primitive =
lift . primitive
instance Monad m => MonadTest (PropertyT m) where
liftTest =
PropertyT . hoist (pure . runIdentity)
instance MonadPlus m => MonadPlus (PropertyT m) where
mzero =
discard
mplus (PropertyT x) (PropertyT y) =
PropertyT . mkTestT $
mplus (runTestT x) (runTestT y)
instance MonadPlus m => Alternative (PropertyT m) where
empty =
mzero
(<|>) =
mplus
forAllWithT :: (Monad m, HasCallStack) => (a -> String) -> GenT m a -> PropertyT m a
forAllWithT render gen = do
x <- PropertyT $ lift gen
withFrozenCallStack $ annotate (render x)
return x
forAllWith :: (Monad m, HasCallStack) => (a -> String) -> Gen a -> PropertyT m a
forAllWith render gen =
withFrozenCallStack $ forAllWithT render $ Gen.lift gen
forAllT :: (Monad m, Show a, HasCallStack) => GenT m a -> PropertyT m a
forAllT gen =
withFrozenCallStack $ forAllWithT showPretty gen
forAll :: (Monad m, Show a, HasCallStack) => Gen a -> PropertyT m a
forAll gen =
withFrozenCallStack $ forAllWith showPretty gen
discard :: Monad m => PropertyT m a
discard =
PropertyT $ lift Gen.discard
test :: Monad m => TestT m a -> PropertyT m a
test =
PropertyT . hoist lift
defaultConfig :: PropertyConfig
defaultConfig =
PropertyConfig {
propertyTestLimit =
100
, propertyDiscardLimit =
100
, propertyShrinkLimit =
1000
, propertyShrinkRetries =
0
}
mapConfig :: (PropertyConfig -> PropertyConfig) -> Property -> Property
mapConfig f (Property cfg t) =
Property (f cfg) t
withTests :: TestLimit -> Property -> Property
withTests n =
mapConfig $ \config -> config { propertyTestLimit = n }
withDiscards :: DiscardLimit -> Property -> Property
withDiscards n =
mapConfig $ \config -> config { propertyDiscardLimit = n }
withShrinks :: ShrinkLimit -> Property -> Property
withShrinks n =
mapConfig $ \config -> config { propertyShrinkLimit = n }
withRetries :: ShrinkRetries -> Property -> Property
withRetries n =
mapConfig $ \config -> config { propertyShrinkRetries = n }
property :: HasCallStack => PropertyT IO () -> Property
property m =
Property defaultConfig $
withFrozenCallStack (evalM m)
$(deriveLift ''GroupName)
$(deriveLift ''PropertyName)
$(deriveLift ''PropertyConfig)
$(deriveLift ''TestLimit)
$(deriveLift ''DiscardLimit)
$(deriveLift ''ShrinkLimit)
$(deriveLift ''ShrinkRetries)