skeletest 0.3.5 → 0.3.6

raw patch · 13 files changed

+426/−162 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• README.md +9/−0
• skeletest.cabal +2/−1
• src/Skeletest/Internal/Error.hs +3/−3
• src/Skeletest/Internal/Paths.hs +19/−1
• src/Skeletest/Internal/Preprocessor.hs +6/−5
• src/Skeletest/Internal/Spec/Output.hs +3/−3
• src/Skeletest/Internal/TestRunner.hs +6/−2
• src/Skeletest/Prop/Internal.hs +165/−126
• test/Skeletest/AssertionsSpec.hs +1/−20
• test/Skeletest/PropSpec.hs +109/−1
• test/Skeletest/TestUtils/CallStack.hs +29/−0
• test/Skeletest/__snapshots__/PropSpec.snap.md +66/−0

@@ -1,3 +1,11 @@+## v0.3.6++Runtime changes:+* Render exceptions in property tests the same as unit tests+* If property configuration (e.g. `Prop.setDiscardLimit`) occurs after `forAll` or IO actions, it now errors instead of silently being ignored+* Support `MonadFail` in `prop`+* Add `SKELETEST_TEST_ROOT` env var+ ## v0.3.5  Runtime changes:

@@ -437,6 +437,15 @@  * `main`: Specify the main module/function, as either `OtherMain.otherMainFunc`, `OtherMain` (equivalent to `OtherMain.main`), or `otherMainFunc` (equivalent to `Main.otherMainFunc`). Generally only useful with the `-main-is` GHC option. +### Environment variables++Skeletest respects the following environment variables at runtime:++* `SKELETEST_TEST_ROOT`: How to derive the root of the test tree, used for reading files during test execution (e.g. snapshot files). Can be set to one of the following:+  * `BUILD_DIR`: (default) The CWD when running the preprocessor+  * `CWD`: The CWD at runtime+  * Otherwise, the path to use as the root+ ### Hooks  Skeletest lets you hook into specific parts of test execution. Skeletest currently supports the following hooks:

@@ -1,7 +1,7 @@ cabal-version: 3.0  name: skeletest-version: 0.3.5+version: 0.3.6 synopsis: Batteries-included, opinionated test framework description: Batteries-included, opinionated test framework. See README.md for more details. homepage: https://github.com/brandonchinn178/skeletest#readme@@ -134,6 +134,7 @@     Skeletest.PluginSpec     Skeletest.PredicateSpec     Skeletest.PropSpec+    Skeletest.TestUtils.CallStack     Skeletest.TestUtils.Integration   build-depends:       base

@@ -17,10 +17,10 @@     CompilationError (Maybe GHC.SrcSpan) Text   | -- | An error in a situation that should never happen, and indicates a bug.     InvariantViolation Text-  | TestInfoNotFound   | CliFlagNotFound Text   | FixtureCircularDependency [Text]   | SnapshotFileCorrupted FilePath+  | PropConfigAfterIO   deriving (Show)  instance Exception SkeletestError where@@ -37,14 +37,14 @@           [ "Invariant violation: " <> msg           , "**** This is a skeletest bug. Please report it at https://github.com/brandonchinn178/skeletest/issues"           ]-      TestInfoNotFound ->-        "Could not find test info"       CliFlagNotFound name ->         "CLI flag '" <> name <> "' was not registered. Did you add it to cliFlags in Main.hs?"       FixtureCircularDependency fixtures ->         "Found circular dependency when resolving fixtures: " <> Text.intercalate " -> " fixtures       SnapshotFileCorrupted fp ->         "Snapshot file was corrupted: " <> Text.pack fp+      PropConfigAfterIO ->+        "Property configuration function must be done before any forAll or IO actions"  skeletestPluginError :: Maybe GHC.SrcSpan -> String -> a skeletestPluginError mloc = impureThrow . CompilationError mloc . Text.pack

