{-# 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 :: 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)

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

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

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

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

-- * ASSERTIONS

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

-- * REPORTING

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)

-- * 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 :: 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

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

-- | 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure