{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Test.Syd.Hedgehog (fromHedgehogGroup) where

import Control.Concurrent.STM
import Control.Exception
import Control.Monad
import qualified Data.Map as M
import qualified Hedgehog
import qualified Hedgehog.Internal.Config as Hedgehog
import qualified Hedgehog.Internal.Property as Hedgehog
import qualified Hedgehog.Internal.Report as Hedgehog
import qualified Hedgehog.Internal.Runner as Hedgehog
import qualified Hedgehog.Internal.Seed as Seed
import Test.Syd as Syd

-- | Import an Hedgehog 'Hedgehog.Group' as a Sydtest 'Test.Syd.Spec'.
--
-- The reasoning behind this function is that, eventhough migration from hedgehog
-- to sydtest is usually very simple, you might depend on certain libraries
-- beyond your control that still use hedgehog.  In that case you want to be able
-- to still use those libraries but also use sydtest already.
fromHedgehogGroup :: Hedgehog.Group -> Syd.Spec
fromHedgehogGroup :: Group -> Spec
fromHedgehogGroup Group
hedgehogGroup = forall (outers :: [*]) inner.
String -> TestDefM outers inner () -> TestDefM outers inner ()
Syd.describe (GroupName -> String
Hedgehog.unGroupName forall a b. (a -> b) -> a -> b
$ Group -> GroupName
Hedgehog.groupName Group
hedgehogGroup) forall a b. (a -> b) -> a -> b
$
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Group -> [(PropertyName, Property)]
Hedgehog.groupProperties Group
hedgehogGroup) forall a b. (a -> b) -> a -> b
$ \(PropertyName
propertyName, Property
property) -> do
    forall (outers :: [*]) inner test.
(HasCallStack, IsTest test, Arg1 test ~ (), Arg2 test ~ inner) =>
String -> test -> TestDefM outers inner ()
it (PropertyName -> String
Hedgehog.unPropertyName PropertyName
propertyName) Property
property

instance IsTest Hedgehog.Property where
  type Arg1 Hedgehog.Property = ()
  type Arg2 Hedgehog.Property = ()
  runTest :: Property
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 Property -> Arg2 Property -> IO ()) -> IO ())
-> IO TestRunResult
runTest Property
func = forall outerArgs innerArg.
(outerArgs -> innerArg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((outerArgs -> innerArg -> IO ()) -> IO ())
-> IO TestRunResult
runHedgehogPropertyWithArg (\() () -> Property
func)

instance IsTest (arg -> Hedgehog.Property) where
  type Arg1 (arg -> Hedgehog.Property) = ()
  type Arg2 (arg -> Hedgehog.Property) = arg
  runTest :: (arg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (arg -> Property) -> Arg2 (arg -> Property) -> IO ())
    -> IO ())
-> IO TestRunResult
runTest arg -> Property
func = forall outerArgs innerArg.
(outerArgs -> innerArg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((outerArgs -> innerArg -> IO ()) -> IO ())
-> IO TestRunResult
runHedgehogPropertyWithArg (\() arg
a -> arg -> Property
func arg
a)

instance IsTest (outerArgs -> innerArg -> Hedgehog.Property) where
  type Arg1 (outerArgs -> innerArg -> Hedgehog.Property) = outerArgs
  type Arg2 (outerArgs -> innerArg -> Hedgehog.Property) = innerArg
  runTest :: (outerArgs -> innerArg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (outerArgs -> innerArg -> Property)
     -> Arg2 (outerArgs -> innerArg -> Property) -> IO ())
    -> IO ())
