{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test.Tasty.Hedgehogx
( module Hedgehog,
module Tasty,
module Test.Tasty.HedgehogTest,
prop,
test,
minTestsOk,
noShrink,
withSeed,
run,
runOnly,
gotException,
printDifference,
display,
)
where
import qualified Data.Text as T
import GHC.Stack
import Hedgehog hiding (test)
import Hedgehog.Gen as Hedgehog hiding (discard, print)
import Hedgehog.Internal.Config (UseColor (EnableColor))
import Hedgehog.Internal.Property (Coverage (..), Diff (..), DiscardCount (..), ShrinkCount (..), TestCount (..))
import Hedgehog.Internal.Report
import Hedgehog.Internal.Show (mkValue, valueDiff)
import Protolude hiding (SrcLoc, empty, toList, (.&.))
import System.Environment
import Test.Tasty as Tasty
import Test.Tasty.HedgehogTest
import Test.Tasty.Options as Tasty
import Test.Tasty.Providers as Tasty (singleTest)
import Test.Tasty.Runners as Tasty
( TestTree (..),
foldSingle,
foldTestTree,
trivialFold,
)
import Prelude (String)
prop :: HasCallStack => TestName -> PropertyT IO () -> TestTree
prop :: HasCallStack => TestName -> PropertyT IO () -> TestTree
prop TestName
name PropertyT IO ()
p =
let aModuleName :: TestName
aModuleName = HasCallStack => TestName
getModuleName
in forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ forall v. IsOption v => v -> TestTree -> TestTree
localOption (Text -> ModuleName
ModuleName (forall a b. ConvertText a b => a -> b
toS TestName
aModuleName)) forall a b. (a -> b) -> a -> b
$
TestName -> Property -> TestTree
testProperty TestName
name (HasCallStack => PropertyT IO () -> Property
Hedgehog.property PropertyT IO ()
p)
test :: HasCallStack => TestName -> PropertyT IO () -> TestTree
test :: HasCallStack => TestName -> PropertyT IO () -> TestTree
test TestName
name PropertyT IO ()
p = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (Int -> TestTree -> TestTree
minTestsOk Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTree -> TestTree
noShrink forall a b. (a -> b) -> a -> b
$ HasCallStack => TestName -> PropertyT IO () -> TestTree
prop TestName
name PropertyT IO ()
p)
minTestsOk :: Int -> TestTree -> TestTree
minTestsOk :: Int -> TestTree -> TestTree
minTestsOk Int
n = forall v. IsOption v => v -> TestTree -> TestTree
localOption (Maybe TestLimit -> HedgehogTestLimit
HedgehogTestLimit (forall a. a -> Maybe a
Just (forall a. Enum a => Int -> a
toEnum Int
n :: TestLimit)))
noShrink :: TestTree -> TestTree
noShrink :: TestTree -> TestTree
noShrink = forall v. IsOption v => v -> TestTree -> TestTree
localOption (Maybe ShrinkLimit -> HedgehogShrinkLimit
HedgehogShrinkLimit (forall a. a -> Maybe a
Just (ShrinkLimit
0 :: ShrinkLimit)))
withSeed :: Prelude.String -> TestTree -> TestTree
withSeed :: TestName -> TestTree -> TestTree
withSeed TestName
seed TestTree
tree =
case forall v. IsOption v => TestName -> Maybe v
parseValue TestName
seed of
Maybe HedgehogReplay
Nothing -> HasCallStack => TestName -> PropertyT IO () -> TestTree
prop (TestName
"cannot parse seed " forall a. Semigroup a => a -> a -> a
<> TestName
seed) forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure
Just (HedgehogReplay
s :: HedgehogReplay) -> forall v. IsOption v => v -> TestTree -> TestTree
localOption HedgehogReplay
s TestTree
tree
gotException :: forall a. (HasCallStack, Show a) => a -> PropertyT IO ()
gotException :: forall a. (HasCallStack, Show a) => a -> PropertyT IO ()
gotException a
a = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
Either SomeException a
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall e a. Exception e => IO a -> IO (Either e a)
try (forall a. a -> IO a
evaluate a
a) :: IO (Either SomeException a))
case Either SomeException a
res of
Left SomeException
_ -> forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
assert Bool
True
Right a
_ -> forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
annotateShow (Text
"excepted an exception" :: Text) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
assert Bool
False
printDifference :: (MonadIO m, Show a, Show b, HasCallStack) => a -> b -> m ()
printDifference :: forall (m :: * -> *) a b.
(MonadIO m, Show a, Show b, HasCallStack) =>
a -> b -> m ()
printDifference a
actual b
expected = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$ do
let failureReport :: FailureReport
failureReport = Size
-> Seed
-> ShrinkCount
-> Maybe (Coverage CoverCount)
-> Maybe Span
-> TestName
-> Maybe Diff
-> [Log]
-> FailureReport
mkFailure (Int -> Size
Size Int
0) (Word64 -> Word64 -> Seed
Seed Word64
0 Word64
0) (Int -> ShrinkCount
ShrinkCount Int
0) forall a. Maybe a
Nothing forall a. Maybe a
Nothing TestName
"" (forall a b. (Show a, Show b, HasCallStack) => a -> b -> Maybe Diff
failureDifference a
actual b
expected) []
TestName
report <- forall (m :: * -> *).
MonadIO m =>
UseColor -> Maybe PropertyName -> Report Result -> m TestName
renderResult UseColor
EnableColor forall a. Maybe a
Nothing (forall a.
TestCount -> DiscardCount -> Coverage CoverCount -> a -> Report a
Report (Int -> TestCount
TestCount Int
0) (Int -> DiscardCount
DiscardCount Int
0) (forall a. Map LabelName (Label a) -> Coverage a
Coverage forall a. Monoid a => a
mempty) (FailureReport -> Result
Failed FailureReport
failureReport))
forall (m :: * -> *). MonadIO m => Text -> m ()
putText ([Text] -> Text
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ TestName
report)
failureDifference :: (Show a, Show b, HasCallStack) => a -> b -> Maybe Diff
failureDifference :: forall a b. (Show a, Show b, HasCallStack) => a -> b -> Maybe Diff
failureDifference a
x b
y = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$
case Value -> Value -> ValueDiff
valueDiff forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Show a => a -> Maybe Value
mkValue a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Show a => a -> Maybe Value
mkValue b
y of
Maybe ValueDiff
Nothing ->
forall a. Maybe a
Nothing
Just ValueDiff
d ->
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack forall a b. (a -> b) -> a -> b
$
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TestName
-> TestName
-> TestName
-> TestName
-> TestName
-> ValueDiff
-> Diff
Diff TestName
"━━━ Failed (" TestName
"- lhs" TestName
") (" TestName
"+ rhs" TestName
") ━━━" ValueDiff
d
display :: (Show a, Monad m, HasCallStack) => a -> PropertyT m a
display :: forall a (m :: * -> *).
(Show a, Monad m, HasCallStack) =>
a -> PropertyT m a
display a
a = forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
annotateShow a
a forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
a)
run :: Runnable t => t -> IO ()
run :: forall t. Runnable t => t -> IO ()
run t
tests = forall t. Runnable t => t -> IO TestTree
runIt t
tests forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TestTree -> IO ()
defaultMain forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTree -> TestTree
groupByModuleName
runOnly :: Runnable t => Text -> t -> IO ()
runOnly :: forall t. Runnable t => Text -> t -> IO ()
runOnly Text
p t
tests = do
TestName -> TestName -> IO ()
setEnv TestName
"TASTY_PATTERN" (forall a b. ConvertText a b => a -> b
toS Text
p)
forall t. Runnable t => t -> IO ()
run t
tests forall a b. IO a -> IO b -> IO a
`finally` TestName -> IO ()
unsetEnv TestName
"TASTY_PATTERN"
class Runnable t where
runIt :: t -> IO TestTree
instance Runnable (IO TestTree) where
runIt :: IO TestTree -> IO TestTree
runIt IO TestTree
t = IO TestTree
t
instance Runnable TestTree where
runIt :: TestTree -> IO TestTree
runIt = forall (f :: * -> *) a. Applicative f => a -> f a
pure