Skip.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}

module Test.Hedgehog.Skip where

import           Control.Monad (when)
import           Control.Monad.IO.Class (MonadIO(..))

import           Data.Foldable (for_)
import           Data.IORef (IORef)
import qualified Data.IORef as IORef

import           Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import qualified Hedgehog.Internal.Config as Config
import           Hedgehog.Internal.Property (Skip(..), ShrinkPath(..), skipCompress, skipDecompress)
import qualified Hedgehog.Internal.Property as Property
import qualified Hedgehog.Internal.Runner as Runner
import           Hedgehog.Internal.Report (Report(..), Result(..), FailureReport(..))

-- | We use this property to help test skipping. It keeps a log of every time it
--   runs in the 'IORef' it's passed.
--
--   It ignores its seed. It discards at size 1 and fails at size 2. When it
--   shrinks, it initially shrinks to something that will pass, and then to
--   something that will fail.
--
skipTestProperty :: IORef [(Size, Int, Bool, Bool)] -> Property
skipTestProperty logRef =
  withTests 5 . property $ do
    val@(curSize, _, shouldDiscard, shouldPass) <- forAll $ do
      curSize <- Gen.sized pure
      (shouldDiscard, shouldPass, nShrinks) <-
        (,,)
          <$> pure (curSize == 1)
          <*> Gen.shrink (\b -> if b then [] else [True]) (pure $ curSize /= 2)
          <*> Gen.shrink (\n -> reverse [0 .. n-1]) (pure 3)
      pure (curSize, nShrinks, shouldDiscard, shouldPass)

    -- Fail coverage to make sure we disable it when shrinking.
    cover 100 "Not 4" (curSize /= 4)

    liftIO $ IORef.modifyIORef' logRef (val :)
    when shouldDiscard discard
    assert shouldPass

checkProp :: MonadIO m => Property -> m (Report Result)
checkProp prop = do
  seed <- Config.resolveSeed Nothing
  liftIO $ Runner.checkReport
    (Property.propertyConfig prop)
    0
    seed
    (Property.propertyTest prop)
    (const $ pure ())

prop_SkipNothing :: Property
prop_SkipNothing =
  withTests 1 . property $ do
    logRef <- liftIO $ IORef.newIORef []
    let
      prop =
        withSkip "" $ skipTestProperty logRef

    report <- checkProp prop
    case reportStatus report of
      Failed f -> do
        failureShrinks f === 3
        failureShrinkPath f === ShrinkPath [1, 1, 1]

      _ -> do
        annotateShow report
        failure

    logs <- liftIO $ reverse <$> IORef.readIORef logRef
    logs ===
      [ (0, 3, False, True)
      , (1, 3, True, True)
      , (2, 3, False, False)
      , (2, 3, False, True)
      , (2, 2, False, False)
      , (2, 2, False, True)
      , (2, 1, False, False)
      , (2, 1, False, True)
      , (2, 0, False, False)
      , (2, 0, False, True)
      ]

prop_SkipToFailingTest :: Property
prop_SkipToFailingTest =
  withTests 1 . property $ do
    logRef <- liftIO $ IORef.newIORef []
    let
      prop =
        withSkip "3" $ skipTestProperty logRef

    report <- checkProp prop
    case reportStatus report of
      Failed f -> do
        failureShrinks f === 3
        failureShrinkPath f === ShrinkPath [1, 1, 1]

      _ ->
        failure

    logs <- liftIO $ reverse <$> IORef.readIORef logRef
    logs ===
      [ (2, 3, False, False)
      , (2, 3, False, True)
      , (2, 2, False, False)
      , (2, 2, False, True)
      , (2, 1, False, False)
      , (2, 1, False, True)
      , (2, 0, False, False)
      , (2, 0, False, True)
      ]

prop_SkipPastFailingTest :: Property
prop_SkipPastFailingTest =
  withTests 1 . property $ do
    logRef <- liftIO $ IORef.newIORef []
    let
      prop =
        withSkip "4" $ skipTestProperty logRef

    report <- checkProp prop
    reportStatus report === OK

    logs <- liftIO $ reverse <$> IORef.readIORef logRef
    logs === [(3, 3, False, True), (4, 3, False, True)]

prop_SkipToNoShrink :: Property
prop_SkipToNoShrink =
  withTests 1 . property $ do
    logRef <- liftIO $ IORef.newIORef []
    let
      prop =
        withSkip "3:" $ skipTestProperty logRef

    report <- checkProp prop
    case reportStatus report of
      Failed f -> do
        failureShrinks f === 0
        failureShrinkPath f === Property.ShrinkPath []

      _ ->
        failure

    logs <- liftIO $ reverse <$> IORef.readIORef logRef
    logs === [(2, 3, False, False)]