-> IO TestRunResult
runTest = forall outerArgs innerArg.
(outerArgs -> innerArg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((outerArgs -> innerArg -> IO ()) -> IO ())
-> IO TestRunResult
runHedgehogPropertyWithArg

runHedgehogPropertyWithArg ::
  forall outerArgs innerArg.
  (outerArgs -> innerArg -> Hedgehog.Property) ->
  TestRunSettings ->
  ProgressReporter ->
  ((outerArgs -> innerArg -> IO ()) -> IO ()) ->
  IO TestRunResult
runHedgehogPropertyWithArg :: forall outerArgs innerArg.
(outerArgs -> innerArg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((outerArgs -> innerArg -> IO ()) -> IO ())
-> IO TestRunResult
runHedgehogPropertyWithArg
  outerArgs -> innerArg -> Property
hedgehogProp
  TestRunSettings {Bool
Int
SeedSetting
testRunSettingSeed :: TestRunSettings -> SeedSetting
testRunSettingMaxSuccess :: TestRunSettings -> Int
testRunSettingMaxSize :: TestRunSettings -> Int
testRunSettingMaxDiscardRatio :: TestRunSettings -> Int
testRunSettingMaxShrinks :: TestRunSettings -> Int
testRunSettingGoldenStart :: TestRunSettings -> Bool
testRunSettingGoldenReset :: TestRunSettings -> Bool
testRunSettingGoldenReset :: Bool
testRunSettingGoldenStart :: Bool
testRunSettingMaxShrinks :: Int
testRunSettingMaxDiscardRatio :: Int
testRunSettingMaxSize :: Int
testRunSettingMaxSuccess :: Int
testRunSettingSeed :: SeedSetting
..}
  ProgressReporter
progressReporter
  (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper = do
    let report :: ProgressReporter
report = ProgressReporter -> ProgressReporter
reportProgress ProgressReporter
progressReporter
    let size :: Size
size = Int -> Size
Hedgehog.Size Int
testRunSettingMaxSize
    Seed
seed <- case SeedSetting
testRunSettingSeed of
      SeedSetting
RandomSeed -> forall (m :: * -> *). MonadIO m => m Seed
Seed.random
      FixedSeed Int
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Word64 -> Seed
Seed.from (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)

    TVar Word
exampleCounter <- forall a. a -> IO (TVar a)
newTVarIO Word
1
    let totalExamples :: Word
totalExamples = (forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Word) Int
testRunSettingMaxSuccess
    ProgressReporter
report Progress
ProgressTestStarting
    -- We make the same tradeoff here as in sydtest-hspec.
    -- We show ProgressExampleStarting for non-property tests as well so that
    -- we can attach timing information.
    -- In the case of hedgehog, non-property tests should be rarer so that
    -- should matter even less.
    Either SomeException (Report Result)
errOrReport <- forall r outerArgs innerArg.
((outerArgs -> innerArg -> IO ()) -> IO ())
-> (outerArgs -> innerArg -> IO r) -> IO (Either SomeException r)
applyWrapper2 (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper forall a b. (a -> b) -> a -> b
$ \outerArgs
outer innerArg
inner -> do
      let config :: PropertyConfig
config =
            (Property -> PropertyConfig
Hedgehog.propertyConfig (outerArgs -> innerArg -> Property
hedgehogProp outerArgs
outer innerArg
inner))
              { propertyDiscardLimit :: DiscardLimit
Hedgehog.propertyDiscardLimit = Int -> DiscardLimit
Hedgehog.DiscardLimit Int
testRunSettingMaxDiscardRatio,
                propertyShrinkLimit :: ShrinkLimit
Hedgehog.propertyShrinkLimit = Int -> ShrinkLimit
Hedgehog.ShrinkLimit Int
testRunSettingMaxShrinks,
                propertyTerminationCriteria :: TerminationCriteria
Hedgehog.propertyTerminationCriteria = TestLimit -> TerminationCriteria
Hedgehog.NoConfidenceTermination forall a b. (a -> b) -> a -> b
$ Int -> TestLimit
Hedgehog.TestLimit Int
testRunSettingMaxSuccess
              }

      forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
PropertyConfig
-> Size
-> Seed
-> PropertyT m ()
-> (Report Progress -> m ())
-> m (Report Result)
Hedgehog.checkReport
        PropertyConfig
config
        Size
size
        Seed
seed
        ( do
            Word
exampleNr <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> IO a
readTVarIO TVar Word
exampleCounter
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ProgressReporter
report forall a b. (a -> b) -> a -> b
$ Word -> Word -> Progress
ProgressExampleStarting Word
totalExamples Word
exampleNr
            (()
result, Word64
duration) <- forall (m :: * -> *) a. MonadIO m => m a -> m (a, Word64)
timeItDuration forall a b. (a -> b) -> a -> b
$ Property -> PropertyT IO ()
Hedgehog.propertyTest (outerArgs -> innerArg -> Property
hedgehogProp outerArgs
outer innerArg
inner)
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ProgressReporter
report forall a b. (a -> b) -> a -> b
$ Word -> Word -> Word64 -> Progress
ProgressExampleDone Word
totalExamples Word
exampleNr Word64
duration
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Word
exampleCounter forall a. Enum a => a -> a
succ
            forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
result
        )
        (\Report Progress
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) -- Don't report progress
    ProgressReporter
report Progress
ProgressTestDone
    ( TestStatus
testRunResultStatus,
      Maybe SomeException
testRunResultException,
      Maybe Word
testRunResultNumTests,
      Maybe (Map [String] Int)
testRunResultLabels,
      Maybe Word
testRunResultNumShrinks,
      [String]
testRunResultFailingInputs
      ) <- case Either SomeException (Report Result)
errOrReport of
      Left SomeException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestStatus
TestFailed, forall a. a -> Maybe a
Just SomeException
e, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing, [])
      Right Report Result
hedgehogReport -> do
        let Hedgehog.TestCount Int
testCountInt = forall a. Report a -> TestCount
Hedgehog.reportTests Report Result
hedgehogReport
            numTests :: Maybe Word
numTests = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
testCountInt
            labelList :: [(LabelName, Label CoverCount)]
labelList =
              forall k a. Map k a -> [(k, a)]
M.toList
                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Coverage a -> Map LabelName (Label a)
Hedgehog.coverageLabels
                forall a b. (a -> b) -> a -> b
$ forall a. Report a -> Coverage CoverCount
Hedgehog.reportCoverage Report Result
hedgehogReport

            labels :: Maybe (Map [String] Int)
labels =
              if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(LabelName, Label CoverCount)]
labelList
                then forall a. Maybe a
Nothing
                else
                  forall a. a -> Maybe a
Just
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map
                      ( \(LabelName
labelName, Label CoverCount
label) ->
                          ([LabelName -> String
Hedgehog.unLabelName LabelName
labelName], CoverCount -> Int
Hedgehog.unCoverCount forall a b. (a -> b) -> a -> b
$ forall a. Label a -> a
Hedgehog.labelAnnotation Label CoverCount
label)
                      )
                    forall a b. (a -> b) -> a -> b
$ [(LabelName, Label CoverCount)]
labelList
        case forall a. Report a -> a
Hedgehog.reportStatus Report Result
hedgehogReport of
          Result
Hedgehog.OK -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestStatus
TestPassed, forall a. Maybe a
Nothing, Maybe Word
numTests, Maybe (Map [String] Int)
labels, forall a. Maybe a
Nothing, [])
          Result
Hedgehog.GaveUp -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestStatus
TestFailed, forall a. Maybe a
Nothing, Maybe Word
numTests, Maybe (Map [String] Int)
labels, forall a. Maybe a
Nothing, [])
          Hedgehog.Failed FailureReport
