Hedgehog.hs

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

module Test.Syd.Hedgehog (fromHedgehogGroup) where

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 hedgehogGroup = Syd.describe (Hedgehog.unGroupName $ Hedgehog.groupName hedgehogGroup) $
  forM_ (Hedgehog.groupProperties hedgehogGroup) $ \(propertyName, property) -> do
    it (Hedgehog.unPropertyName propertyName) property

instance IsTest Hedgehog.Property where
  type Arg1 Hedgehog.Property = ()
  type Arg2 Hedgehog.Property = ()
  runTest = runHedgehogProperty

runHedgehogProperty :: Hedgehog.Property -> Syd.TestRunSettings -> ((() -> () -> IO ()) -> IO ()) -> IO TestRunResult
runHedgehogProperty hedgehogProp TestRunSettings {..} wrapper = do
  let config =
        (Hedgehog.propertyConfig hedgehogProp)
          { Hedgehog.propertyDiscardLimit = Hedgehog.DiscardLimit testRunSettingMaxDiscardRatio,
            Hedgehog.propertyShrinkLimit = Hedgehog.ShrinkLimit testRunSettingMaxShrinks
          }
  let size = Hedgehog.Size testRunSettingMaxSize
  seed <- case testRunSettingSeed of
    RandomSeed -> Seed.random
    FixedSeed i -> pure $ Seed.from (fromIntegral i)
  errOrReport <- applyWrapper2 wrapper $ \() () ->
    Hedgehog.checkReport
      config
      size
      seed
      (Hedgehog.propertyTest hedgehogProp)
      (\_ -> pure ()) -- Don't report progress
  ( testRunResultStatus,
    testRunResultException,
    testRunResultNumTests,
    testRunResultLabels,
    testRunResultNumShrinks,
    testRunResultFailingInputs
    ) <- case errOrReport of
    Left e -> pure (TestFailed, Just e, Nothing, Nothing, Nothing, [])
    Right report -> do
      let Hedgehog.TestCount testCountInt = Hedgehog.reportTests report
          numTests = Just $ fromIntegral testCountInt
          labelList =
            M.toList
              . Hedgehog.coverageLabels
              $ Hedgehog.reportCoverage report

          labels =
            if null labelList
              then Nothing
              else
                Just
                  . M.fromList
                  . map
                    ( \(labelName, label) ->
                        ([Hedgehog.unLabelName labelName], Hedgehog.unCoverCount $ Hedgehog.labelAnnotation label)
                    )
                  $ labelList
      case Hedgehog.reportStatus report of
        Hedgehog.OK -> pure (TestPassed, Nothing, numTests, labels, Nothing, [])
        Hedgehog.GaveUp -> pure (TestFailed, Nothing, numTests, labels, Nothing, [])
        Hedgehog.Failed failureReport -> do
          s <-
            Hedgehog.renderResult
              Hedgehog.EnableColor
              Nothing
              report
          let Hedgehog.ShrinkCount shrinkCountInt = Hedgehog.failureShrinks failureReport
              numShrinks = Just $ fromIntegral shrinkCountInt
              exception = Just $ Left s
              inputs = map Hedgehog.failedValue $ Hedgehog.failureAnnotations failureReport
          pure (TestFailed, exception, numTests, labels, numShrinks, inputs) -- TODO
  let testRunResultRetries = Nothing
  let testRunResultGoldenCase = Nothing
  let testRunResultExtraInfo = Nothing
  let testRunResultClasses = Nothing
  let testRunResultTables = Nothing
  let testRunResultFlakinessMessage = Nothing

  pure TestRunResult {..}