{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{-

This module unifies property based testing with Hedgehog and one-off tests.

-}
module Test.Tasty.Hedgehogx
  ( module Hedgehog,
    module Tasty,
    module Test.Tasty.HedgehogTest,

    -- * Tests definition
    prop,
    test,

    -- * Tests settings
    minTestsOk,
    noShrink,
    withSeed,

    -- * Running tests
    run,
    runOnly,

    -- * Assertions
    gotException,

    -- * Display
    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)

-- * TESTS AND PROPERTIES

-- | Create a Tasty test from a Hedgehog property
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)

-- | Create a Tasty test from a Hedgehog property called only once
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)

-- * SETTING TEST OPTIONS

-- | Set the minimum number of tests which must be successful for a property to pass
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)))

-- | Do not shrink failures
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)))

-- | Execute a property with a specific seed
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

-- * ASSERTIONS

-- | Assert that an exception is thrown
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

-- * REPORTING

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)

-- * GHCi run functions

-- | Run either a test tree (a test or a property) whether it is in IO or not
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

-- | Run only some tests by passing a tasty pattern
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"

-- | Typeclass to unify a simple test in a file like test_simple :: TestTree
--   and all the tests retrieved by tasty-discovery which have the type :: IO TestTree
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