prop_SkipToFailingShrink :: Property
prop_SkipToFailingShrink =
  withTests 1 . property $ do
    logRef <- liftIO $ IORef.newIORef []
    let
      prop =
        withSkip "3:b2" $ skipTestProperty logRef

    report <- checkProp prop
    case reportStatus report of
      Failed f -> do
        failureShrinks f === 2
        failureShrinkPath f === Property.ShrinkPath [1, 1]

      _ ->
        failure

    logs <- liftIO $ reverse <$> IORef.readIORef logRef
    logs === [(2, 3, False, False), (2, 2, False, False), (2, 1, False, False)]

prop_SkipToPassingShrink :: Property
prop_SkipToPassingShrink =
  withTests 1 . property $ do
    logRef <- liftIO $ IORef.newIORef []
    let
      prop =
        withSkip "3:bA" $ skipTestProperty logRef

    report <- checkProp prop
    reportStatus report === OK

    logs <- liftIO $ reverse <$> IORef.readIORef logRef
    logs === [(2, 3, False, False), (2, 2, False, False), (2, 2, False, True)]

prop_SkipToReportedShrink :: Property
prop_SkipToReportedShrink =
  withTests 1 . property $ do
    logRef <- liftIO $ IORef.newIORef []

    report1 <- checkProp $ skipTestProperty logRef
    failure1 <- case reportStatus report1 of
      Failed f -> pure f
      _ -> do
        annotateShow report1
        failure

    let
      skip = SkipToShrink (reportTests report1)
                          (reportDiscards report1)
                          (failureShrinkPath failure1)


    report2 <- checkProp $ withSkip skip $ skipTestProperty logRef
    failure2 <- case reportStatus report2 of
      Failed f -> pure f
      _ -> do
        annotateShow report2
        failure

    failure1 === failure2

    reportTests report1 === 2
    reportTests report2 === 2
    reportDiscards report1 === 1
    reportDiscards report2 === 1

genSkip :: Gen Skip
genSkip =
  let
    range =
      Range.linear 0 100

    genTestCount =
      Property.TestCount <$> Gen.int range

    genDiscardCount =
      Property.DiscardCount <$> Gen.int range

    genShrinkPath =
      Property.ShrinkPath <$> Gen.list range (Gen.int range)
  in
    Gen.choice
      [ pure SkipNothing
      , SkipToTest <$> genTestCount <*> genDiscardCount
      , SkipToShrink <$> genTestCount <*> genDiscardCount <*> genShrinkPath
      ]

-- | Test that `skipCompress` and `skipDecompress` roundtrip.
prop_compressSkip :: Property
prop_compressSkip =
  property $ do
    skip <- forAll genSkip
    tripping skip Property.skipCompress Property.skipDecompress

-- | Demonstrate some example compressions.
--
--   In general it's probably fine for compressions to change between hedgehog
--   versions. There's not much reason to share them or save them long-term. So
--   breaking this test isn't necessarily a problem, if it's done deliberately.
--
--   But it's useful to have examples, to avoid accidentally changing the
--   compression format and to demonstrate edge cases.
prop_compressDecompressExamples :: Property
prop_compressDecompressExamples =
  withTests 1 . property $ do
    let
      -- Each test case has a Skip, the result of compressing it, and some other
      -- strings that would decompress to the same Skip.
      testCases =
        [ (SkipNothing, "", [])
        , (SkipToTest 3 0, "3", ["03", "003", "3/0", "03/00"])
        , (SkipToTest 197 1, "197/1", ["0197/1", "00197/01"])
        , ( SkipToShrink 5 0 $ Property.ShrinkPath [2, 3, 0]
          , "5:cDa"
          , ["5:CdA", "05:c1b0D1A1"]
          )
        , ( SkipToShrink 21 3 $ Property.ShrinkPath [5, 3, 27, 27, 26]
          , "21/3:fDbb2BA"
          , ["21/3:fDbbBBba"]
          )
        ]

    for_ testCases $ \(skip, compressed, otherCompressions) -> do
      skipCompress skip === compressed
      for_ (compressed : otherCompressions) $ \c ->
        skipDecompress c === Just skip

tests :: IO Bool
tests =
  checkParallel $$(discover)