@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ module Skeletest.Internal.Paths (   setOriginalDirectory,   readTestFile,@@ -7,6 +9,8 @@ import Data.Text (Text) import Data.Text.IO qualified as Text import Skeletest.Internal.Error (invariantViolation)+import System.Directory (getCurrentDirectory)+import System.Environment (lookupEnv) import System.FilePath ((</>)) import System.IO.Unsafe (unsafePerformIO) @@ -14,8 +18,22 @@ originalDirectoryRef = unsafePerformIO $ newIORef (invariantViolation "Original directory not set") {-# NOINLINE originalDirectoryRef #-} +data TestRoot = TestRootBuildDir | TestRootCWD | TestRoot FilePath+ setOriginalDirectory :: FilePath -> IO ()-setOriginalDirectory = writeIORef originalDirectoryRef+setOriginalDirectory buildDir = do+  testRoot <-+    lookupEnv "SKELETEST_TEST_ROOT" >>= \case+      Nothing -> pure TestRootBuildDir+      Just "BUILD_DIR" -> pure TestRootBuildDir+      Just "CWD" -> pure TestRootCWD+      Just fp -> pure $ TestRoot fp+  root <-+    case testRoot of+      TestRootBuildDir -> pure buildDir+      TestRootCWD -> getCurrentDirectory+      TestRoot fp -> pure fp+  writeIORef originalDirectoryRef root  readTestFile :: FilePath -> IO Text readTestFile fp = do

@@ -45,12 +45,13 @@ encodeOptions = Text.pack . show  decodeOptions :: Text -> Either Text Options-decodeOptions =-  maybe (Left "Could not decode skeletest-preprocessor options") Right-    . readMaybe-    . Text.unpack-    . unquote+decodeOptions = readEither . unquote  where+  readEither s =+    maybe (Left $ "Could not decode skeletest-preprocessor options: " <> s) Right+      . readMaybe+      . Text.unpack+      $ s   unquote s =     case Text.stripPrefix "\"" s >>= Text.stripSuffix "\"" of       Just s' -> Text.replace "\\\"" "\"" s'

@@ -95,15 +95,15 @@       try (readTestFile path) >>= \case         Right srcFile           | Just line <- getLineNum lineNum srcFile -> pure $ Right line-          | otherwise -> pure $ Left "<line does not exist>"-        Left (_ :: SomeException) -> pure $ Left "<could not open file>"+          | otherwise -> pure $ Left $ "<line does not exist: " <> path <> ":" <> show lineNum <> ">"+        Left (_ :: SomeException) -> pure $ Left $ "<could not open file: " <> path <> ">"     let (srcLine, pointerLine) =           case mLine of             Right line ->               ( line               , Text.replicate (startCol - 1) " " <> Text.replicate (endCol - startCol) "^"               )-            Left e -> (e, "")+            Left e -> (Text.pack e, "")      pure . Text.intercalate "\n" $       [ Text.pack path <> ":" <> (Text.pack . show) lineNum <> ":"

@@ -13,6 +13,7 @@   testResultPass,   testResultFromAssertionFail,   testResultFromError,+  testResultFromErrorWith,    -- * AssertionFail   AssertionFail (..),@@ -88,8 +89,11 @@       }  testResultFromError :: SomeException -> IO TestResult-testResultFromError e = do-  msg <- renderMsg+testResultFromError = testResultFromErrorWith id++testResultFromErrorWith :: (Text -> Text) -> SomeException -> IO TestResult+testResultFromErrorWith f e = do+  msg <- f <$> renderMsg   pure     TestResult       { testResultSuccess = False

@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}  module Skeletest.Prop.Internal (@@ -32,6 +33,7 @@ ) where  import Control.Monad (ap)+import Control.Monad.Catch qualified as MonadCatch import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Class qualified as Trans import Control.Monad.Trans.Reader qualified as Trans@@ -47,17 +49,21 @@ import Hedgehog.Internal.Seed qualified as Hedgehog.Seed import Hedgehog.Internal.Source qualified as Hedgehog import Skeletest.Internal.CLI (FlagSpec (..), IsFlag (..), getFlag)-import Skeletest.Internal.TestInfo (getTestInfo)+import Skeletest.Internal.Error (SkeletestError (..))+import Skeletest.Internal.TestInfo (TestInfo, getTestInfo) import Skeletest.Internal.TestRunner (   AssertionFail (..),+  FailContext,   TestResult (..),   TestResultMessage (..),   Testable (..),+  testResultFromAssertionFail,+  testResultFromErrorWith,   testResultPass,  ) import Skeletest.Internal.Utils.Color qualified as Color import Text.Read (readEither, readMaybe)-import UnliftIO.Exception (throwIO)+import UnliftIO.Exception (SomeException, fromException, throwIO, toException) import UnliftIO.IORef (IORef, newIORef, readIORef, writeIORef)  #if !MIN_VERSION_base(4, 20, 0)@@ -72,9 +78,10 @@  data PropertyM a   = PropertyPure [PropertyConfig] a-  | PropertyIO [PropertyConfig] (Trans.ReaderT FailureRef (Hedgehog.PropertyT IO) a)+  | PropertyIO [PropertyConfig] (PropertyIO a) -type FailureRef = IORef (Maybe AssertionFail)+type FailureRef = IORef (Maybe SomeException)+type PropertyIO a = Trans.ReaderT FailureRef (Hedgehog.PropertyT IO) a  instance Functor PropertyM where   fmap f = \case@@ -92,17 +99,20 @@     PropertyIO cfg1 $ do       a <- fa       case k a of-        PropertyPure _ b -> pure b+        PropertyPure [] b -> pure b+        PropertyPure _ _ -> throwIO PropConfigAfterIO         PropertyIO _ mb -> mb instance MonadIO PropertyM where   liftIO = PropertyIO [] . liftIO+instance MonadFail PropertyM where+  fail = liftIO . fail  instance Testable PropertyM where   runTestable = runProperty   context msg m = PropertyIO [] (Hedgehog.annotate msg) >> m   throwFailure e = PropertyIO [] $ do     failureRef <- Trans.ask-    writeIORef failureRef (Just e)+    writeIORef failureRef (Just $ toException e)     Trans.lift Hedgehog.failure  propConfig :: PropertyConfig -> Property@@ -164,125 +174,100 @@ runProperty = \case   PropertyPure cfg () -> runProperty $ PropertyIO cfg (pure ())   PropertyIO cfg m -> do-    failureRef <- newIORef Nothing     (seed, extraConfig) <- loadPropFlags-    report <--      Hedgehog.checkReport-        (resolveConfig $ cfg <> extraConfig)-        0-        seed-        (Trans.runReaderT m failureRef)-        reportProgress--    let-      Hedgehog.TestCount testCount = Hedgehog.reportTests report-      Hedgehog.DiscardCount discards = Hedgehog.reportDiscards report-      Hedgehog.Coverage coverage = Hedgehog.reportCoverage report+    let cfg' = resolveConfig $ cfg <> extraConfig+    (prop, getException) <- fromPropertyIO m+    report <- Hedgehog.checkReport cfg' size seed prop reportProgress +    testInfo <- getTestInfo     case Hedgehog.reportStatus report of-      Hedgehog.OK ->-        pure-          testResultPass-            { testResultMessage =-                TestResultMessageInline . Color.gray . Text.pack . List.intercalate "\n" . concat $-                  [ [show testCount <> " tests, " <> show discards <> " discards"]-                  , renderCoverage coverage testCount-                  ]-            }-      Hedgehog.GaveUp -> do-        testInfo <- getTestInfo-        throwIO-          AssertionFail-            { testInfo-            , testFailMessage =-                Text.pack . List.intercalate "\n" $-                  [ "Gave up after " <> show discards <> " discards."-                  , "Passed " <> show testCount <> " tests."-                  ]-            , testFailContext = []-            , callStack = GHC.fromCallSiteList []-            }-      Hedgehog.Failed Hedgehog.FailureReport{..} ->-        readIORef failureRef >>= \case-          Nothing -> do-            testInfo <- getTestInfo-            throwIO-              AssertionFail-                { testInfo-                , testFailMessage = Text.pack failureMessage-                , testFailContext = []-                , callStack = toCallStack failureLocation-                }-          Just failure -> do-            let-              info =-                map Text.pack . concat $-                  [-                    [ "Failed after " <> show testCount <> " tests."-                    , "Rerun with --seed=" <> renderSeed report <> " to reproduce."-                    , ""-                    ]-                  , [ let loc =-                            case failedSpan of-                              Just Hedgehog.Span{..} ->-                                List.intercalate ":" $-                                  [ spanFile-                                  , show . Hedgehog.unLineNo $ spanStartLine-                                  , show . Hedgehog.unColumnNo $ spanStartColumn-                                  ]-                              Nothing -> "<unknown loc>"-                       in loc <> " ==> " <> failedValue-                    | Hedgehog.FailedAnnotation{..} <- failureAnnotations-                    ]-                  ]+      Hedgehog.OK -> pure $ toTestResultPass report+      Hedgehog.GaveUp -> testResultFromAssertionFail $ fromGaveUpFailure testInfo report+      Hedgehog.Failed failureReport -> do+        -- Get an 'Either AssertionFail SomeException'+        let resolveException = \case+              Nothing -> Left $ fromHedgehogFailure testInfo failureReport+              Just e -> maybe (Right e) Left $ fromException e+        exc <- resolveException <$> getException -            throwIO-              failure-                { testFailContext =-                    -- N.B. testFailContext is reversed!-                    failure.testFailContext <> reverse info-                }+        -- Add hedgehog-specific context to the failure+        let info = getExtraTestContext report failureReport+        case exc of+          Left failure ->+            testResultFromAssertionFail+              -- N.B. testFailContext is reversed!+              failure{testFailContext = failure.testFailContext <> reverse info}+          Right err -> do+            let addInfo msg = msg <> "\n\n" <> Text.unlines info+            testResultFromErrorWith addInfo err  where+  size = 0   reportProgress _ = pure ()-  renderSeed report =-    let Hedgehog.Seed value gamma = Hedgehog.reportSeed report-     in show value <> ":" <> show gamma-  renderCoverage coverage testCount =-    let columns =-          [ (name, percentStr, percentBar)-          | Hedgehog.MkLabel{..} <- List.sortOn Hedgehog.labelLocation $ Map.elems coverage-          , let-              Hedgehog.LabelName name = labelName-              Hedgehog.CoverCount count = labelAnnotation-              percent = round $ fromIntegral count / fromIntegral testCount * (100 :: Double)-              percentStr = show percent <> "%"-              percentBar = renderPercentBar percent-          ]-        (maxNameLen, maxPercentLen) =-          foldr-            ( \(name, percent, _) (nameAcc, percentAcc) ->-                (max (length name) nameAcc, max (length percent) percentAcc)-            )-            (0, 0)-            columns-     in [ rjust maxNameLen name <> " " <> rjust maxPercentLen percentStr <> " " <> percentBar-        | (name, percentStr, percentBar) <- columns++loadPropFlags :: IO (Hedgehog.Seed, [PropertyConfig])+loadPropFlags = do+  PropSeedFlag mSeed <- getFlag+  seed <- maybe Hedgehog.Seed.random pure mSeed++  PropLimitFlag mLimit <- getFlag++  let extraConfig =+        [ SetTestLimit <$> mLimit         ]-  rjust n s = replicate (n - length s) ' ' <> s-  renderPercentBar percent =-    -- render percentage bar 20 characters wide-    let (n, r) = percent `divMod` 5-     in concat-          [ replicate n '█'-          , case r of-              0 -> ""-              1 -> "▏"-              2 -> "▍"-              3 -> "▌"-              4 -> "▊"-              _ -> "" -- unreachable-          , replicate (20 - n - (if r == 0 then 0 else 1)) '·'+  pure (seed, catMaybes extraConfig)++fromPropertyIO :: PropertyIO a -> IO (Hedgehog.PropertyT IO a, IO (Maybe SomeException))+fromPropertyIO m = do+  failureRef <- newIORef Nothing+  let run =+        (`Trans.runReaderT` failureRef)+          . (`MonadCatch.catch` \e -> writeIORef failureRef (Just e) *> Hedgehog.failure)+          $ m+      getException = readIORef failureRef+  pure (run, getException)++toTestResultPass :: Hedgehog.Report Hedgehog.Result -> TestResult+toTestResultPass report =+  testResultPass+    { testResultMessage =+        TestResultMessageInline . Color.gray . Text.pack . List.intercalate "\n" . concat $+          [ [show testCount <> " tests, " <> show discards <> " discards"]+          , renderCoverage report.reportCoverage testCount           ]+    }+ where+  Hedgehog.TestCount testCount = report.reportTests+  Hedgehog.DiscardCount discards = report.reportDiscards++fromGaveUpFailure :: TestInfo -> Hedgehog.Report Hedgehog.Result -> AssertionFail+fromGaveUpFailure testInfo report =+  AssertionFail+    { testInfo+    , testFailMessage =+        Text.pack . List.intercalate "\n" $+          [ "Gave up after " <> show discards <> " discards."+          , "Passed " <> show testCount <> " tests."+          ]+    , testFailContext = []+    , callStack = GHC.fromCallSiteList []+    }+ where+  Hedgehog.TestCount testCount = report.reportTests+  Hedgehog.DiscardCount discards = report.reportDiscards++-- | Convert a Hedgehog failure to AssertionFail.+--+-- Only happens if one of Hedgehog's functions failed using the failure mode in+-- PropertyT. All IO exceptions are handled in 'fromPropertyIO'.+fromHedgehogFailure :: TestInfo -> Hedgehog.FailureReport -> AssertionFail+fromHedgehogFailure testInfo Hedgehog.FailureReport{..} =+  AssertionFail+    { testInfo+    , testFailMessage = Text.pack failureMessage+    , testFailContext = []+    , callStack = toCallStack failureLocation+    }+ where   toCallStack mSpan =     GHC.fromCallSiteList $       case mSpan of@@ -300,17 +285,71 @@                   }            in [("<unknown>", loc)] -loadPropFlags :: IO (Hedgehog.Seed, [PropertyConfig])-loadPropFlags = do-  PropSeedFlag mSeed <- getFlag-  seed <- maybe Hedgehog.Seed.random pure mSeed--  PropLimitFlag mLimit <- getFlag+getExtraTestContext :: Hedgehog.Report Hedgehog.Result -> Hedgehog.FailureReport -> FailContext+getExtraTestContext report Hedgehog.FailureReport{..} =+  map Text.pack . concatSections $+    [+      [ "Failed after " <> show testCount <> " tests."+      , "Rerun with --seed=" <> seed <> " to reproduce."+      ]+    , [ let loc =+              case failedSpan of+                Just Hedgehog.Span{..} ->+                  List.intercalate ":" $+                    [ spanFile+                    , show . Hedgehog.unLineNo $ spanStartLine+                    , show . Hedgehog.unColumnNo $ spanStartColumn+                    ]+                Nothing -> "<unknown loc>"+         in loc <> " ==> " <> failedValue+      | Hedgehog.FailedAnnotation{..} <- failureAnnotations+      ]+    ]+ where+  Hedgehog.TestCount testCount = report.reportTests+  seed =+    let Hedgehog.Seed value gamma = report.reportSeed+     in show value <> ":" <> show gamma+  concatSections = concat . List.intersperse [""] . filter (not . null) -  let extraConfig =-        [ SetTestLimit <$> mLimit+renderCoverage :: Hedgehog.Coverage Hedgehog.CoverCount -> Int -> [String]+renderCoverage (Hedgehog.Coverage coverage) testCount =+  let columns =+        [ (name, percentStr, percentBar)+        | Hedgehog.MkLabel{..} <- List.sortOn Hedgehog.labelLocation $ Map.elems coverage+        , let+            Hedgehog.LabelName name = labelName+            Hedgehog.CoverCount count = labelAnnotation+            percent = round $ fromIntegral count / fromIntegral testCount * (100 :: Double)+            percentStr = show percent <> "%"+            percentBar = renderPercentBar percent         ]-  pure (seed, catMaybes extraConfig)+      (maxNameLen, maxPercentLen) =+        foldr+          ( \(name, percent, _) (nameAcc, percentAcc) ->+              (max (length name) nameAcc, max (length percent) percentAcc)+          )+          (0, 0)+          columns+   in [ rjust maxNameLen name <> " " <> rjust maxPercentLen percentStr <> " " <> percentBar+      | (name, percentStr, percentBar) <- columns+      ]+ where+  rjust n s = replicate (n - length s) ' ' <> s+  renderPercentBar percent =+    -- render percentage bar 20 characters wide+    let (n, r) = percent `divMod` 5+     in concat+          [ replicate n '█'+          , case r of+              0 -> ""+              1 -> "▏"+              2 -> "▍"+              3 -> "▌"+              4 -> "▊"+              _ -> "" -- unreachable+          , replicate (20 - n - (if r == 0 then 0 else 1)) '·'+          ]  {----- Test -----} 

@@ -5,12 +5,9 @@  import Skeletest import Skeletest.Predicate qualified as P+import Skeletest.TestUtils.CallStack (sanitizeTraceback) import Skeletest.TestUtils.Integration -#if __GLASGOW_HASKELL__ == 910-import Data.Text qualified as Text-#endif- spec :: Spec spec = do   describe "shouldBe" $ do@@ -203,19 +200,3 @@     (stdout, stderr) <- expectFailure $ runner.runTestsWith def{cwd = Just "/"}     stderr `shouldBe` ""     stdout `shouldSatisfy` P.matchesSnapshot---- GHC 9.10 specifically added a backtrace to SomeException, which was reverted in 9.12--- https://github.com/haskell/core-libraries-committee/issues/285-sanitizeTraceback :: String -> String-#if __GLASGOW_HASKELL__ == 910-sanitizeTraceback s =-  let (pre, post) = break (Text.pack "HasCallStack backtrace:" `Text.isInfixOf`) $ Text.lines $ Text.pack s-      (_, post2) = break (Text.pack "╰" `Text.isPrefixOf`) $ drop 1 post-      post2' =-        case post2 of-          [] -> []-          l : ls -> Text.take 80 l : ls-   in Text.unpack . Text.unlines $ pre ++ post2'-#else-sanitizeTraceback = id-#endif

@@ -6,10 +6,115 @@ import Skeletest.Predicate qualified as P import Skeletest.Prop.Gen qualified as Gen import Skeletest.Prop.Range qualified as Range+import Skeletest.TestUtils.CallStack (sanitizeTraceback) import Skeletest.TestUtils.Integration  spec :: Spec spec = do+  describe "prop" $ do+    integration . it "shows hedgehog context for arbitrary failures" $ do+      runner <- getFixture @TestRunner+      runner.addTestFile "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Control.Exception"+        , "import Control.Monad.IO.Class (liftIO)"+        , "import Skeletest"+        , "import qualified Skeletest.Prop as Prop"+        , "import qualified Skeletest.Prop.Gen as Gen"+        , ""+        , "spec = do"+        , "  prop \"error\" $ do"+        , "    x <- forAll $ pure True"+        , "    if x then liftIO $ throwIO MyException else pure ()"+        , ""+        , "data MyException = MyException deriving (Show)"+        , "instance Exception MyException where"+        , "  displayException MyException = \"this is MyException\""+        ]++      (stdout, stderr) <- expectFailure $ runner.runTestsWith zeroSeed+      stderr `shouldBe` ""+      sanitizeTraceback stdout `shouldSatisfy` P.matchesSnapshot++    integration . it "renders Skeletest errors well" $ do+      runner <- getFixture @TestRunner+      runner.addTestFile "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "spec = do"+        , "  prop \"error\" $ do"+        , "    _ <- getFlag @MyFlag"+        , "    pure ()"+        , ""+        , "data MyFlag = MyFlag"+        , "instance IsFlag MyFlag where"+        , "  flagName = \"my-flag\""+        , "  flagHelp = \"example\""+        , "  flagSpec = RequiredFlag (const $ Right MyFlag)"+        ]++      (stdout, stderr) <- expectFailure $ runner.runTestsWith zeroSeed+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot++    integration . it "fails when configuration occurs after forAll" $ do+      runner <- getFixture @TestRunner+      runner.addTestFile "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , "import qualified Skeletest.Prop as Prop"+        , "import qualified Skeletest.Prop.Gen as Gen"+        , ""+        , "spec = prop \"discards\" $ do"+        , "  x <- forAll Gen.bool"+        , "  Prop.setDiscardLimit 10"+        , "  x `shouldBe` x"+        ]++      (stdout, stderr) <- expectFailure $ runner.runTestsWith zeroSeed+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot++    integration . it "fails when configuration occurs after IO actions" $ do+      runner <- getFixture @TestRunner+      runner.addTestFile "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , "import qualified Skeletest.Prop as Prop"+        , "import qualified Skeletest.Prop.Gen as Gen"+        , ""+        , "spec = prop \"discards\" $ do"+        , "  FixtureTmpDir _ <- getFixture"+        , "  Prop.setDiscardLimit 10"+        ]++      (stdout, stderr) <- expectFailure $ runner.runTestsWith zeroSeed+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot++    integration . it "supports MonadFail" $ do+      runner <- getFixture @TestRunner+      runner.addTestFile "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , "import qualified Skeletest.Prop as Prop"+        , "import qualified Skeletest.Prop.Gen as Gen"+        , ""+        , "spec = prop \"discards\" $ do"+        , "  Just _ <- forAll $ pure (Nothing :: Maybe Int)"+        , "  pure ()"+        ]++      (stdout, stderr) <- expectFailure $ runner.runTestsWith zeroSeed+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot+   describe "setDiscardLimit" $ do     integration . it "sets discard limit" $ do       runner <- getFixture @TestRunner@@ -50,6 +155,9 @@         , "    (read . show) P.=== id `shouldNotSatisfy` P.isoWith (Gen.int $ Range.linear 0 10)"         ] -      (stdout, stderr) <- expectFailure $ runner.runTestsWith def{cliArgs = ["--seed=0:0"]}+      (stdout, stderr) <- expectFailure $ runner.runTestsWith zeroSeed       stderr `shouldBe` ""       stdout `shouldSatisfy` P.matchesSnapshot++zeroSeed :: TestArgs+zeroSeed = def{cliArgs = ["--seed=0:0"]}

