{-# 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 = String -> Spec -> Spec
forall (outers :: [*]) inner.
String -> TestDefM outers inner () -> TestDefM outers inner ()
Syd.describe (GroupName -> String
Hedgehog.unGroupName (GroupName -> String) -> GroupName -> String
forall a b. (a -> b) -> a -> b
$ Group -> GroupName
Hedgehog.groupName Group
hedgehogGroup) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
  [(PropertyName, Property)]
-> ((PropertyName, Property) -> Spec) -> Spec
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Group -> [(PropertyName, Property)]
Hedgehog.groupProperties Group
hedgehogGroup) (((PropertyName, Property) -> Spec) -> Spec)
-> ((PropertyName, Property) -> Spec) -> Spec
forall a b. (a -> b) -> a -> b
$ \(PropertyName
propertyName, Property
property) -> do
    String -> Property -> Spec
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 = (() -> () -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((() -> () -> IO ()) -> IO ())
-> IO TestRunResult
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 = (() -> arg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((() -> arg -> IO ()) -> IO ())
-> IO TestRunResult
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 = (outerArgs -> innerArg -> Property)
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (outerArgs -> innerArg -> Property)
     -> Arg2 (outerArgs -> innerArg -> Property) -> IO ())
    -> IO ())
-> IO TestRunResult
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 :: (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 -> IO Seed
forall (m :: * -> *). MonadIO m => m Seed
Seed.random
      FixedSeed Int
i -> Seed -> IO Seed
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seed -> IO Seed) -> Seed -> IO Seed
forall a b. (a -> b) -> a -> b
$ Word64 -> Seed
Seed.from (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)

    TVar Word
exampleCounter <- Word -> IO (TVar Word)
forall a. a -> IO (TVar a)
newTVarIO Word
1
    let totalExamples :: Word
totalExamples = (Int -> Word
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 <- ((outerArgs -> innerArg -> IO ()) -> IO ())
-> (outerArgs -> innerArg -> IO (Report Result))
-> IO (Either SomeException (Report Result))
forall r outerArgs innerArg.
((outerArgs -> innerArg -> IO ()) -> IO ())
-> (outerArgs -> innerArg -> IO r) -> IO (Either SomeException r)
applyWrapper2 (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper ((outerArgs -> innerArg -> IO (Report Result))
 -> IO (Either SomeException (Report Result)))
-> (outerArgs -> innerArg -> IO (Report Result))
-> IO (Either SomeException (Report Result))
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 (TestLimit -> TerminationCriteria)
-> TestLimit -> TerminationCriteria
forall a b. (a -> b) -> a -> b
$ Int -> TestLimit
Hedgehog.TestLimit Int
testRunSettingMaxSuccess
              }

      PropertyConfig
-> Size
-> Seed
-> PropertyT IO ()
-> (Report Progress -> IO ())
-> IO (Report Result)
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 <- IO Word -> PropertyT IO Word
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Word -> PropertyT IO Word) -> IO Word -> PropertyT IO Word
forall a b. (a -> b) -> a -> b
$ TVar Word -> IO Word
forall a. TVar a -> IO a
readTVarIO TVar Word
exampleCounter
            IO () -> PropertyT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PropertyT IO ()) -> IO () -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ ProgressReporter
report ProgressReporter -> ProgressReporter
forall a b. (a -> b) -> a -> b
$ Word -> Word -> Progress
ProgressExampleStarting Word
totalExamples Word
exampleNr
            Timed ()
timedResult <- PropertyT IO () -> PropertyT IO (Timed ())
forall (m :: * -> *) a. MonadIO m => m a -> m (Timed a)
timeItT (PropertyT IO () -> PropertyT IO (Timed ()))
-> PropertyT IO () -> PropertyT IO (Timed ())
forall a b. (a -> b) -> a -> b
$ Property -> PropertyT IO ()
Hedgehog.propertyTest (outerArgs -> innerArg -> Property
hedgehogProp outerArgs
outer innerArg
inner)
            IO () -> PropertyT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PropertyT IO ()) -> IO () -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ ProgressReporter
report ProgressReporter -> ProgressReporter
forall a b. (a -> b) -> a -> b
$ Word -> Word -> Word64 -> Progress
ProgressExampleDone Word
totalExamples Word
exampleNr (Word64 -> Progress) -> Word64 -> Progress
forall a b. (a -> b) -> a -> b
$ Timed () -> Word64
forall a. Timed a -> Word64
timedTime Timed ()
timedResult
            IO () -> PropertyT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PropertyT IO ()) -> IO () -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Word -> (Word -> Word) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Word
exampleCounter Word -> Word
forall a. Enum a => a -> a
succ
            () -> PropertyT IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> PropertyT IO ()) -> () -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ Timed () -> ()
forall a. Timed a -> a
timedValue Timed ()
timedResult
        )
        (\Report Progress
_ -> () -> IO ()
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 -> (TestStatus, Maybe SomeException, Maybe Word,
 Maybe (Map [String] Int), Maybe Word, [String])
-> IO
     (TestStatus, Maybe SomeException, Maybe Word,
      Maybe (Map [String] Int), Maybe Word, [String])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestStatus
TestFailed, SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just SomeException
e, Maybe Word
forall a. Maybe a
Nothing, Maybe (Map [String] Int)
forall a. Maybe a
Nothing, Maybe Word
forall a. Maybe a
Nothing, [])
      Right Report Result
hedgehogReport -> do
        let Hedgehog.TestCount Int
testCountInt = Report Result -> TestCount
forall a. Report a -> TestCount
Hedgehog.reportTests Report Result
hedgehogReport
            numTests :: Maybe Word
numTests = Word -> Maybe Word
forall a. a -> Maybe a
Just (Word -> Maybe Word) -> Word -> Maybe Word
forall a b. (a -> b) -> a -> b
$ Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
testCountInt
            labelList :: [(LabelName, Label CoverCount)]
labelList =
              Map LabelName (Label CoverCount) -> [(LabelName, Label CoverCount)]
forall k a. Map k a -> [(k, a)]
M.toList
                (Map LabelName (Label CoverCount)
 -> [(LabelName, Label CoverCount)])
-> (Coverage CoverCount -> Map LabelName (Label CoverCount))
-> Coverage CoverCount
-> [(LabelName, Label CoverCount)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coverage CoverCount -> Map LabelName (Label CoverCount)
forall a. Coverage a -> Map LabelName (Label a)
Hedgehog.coverageLabels
                (Coverage CoverCount -> [(LabelName, Label CoverCount)])
-> Coverage CoverCount -> [(LabelName, Label CoverCount)]
forall a b. (a -> b) -> a -> b
$ Report Result -> Coverage CoverCount
forall a. Report a -> Coverage CoverCount
Hedgehog.reportCoverage Report Result
hedgehogReport

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

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