{-# 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 :: TestName -> PropertyT IO () -> TestTree
prop TestName
name PropertyT IO ()
p =
let aModuleName :: TestName
aModuleName = TestName
HasCallStack => TestName
getModuleName
in (HasCallStack => TestTree) -> TestTree
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => TestTree) -> TestTree)
-> (HasCallStack => TestTree) -> TestTree
forall a b. (a -> b) -> a -> b
$ ModuleName -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Text -> ModuleName
ModuleName (TestName -> Text
forall a b. ConvertText a b => a -> b
toS TestName
aModuleName)) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
TestName -> Property -> TestTree
testProperty TestName
name (HasCallStack => PropertyT IO () -> Property
PropertyT IO () -> Property
Hedgehog.property PropertyT IO ()
p)
test :: HasCallStack => TestName -> PropertyT IO () -> TestTree
test :: TestName -> PropertyT IO () -> TestTree
test TestName
name PropertyT IO ()
p = (HasCallStack => TestTree) -> TestTree
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (Int -> TestTree -> TestTree
minTestsOk Int
1 (TestTree -> TestTree)
-> (TestTree -> TestTree) -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTree -> TestTree
noShrink (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ HasCallStack => TestName -> PropertyT IO () -> TestTree
TestName -> PropertyT IO () -> TestTree
prop TestName
name PropertyT IO ()
p)
minTestsOk :: Int -> TestTree -> TestTree
minTestsOk :: Int -> TestTree -> TestTree
minTestsOk Int
n = HedgehogTestLimit -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Maybe TestLimit -> HedgehogTestLimit
HedgehogTestLimit (TestLimit -> Maybe TestLimit
forall a. a -> Maybe a
Just (Int -> TestLimit
forall a. Enum a => Int -> a
toEnum Int
n :: TestLimit)))
noShrink :: TestTree -> TestTree
noShrink :: TestTree -> TestTree
noShrink = HedgehogShrinkLimit -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Maybe ShrinkLimit -> HedgehogShrinkLimit
HedgehogShrinkLimit (ShrinkLimit -> Maybe ShrinkLimit
forall a. a -> Maybe a
Just (ShrinkLimit
0 :: ShrinkLimit)))
withSeed :: Prelude.String -> TestTree -> TestTree
withSeed :: TestName -> TestTree -> TestTree
withSeed TestName
seed TestTree
tree =
case TestName -> Maybe HedgehogReplay
forall v. IsOption v => TestName -> Maybe v
parseValue TestName
seed of
Maybe HedgehogReplay
Nothing -> HasCallStack => TestName -> PropertyT IO () -> TestTree
TestName -> PropertyT IO () -> TestTree
prop (TestName
"cannot parse seed " TestName -> TestName -> TestName
forall a. Semigroup a => a -> a -> a
<> TestName
seed) PropertyT IO ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure
Just (HedgehogReplay
s :: HedgehogReplay) -> HedgehogReplay -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption HedgehogReplay
s TestTree
tree
gotException :: forall a. (HasCallStack, Show a) => a -> PropertyT IO ()
gotException :: a -> PropertyT IO ()
gotException a
a = (HasCallStack => PropertyT IO ()) -> PropertyT IO ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => PropertyT IO ()) -> PropertyT IO ())
-> (HasCallStack => PropertyT IO ()) -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ do
Either SomeException a
res <- IO (Either SomeException a)
-> PropertyT IO (Either SomeException a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
try (a -> IO a
forall a. a -> IO a
evaluate a
a) :: IO (Either SomeException a))
case Either SomeException a
res of
Left SomeException
_ -> Bool -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
assert Bool
True
Right a
_ -> Text -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
annotateShow (Text
"excepted an exception" :: Text) PropertyT IO () -> PropertyT IO () -> PropertyT IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> PropertyT IO ()
forall (m :: * -> *). (MonadTest m, HasCallStack) => Bool -> m ()
assert Bool
False
printDifference :: (MonadIO m, Show a, Show b, HasCallStack) => a -> b -> m ()
printDifference :: a -> b -> m ()
printDifference a
actual b
expected = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
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) Maybe (Coverage CoverCount)
forall a. Maybe a
Nothing Maybe Span
forall a. Maybe a
Nothing TestName
"" (a -> b -> Maybe Diff
forall a b. (Show a, Show b, HasCallStack) => a -> b -> Maybe Diff
failureDifference a
actual b
expected) []
TestName
report <- UseColor -> Maybe PropertyName -> Report Result -> m TestName
forall (m :: * -> *).
MonadIO m =>
UseColor -> Maybe PropertyName -> Report Result -> m TestName
renderResult UseColor
EnableColor Maybe PropertyName
forall a. Maybe a
Nothing (TestCount
-> DiscardCount -> Coverage CoverCount -> Result -> Report Result
forall a.
TestCount -> DiscardCount -> Coverage CoverCount -> a -> Report a
Report (Int -> TestCount
TestCount Int
0) (Int -> DiscardCount
DiscardCount Int
0) (Map LabelName (Label CoverCount) -> Coverage CoverCount
forall a. Map LabelName (Label a) -> Coverage a
Coverage Map LabelName (Label CoverCount)
forall a. Monoid a => a
mempty) (FailureReport -> Result
Failed FailureReport
failureReport))
Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putText ([Text] -> Text
T.unlines ([Text] -> Text) -> (TestName -> [Text]) -> TestName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
3 ([Text] -> [Text]) -> (TestName -> [Text]) -> TestName -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines (Text -> [Text]) -> (TestName -> Text) -> TestName -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestName -> Text
forall a b. ConvertText a b => a -> b
toS (TestName -> Text) -> TestName -> Text
forall a b. (a -> b) -> a -> b
$ TestName
report)
failureDifference :: (Show a, Show b, HasCallStack) => a -> b -> Maybe Diff
failureDifference :: a -> b -> Maybe Diff
failureDifference a
x b
y = (HasCallStack => Maybe Diff) -> Maybe Diff
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Maybe Diff) -> Maybe Diff)
-> (HasCallStack => Maybe Diff) -> Maybe Diff
forall a b. (a -> b) -> a -> b
$
case Value -> Value -> ValueDiff
valueDiff (Value -> Value -> ValueDiff)
-> Maybe Value -> Maybe (Value -> ValueDiff)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe Value
forall a. Show a => a -> Maybe Value
mkValue a
x Maybe (Value -> ValueDiff) -> Maybe Value -> Maybe ValueDiff
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> Maybe Value
forall a. Show a => a -> Maybe Value
mkValue b
y of
Maybe ValueDiff
Nothing ->
Maybe Diff
forall a. Maybe a
Nothing
Just ValueDiff
d ->
(HasCallStack => Maybe Diff) -> Maybe Diff
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Maybe Diff) -> Maybe Diff)
-> (HasCallStack => Maybe Diff) -> Maybe Diff
forall a b. (a -> b) -> a -> b
$
Diff -> Maybe Diff
forall a. a -> Maybe a
Just (Diff -> Maybe Diff) -> Diff -> Maybe Diff
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 :: a -> PropertyT m a
display a
a = (HasCallStack => PropertyT m a) -> PropertyT m a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack (a -> PropertyT m ()
forall (m :: * -> *) a.
(MonadTest m, Show a, HasCallStack) =>
a -> m ()
annotateShow a
a PropertyT m () -> a -> PropertyT m a
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> a
a)
run :: Runnable t => t -> IO ()
run :: t -> IO ()
run t
tests = t -> IO TestTree
forall t. Runnable t => t -> IO TestTree
runIt t
tests IO TestTree -> (TestTree -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TestTree -> IO ()
defaultMain (TestTree -> IO ()) -> (TestTree -> TestTree) -> TestTree -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTree -> TestTree
groupByModuleName
runOnly :: Runnable t => Text -> t -> IO ()
runOnly :: Text -> t -> IO ()
runOnly Text
p t
tests = do
TestName -> TestName -> IO ()
setEnv TestName
"TASTY_PATTERN" (Text -> TestName
forall a b. ConvertText a b => a -> b
toS Text
p)
t -> IO ()
forall t. Runnable t => t -> IO ()
run t
tests IO () -> IO () -> IO ()
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 = TestTree -> IO TestTree
forall (f :: * -> *) a. Applicative f => a -> f a
pure