diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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: diff --git a/skeletest.cabal b/skeletest.cabal --- a/skeletest.cabal +++ b/skeletest.cabal @@ -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 diff --git a/src/Skeletest/Internal/Error.hs b/src/Skeletest/Internal/Error.hs --- a/src/Skeletest/Internal/Error.hs +++ b/src/Skeletest/Internal/Error.hs @@ -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 diff --git a/src/Skeletest/Internal/Paths.hs b/src/Skeletest/Internal/Paths.hs --- a/src/Skeletest/Internal/Paths.hs +++ b/src/Skeletest/Internal/Paths.hs @@ -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 diff --git a/src/Skeletest/Internal/Preprocessor.hs b/src/Skeletest/Internal/Preprocessor.hs --- a/src/Skeletest/Internal/Preprocessor.hs +++ b/src/Skeletest/Internal/Preprocessor.hs @@ -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' diff --git a/src/Skeletest/Internal/Spec/Output.hs b/src/Skeletest/Internal/Spec/Output.hs --- a/src/Skeletest/Internal/Spec/Output.hs +++ b/src/Skeletest/Internal/Spec/Output.hs @@ -95,15 +95,15 @@ try (readTestFile path) >>= \case Right srcFile | Just line <- getLineNum lineNum srcFile -> pure $ Right line - | otherwise -> pure $ Left "" - Left (_ :: SomeException) -> pure $ Left "" + | otherwise -> pure $ Left $ " path <> ":" <> show lineNum <> ">" + Left (_ :: SomeException) -> pure $ Left $ " 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 <> ":" diff --git a/src/Skeletest/Internal/TestRunner.hs b/src/Skeletest/Internal/TestRunner.hs --- a/src/Skeletest/Internal/TestRunner.hs +++ b/src/Skeletest/Internal/TestRunner.hs @@ -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 diff --git a/src/Skeletest/Prop/Internal.hs b/src/Skeletest/Prop/Internal.hs --- a/src/Skeletest/Prop/Internal.hs +++ b/src/Skeletest/Prop/Internal.hs @@ -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 -> "" - 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 [("", 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 -> "" + 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 -----} diff --git a/test/Skeletest/AssertionsSpec.hs b/test/Skeletest/AssertionsSpec.hs --- a/test/Skeletest/AssertionsSpec.hs +++ b/test/Skeletest/AssertionsSpec.hs @@ -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 diff --git a/test/Skeletest/PropSpec.hs b/test/Skeletest/PropSpec.hs --- a/test/Skeletest/PropSpec.hs +++ b/test/Skeletest/PropSpec.hs @@ -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"]} diff --git a/test/Skeletest/TestUtils/CallStack.hs b/test/Skeletest/TestUtils/CallStack.hs new file mode 100644 --- /dev/null +++ b/test/Skeletest/TestUtils/CallStack.hs @@ -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 diff --git a/test/Skeletest/__snapshots__/PropSpec.snap.md b/test/Skeletest/__snapshots__/PropSpec.snap.md --- a/test/Skeletest/__snapshots__/PropSpec.snap.md +++ b/test/Skeletest/__snapshots__/PropSpec.snap.md @@ -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 ```