{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module Test.Tasty.Hedgehogx (
module Hedgehog
, module Tasty
, gotException
, groupByModuleName
, minTestsOk
, mustBe
, noShrink
, prop
, run
, runOnly
, test
, withSeed
, (===)
) where
import Data.Maybe (fromJust)
import Data.MultiMap hiding (foldr)
import GHC.Stack
import Hedgehog as Hedgehog hiding (test, (===))
import qualified Hedgehog as Hedgehog ((===))
import Hedgehog.Gen as Hedgehog hiding (discard, print)
import Prelude (String)
import qualified Prelude as Prelude
import Protolude hiding (SrcLoc, empty, toList, (.&.))
import System.Environment
import Test.Tasty as Tasty
import Test.Tasty.Hedgehog as Tasty
import Test.Tasty.Options as Tasty
import Test.Tasty.Providers as Tasty (singleTest)
import Test.Tasty.Runners as Tasty (TestTree (..), foldSingle,
foldTestTree, trivialFold)
prop :: HasCallStack => TestName -> PropertyT IO () -> TestTree
prop name p =
let aModuleName = getModuleName
in withFrozenCallStack . localOption (ModuleName (toS aModuleName)) $
testProperty name (Hedgehog.property p)
test :: HasCallStack => TestName -> PropertyT IO () -> TestTree
test name p = withFrozenCallStack (minTestsOk 1 . noShrink $ prop name p)
gotException :: forall a . (HasCallStack, Show a) => a -> PropertyT IO ()
gotException a = withFrozenCallStack $ do
res <- liftIO (try (evaluate a) :: IO (Either SomeException a))
case res of
Left _ -> assert True
Right _ -> annotateShow ("excepted an exception" :: Text) >> assert False
infix 4 ===
(===) :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m ()
actual === expected = withFrozenCallStack $ do
displayActualAndExpectedValues actual expected
actual Hedgehog.=== expected
mustBe :: (MonadTest m, Eq a, Show a, HasCallStack) => a -> a -> m ()
actual `mustBe` expected = do
ok <- eval (actual == expected)
if ok then
success
else withFrozenCallStack $ do
displayActualAndExpectedValues actual expected
failure
displayActualAndExpectedValues :: (Show a, MonadTest m, HasCallStack) => a -> a -> m ()
displayActualAndExpectedValues actual expected =
withFrozenCallStack $ do
footnote makeSourceLink
footnote "\n"
footnote $ "Expected\n" <> (show expected)
footnote "\n"
footnote $ "Actual\n" <> (show actual)
makeSourceLink :: (HasCallStack) => String
makeSourceLink =
case getCallStack callStack of
[] -> "FAIL!"
(f, SrcLoc {..}) : _ ->
f ++ " error, called at " ++
foldr (++) ""
[ srcLocFile, ":"
, show srcLocStartLine, ":"
, show srcLocStartCol, " in "
, srcLocPackage, ":", srcLocModule
]
minTestsOk :: Int -> TestTree -> TestTree
minTestsOk n = localOption (HedgehogTestLimit (Just (toEnum n :: TestLimit)))
noShrink :: TestTree -> TestTree
noShrink = localOption (HedgehogShrinkLimit (Just (0 :: ShrinkLimit)))
withSeed :: Prelude.String -> TestTree -> TestTree
withSeed seed = localOption (fromJust (parseValue seed :: Maybe HedgehogReplay))
groupByModuleName :: TestTree -> TestTree
groupByModuleName testTree =
let grouped = assocs $ foldTestTree (trivialFold { foldSingle = \os n t ->
let (ModuleName aModuleName) = lookupOption os :: ModuleName
in insert (toS aModuleName) (setOptionSet os $ singleTest n t) empty
}) mempty testTree
in TestGroup "All" (uncurry TestGroup <$> grouped)
instance (Ord k) => Semigroup (MultiMap k v) where
(<>) m1 m2 = fromList (toList m1 <> toList m2)
instance (Ord k) => Monoid (MultiMap k v) where
mempty = empty
mappend = (<>)
setOptionSet :: OptionSet -> TestTree -> TestTree
setOptionSet os =
localOption (lookupOption os :: HedgehogTestLimit) .
localOption (lookupOption os :: HedgehogShrinkLimit) .
localOption (lookupOption os :: HedgehogReplay)
getModuleName :: HasCallStack => Prelude.String
getModuleName =
case getCallStack callStack of
((_, loc):_) -> srcLocModule loc
_ -> "root"
newtype ModuleName = ModuleName Text deriving (Eq, Show)
instance IsOption ModuleName where
defaultValue = ModuleName "root"
parseValue = fmap ModuleName . safeRead
optionName = pure "module-name"
optionHelp = pure "internal option used to group tests into the same module"
optionCLParser = mkFlagCLParser mempty (ModuleName "root")
run :: Runnable t => t -> IO ()
run tests = runIt tests >>= defaultMain . groupByModuleName
runOnly :: Runnable t => Text -> t -> IO ()
runOnly p tests = do
setEnv "TASTY_PATTERN" (toS p)
run tests `finally` unsetEnv "TASTY_PATTERN"
class Runnable t where
runIt :: t -> IO TestTree
instance Runnable (IO TestTree) where
runIt t = t
instance Runnable TestTree where
runIt = pure