module Hedgehog.Internal.Property (
Property(..)
, PropertyName(..)
, PropertyConfig(..)
, TestLimit(..)
, DiscardLimit(..)
, ShrinkLimit(..)
, property
, withTests
, withDiscards
, withShrinks
, Group(..)
, GroupName(..)
, Test(..)
, Log(..)
, Failure(..)
, Diff(..)
, forAll
, forAllWith
, annotate
, annotateShow
, footnote
, footnoteShow
, discard
, failure
, success
, assert
, (===)
, liftCatch
, liftCatchIO
, liftEither
, liftExceptT
, withCatch
, withExceptT
, withResourceT
, defaultConfig
, mapConfig
, failWith
, writeLog
, runTest
) where
import Control.Applicative (Alternative(..))
import Control.Monad (MonadPlus(..))
import Control.Monad.Base (MonadBase(..))
import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
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.Except (ExceptT(..), runExceptT)
import Control.Monad.Trans.Resource (MonadResource(..), MonadResourceBase)
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
import Control.Monad.Trans.Writer.Lazy (WriterT(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import Data.Semigroup (Semigroup)
import Data.String (IsString)
import Hedgehog.Internal.Distributive
import Hedgehog.Internal.Exception
import Hedgehog.Internal.Gen (Gen)
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 :: Test IO ()
}
newtype Test m a =
Test {
unTest :: ExceptT Failure (WriterT [Log] (Gen m)) a
} deriving (Functor, Applicative)
newtype PropertyName =
PropertyName {
unPropertyName :: String
} deriving (Eq, Ord, Show, IsString, Semigroup)
data PropertyConfig =
PropertyConfig {
propertyTestLimit :: !TestLimit
, propertyDiscardLimit :: !DiscardLimit
, propertyShrinkLimit :: !ShrinkLimit
} deriving (Eq, Ord, Show)
newtype TestLimit =
TestLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
newtype ShrinkLimit =
ShrinkLimit Int
deriving (Eq, Ord, Show, Num, Enum, Real, Integral)
newtype DiscardLimit =
DiscardLimit 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 (Test m) where
return =
Test . return
(>>=) m k =
Test $
unTest m >>=
unTest . k
fail err =
Test . ExceptT . pure . Left $ Failure Nothing err Nothing
instance Monad m => MonadPlus (Test m) where
mzero =
discard
mplus x y =
Test . ExceptT . WriterT $
mplus (runTest x) (runTest y)
instance Monad m => Alternative (Test m) where
empty =
mzero
(<|>) =
mplus
instance MonadTrans Test where
lift =
Test . lift . lift . lift
instance MFunctor Test where
hoist f =
Test . hoist (hoist (hoist f)) . unTest
distributeTest :: Transformer t Test m => Test (t m) a -> t (Test m) a
distributeTest =
hoist Test .
distribute .
hoist distribute .
hoist (hoist distribute) .
unTest
instance Distributive Test where
type Transformer t Test m = (
Transformer t Gen m
, Transformer t (WriterT [Log]) (Gen m)
, Transformer t (ExceptT Failure) (WriterT [Log] (Gen m))
)
distribute =
distributeTest
instance PrimMonad m => PrimMonad (Test m) where
type PrimState (Test m) =
PrimState m
primitive =
lift . primitive
instance MonadIO m => MonadIO (Test m) where
liftIO =
lift . liftIO
instance MonadBase b m => MonadBase b (Test m) where
liftBase =
lift . liftBase
instance MonadThrow m => MonadThrow (Test m) where
throwM =
lift . throwM
instance MonadCatch m => MonadCatch (Test m) where
catch m onErr =
Test $
(unTest m) `catch`
(unTest . onErr)
instance MonadReader r m => MonadReader r (Test m) where
ask =
lift ask
local f m =
Test $
local f (unTest m)
instance MonadState s m => MonadState s (Test m) where
get =
lift get
put =
lift . put
state =
lift . state
instance MonadError e m => MonadError e (Test m) where
throwError =
lift . throwError
catchError m onErr =
Test . ExceptT $
(runExceptT $ unTest m) `catchError`
(runExceptT . unTest . onErr)
instance MonadResource m => MonadResource (Test m) where
liftResourceT =
lift . liftResourceT
defaultConfig :: PropertyConfig
defaultConfig =
PropertyConfig {
propertyTestLimit =
100
, propertyDiscardLimit =
100
, propertyShrinkLimit =
1000
}
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 }
property :: Test IO () -> Property
property =
Property defaultConfig
runTest :: Test m a -> Gen m (Either Failure a, [Log])
runTest =
runWriterT . runExceptT . unTest
writeLog :: Monad m => Log -> Test m ()
writeLog =
Test . lift . tell . pure
forAll :: (Monad m, Show a, HasCallStack) => Gen m a -> Test m a
forAll gen =
withFrozenCallStack $ forAllWith showPretty gen
forAllWith :: (Monad m, HasCallStack) => (a -> String) -> Gen m a -> Test m a
forAllWith render gen = do
x <- Test . lift $ lift gen
withFrozenCallStack $ annotate (render x)
return x
annotate :: (Monad m, HasCallStack) => String -> Test m ()
annotate x = do
writeLog $ Annotation (getCaller callStack) x
annotateShow :: (Monad m, Show a, HasCallStack) => a -> Test m ()
annotateShow x = do
withFrozenCallStack $ annotate (showPretty x)
footnote :: Monad m => String -> Test m ()
footnote =
writeLog . Footnote
footnoteShow :: (Monad m, Show a) => a -> Test m ()
footnoteShow =
writeLog . Footnote . showPretty
discard :: Monad m => Test m a
discard =
Test . lift $ lift Gen.discard
failWith :: (Monad m, HasCallStack) => Maybe Diff -> String -> Test m a
failWith diff msg =
Test . ExceptT . pure . Left $ Failure (getCaller callStack) msg diff
failure :: (Monad m, HasCallStack) => Test m a
failure =
withFrozenCallStack $ failWith Nothing ""
success :: Monad m => Test m ()
success =
Test $ pure ()
assert :: (Monad m, HasCallStack) => Bool -> Test m ()
assert b =
if b then
success
else
withFrozenCallStack failure
infix 4 ===
(===) :: (Monad m, Eq a, Show a, HasCallStack) => a -> a -> Test m ()
(===) x y =
if x == y then
success
else
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) ""
liftEither :: (Monad m, Show x, HasCallStack) => Either x a -> Test m a
liftEither = \case
Left x ->
withFrozenCallStack $ failWith Nothing $ showPretty x
Right x ->
pure x
liftExceptT :: (Monad m, Show x, HasCallStack) => ExceptT x m a -> Test m a
liftExceptT m =
withFrozenCallStack liftEither =<< lift (runExceptT m)
liftCatch :: (MonadCatch m, HasCallStack) => m a -> Test m a
liftCatch m =
withFrozenCallStack liftEither =<< lift (tryAll m)
liftCatchIO :: (MonadIO m, HasCallStack) => IO a -> Test m a
liftCatchIO m =
withFrozenCallStack liftEither =<< liftIO (tryAll m)
withExceptT :: (Monad m, Show x, HasCallStack) => Test (ExceptT x m) a -> Test m a
withExceptT m =
withFrozenCallStack liftEither =<< runExceptT (distribute m)
withCatch :: (MonadCatch m, HasCallStack) => Test m a -> Test m a
withCatch m =
withFrozenCallStack liftEither =<< tryAll m
withResourceT :: MonadResourceBase m => Test (ResourceT m) a -> Test m a
withResourceT =
hoist runResourceT
$(deriveLift ''GroupName)
$(deriveLift ''PropertyName)
$(deriveLift ''PropertyConfig)
$(deriveLift ''TestLimit)
$(deriveLift ''ShrinkLimit)
$(deriveLift ''DiscardLimit)