failureReport -> do
            String
s <-
              forall (m :: * -> *).
MonadIO m =>
UseColor -> Maybe PropertyName -> Report Result -> m String
Hedgehog.renderResult
                UseColor
Hedgehog.EnableColor
                forall a. Maybe a
Nothing
                Report Result
hedgehogReport
            let Hedgehog.ShrinkCount Int
shrinkCountInt = FailureReport -> ShrinkCount
Hedgehog.failureShrinks FailureReport
failureReport
                numShrinks :: Maybe Word
numShrinks = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
shrinkCountInt
                exception :: Maybe SomeException
exception = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
SomeException forall a b. (a -> b) -> a -> b
$ String -> Assertion
ExpectationFailed String
s
                inputs :: [String]
inputs = forall a b. (a -> b) -> [a] -> [b]
map FailedAnnotation -> String
Hedgehog.failedValue forall a b. (a -> b) -> a -> b
$ FailureReport -> [FailedAnnotation]
Hedgehog.failureAnnotations FailureReport
failureReport
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestStatus
TestFailed, Maybe SomeException
exception, Maybe Word
numTests, Maybe (Map [String] Int)
labels, Maybe Word
numShrinks, [String]
inputs) -- TODO
    let testRunResultGoldenCase :: Maybe a
testRunResultGoldenCase = forall a. Maybe a
Nothing
    let testRunResultExtraInfo :: Maybe a
testRunResultExtraInfo = forall a. Maybe a
Nothing
    let testRunResultClasses :: Maybe a
testRunResultClasses = forall a. Maybe a
Nothing
    let testRunResultTables :: Maybe a
testRunResultTables = forall a. Maybe a
Nothing

    forall (f :: * -> *) a. Applicative f => a -> f a
pure TestRunResult {[String]
Maybe Word
Maybe (Map [String] Int)
Maybe SomeException
TestStatus
forall a. Maybe a
testRunResultStatus :: TestStatus
testRunResultException :: Maybe SomeException
testRunResultNumTests :: Maybe Word
testRunResultNumShrinks :: Maybe Word
testRunResultFailingInputs :: [String]
testRunResultLabels :: Maybe (Map [String] Int)
testRunResultClasses :: Maybe (Map String Int)
testRunResultTables :: Maybe (Map String (Map String Int))
testRunResultGoldenCase :: Maybe GoldenCase
testRunResultExtraInfo :: Maybe String
testRunResultTables :: forall a. Maybe a
testRunResultClasses :: forall a. Maybe a
testRunResultExtraInfo :: forall a. Maybe a
testRunResultGoldenCase :: forall a. Maybe a
testRunResultFailingInputs :: [String]
testRunResultNumShrinks :: Maybe Word
testRunResultLabels :: Maybe (Map [String] Int)
testRunResultNumTests :: Maybe Word
testRunResultException :: Maybe SomeException
testRunResultStatus :: TestStatus
..}