@@ -0,0 +1,29 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Skeletest.TestUtils.CallStack (+  sanitizeTraceback,+) where++#if __GLASGOW_HASKELL__ == 910+import Data.Text qualified as Text+#endif++-- GHC 9.10 specifically added a backtrace to SomeException, which was reverted in 9.12+-- https://github.com/haskell/core-libraries-committee/issues/285+sanitizeTraceback :: String -> String+#if __GLASGOW_HASKELL__ == 910+sanitizeTraceback s =+  let (pre, post) = break ("HasCallStack backtrace:" `Text.isInfixOf`) $ Text.lines $ Text.pack s+      (_, post2) = span (", called at" `Text.isInfixOf`) $ drop 1 post+      post2' = mapLast (Text.take 80) post2+   in Text.unpack . Text.unlines $ pre ++ post2'+ where+  mapLast f = \case+    [] -> []+    [x] -> [f x]+    x : xs -> x : mapLast f xs+#else+sanitizeTraceback = id+#endif

@@ -38,6 +38,72 @@ ╰──────────────────────────────────────────────────────────────────────────────────────── ``` +## prop / fails when configuration occurs after IO actions++```+./ExampleSpec.hs+╭── discards: ERROR+│ Property configuration function must be done before any forAll or IO actions+│ +│ Failed after 1 tests.+│ Rerun with --seed=0:0 to reproduce.+╰───────────────────────────────────────────────────────────────────────────────+```++## prop / fails when configuration occurs after forAll++```+./ExampleSpec.hs+╭── discards: ERROR+│ Property configuration function must be done before any forAll or IO actions+│ +│ Failed after 1 tests.+│ Rerun with --seed=0:0 to reproduce.+╰───────────────────────────────────────────────────────────────────────────────+```++## prop / renders Skeletest errors well++```+./ExampleSpec.hs+╭── error: ERROR+│ CLI flag 'my-flag' was not registered. Did you add it to cliFlags in Main.hs?+│ +│ Failed after 1 tests.+│ Rerun with --seed=0:0 to reproduce.+╰───────────────────────────────────────────────────────────────────────────────+```++## prop / shows hedgehog context for arbitrary failures++```+./ExampleSpec.hs+╭── error: ERROR+│ Got exception of type `MyException`:+│ this is MyException+│ +│ Failed after 1 tests.+│ Rerun with --seed=0:0 to reproduce.+╰───────────────────────────────────────────────────────────────────────────────+```++## prop / supports MonadFail++```+./ExampleSpec.hs+╭── discards: ERROR+│ ExampleSpec.hs:8:+│ │+│ │   Just _ <- forAll $ pure (Nothing :: Maybe Int)+│ │   ^^^^^^+│ +│ Pattern match failure in 'do' block+│ +│ Failed after 1 tests.+│ Rerun with --seed=0:0 to reproduce.+╰───────────────────────────────────────────────────────────────────────────────+```+ ## setDiscardLimit / sets discard limit  ```