skeletest 0.3.7 → 0.4.0

raw patch · 58 files changed

+4344/−1463 lines, 58 filesdep +deepseqdep +strip-ansi-escapedep +timedep ~DiffPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, strip-ansi-escape, time

Dependency ranges changed: Diff

API changes (from Hackage documentation)

Files

• CHANGELOG.md +36/−0
• README.md +27/−11
• skeletest.cabal +31/−13
• src/Skeletest.hs +6/−1
• src/Skeletest/Hooks.hs +80/−0
• src/Skeletest/Internal/CLI.hs +75/−23
• src/Skeletest/Internal/Capture.hs +52/−20
• src/Skeletest/Internal/Error.hs +24/−23
• src/Skeletest/Internal/Exit.hs +55/−0
• src/Skeletest/Internal/Fixtures.hs +10/−3
• src/Skeletest/Internal/GHC.hs +3/−2
• src/Skeletest/Internal/Hooks.hs +181/−0
• src/Skeletest/Internal/Hooks/HookDef.hs +121/−0
• src/Skeletest/Internal/Paths.hs +24/−1
• src/Skeletest/Internal/Plugin.hs +0/−238
• src/Skeletest/Internal/Predicate.hs +88/−133
• src/Skeletest/Internal/Preprocessor.hs +3/−2
• src/Skeletest/Internal/PreprocessorPlugin.hs +240/−0
• src/Skeletest/Internal/Snapshot.hs +536/−243
• src/Skeletest/Internal/Snapshot/Renderer.hs +66/−0
• src/Skeletest/Internal/Spec.hs +285/−106
• src/Skeletest/Internal/Spec/Output.hs +10/−71
• src/Skeletest/Internal/Spec/TestReporter.hs +319/−0
• src/Skeletest/Internal/Spec/Tree.hs +16/−20
• src/Skeletest/Internal/TestInfo.hs +10/−5
• src/Skeletest/Internal/TestRunner.hs +39/−14
• src/Skeletest/Internal/Utils/Color.hs +4/−0
• src/Skeletest/Internal/Utils/Term.hs +169/−0
• src/Skeletest/Internal/Utils/Text.hs +43/−0
• src/Skeletest/Internal/Utils/Timer.hs +23/−0
• src/Skeletest/Main.hs +76/−35
• src/Skeletest/Plugin.hs +4/−81
• src/Skeletest/Predicate.hs +3/−0
• src/Skeletest/Prop/Internal.hs +98/−15
• src/bin/skeletest-preprocessor.hs +11/−5
• test/Skeletest/Internal/CLISpec.hs +7/−7
• test/Skeletest/Internal/CaptureSpec.hs +23/−1
• test/Skeletest/Internal/SnapshotSpec.hs +339/−23
• test/Skeletest/Internal/Spec/TestReporterSpec.hs +36/−0
• test/Skeletest/Internal/Spec/__snapshots__/TestReporterSpec.snap.md +134/−0
• test/Skeletest/Internal/SpecSpec.hs +19/−3
• test/Skeletest/Internal/__snapshots__/CLISpec.snap.md +5/−1
• test/Skeletest/Internal/__snapshots__/CaptureSpec.snap.md +202/−0
• test/Skeletest/Internal/__snapshots__/FixturesSpec.snap.md +13/−4
• test/Skeletest/Internal/__snapshots__/SnapshotSpec.snap.md +112/−18
• test/Skeletest/Internal/__snapshots__/SpecSpec.snap.md +51/−21
• test/Skeletest/Internal/__snapshots__/TestTargetsSpec.snap.md +1/−1
• test/Skeletest/PluginSpec.hs +5/−7
• test/Skeletest/PredicateSpec.hs +2/−1
• test/Skeletest/TestUtils/ANSI.hs +199/−0
• test/Skeletest/TestUtils/CallStack.hs +8/−7
• test/Skeletest/TestUtils/Integration.hs +62/−28
• test/Skeletest/__snapshots__/AssertionsSpec.snap.md +93/−49
• test/Skeletest/__snapshots__/MainSpec.snap.md +2/−1
• test/Skeletest/__snapshots__/PluginSpec.snap.md +15/−6
• test/Skeletest/__snapshots__/PredicateSpec.snap.md +164/−160
• test/Skeletest/__snapshots__/PropSpec.snap.md +82/−58
• test/__snapshots__/ExampleSpec.snap.md +2/−2

@@ -1,3 +1,39 @@+## v0.4.0++New features:+* Long tests now display the duration of the test ([#23](https://github.com/brandonchinn178/skeletest/issues/23))+* Summary of test results now displayed at end of test ([#21](https://github.com/brandonchinn178/skeletest/issues/21))+* Added `--format` for customizing the report format; `--format=minimal` is now the default in a terminal that supports ANSI++API changes:+* Re-designed how hooks are defined+* New hooks:+  * `runSpecs`+  * `modifyTestSummary`+  * `onTestFailure`+* New `P.empty` predicate for checking empty lists/texts/etc.+* Add `HasSubsequences` instance for lazy `Text`+* Remove field prefixes from more constructors (`FlagSpec`, `TestResult`, `SpecInfo`)+* Change `testResultSuccess` from `Bool` to `TestResultStatus`+* `P.anything` now forces its argument to WHNF+  * Added `P.anythingDeep` for forcing its argument deeply+  * Added `P.anyThunk` to recover the old behavior+* New `skipTest` function for skipping tests at runtime++Runtime changes:+* Sanitize a literal "\`\`\`" line in snapshots ([#27](https://github.com/brandonchinn178/skeletest/issues/27))+* Show diff when snapshot doesn't exist also ([#51](https://github.com/brandonchinn178/skeletest/issues/51))+* Only update snapshots if test passed ([#25](https://github.com/brandonchinn178/skeletest/issues/25))+* Standardize exit codes+* Error if no tests were selected+* If there are any outdated snapshot files, `--update` now updates/removes them. The test suite fails if `--update` is not specified. ([#24](https://github.com/brandonchinn178/skeletest/issues/24))+* Snapshots are now ordered by test order ([#26](https://github.com/brandonchinn178/skeletest/issues/26))+  * Will not reorder existing snapshot files until at least one snapshot in the file has changed and forces a write to the file. To force reorder everything, run `find ./test -name '*.snap.md' | xargs rm -rf` and rerun with `--update`.+* Snapshot headers now use `≫` as the group delimiter+  * Slashes are now safe in group/test names in snapshot files+  * `≫` is properly sanitized if used in group/test names+  * Snapshot files will re-render with the new delimiter when a snapshot changes. Delete all snapshot files to force rerendering+ ## v0.3.7  New features:

@@ -184,6 +184,19 @@  When multiple targets are specified, they are joined with `or`. +### Exit codes++<!-- Keep this in sync with Skeletest.Internal.Exit -->+| Exit code | Description                  |+|-----------|------------------------------|+|     0     | Skeletest ran successfully   |+|     1     | Tests failed, general errors |+|     3     | No tests ran                 |+|     4     | CLI argument-related failure |+|     5     | Outdated snapshots           |+|    10     | Preprocessor failure         |+|    99     | Some unknown error           |+ ### Assertions and Predicates  All assertions in Skeletest use the following functions:@@ -448,11 +461,20 @@  ### Hooks -Skeletest lets you hook into specific parts of test execution. Skeletest currently supports the following hooks:+Skeletest lets you hook into specific parts of test execution. See [Hackage](https://hackage-content.haskell.org/package/skeletest/docs/Skeletest-Hooks.html) for more info. -* `modifySpecRegistry` - Modify all the specs in the test suite. This can be used to do your own test selection, test transformations, etc.-* `runTest` - Modify how/if a test is run. Takes the `TestInfo` of the currently running test. `TestInfo` contains `testInfoMarkers`, which you can query with `findMarker` or `hasMarkerNamed`.+```haskell+import Skeletest.Hooks +hooks :: Hooks+hooks =+  defaultHooks+    { runTest = mkHook_+        (\_ _ -> putStrLn "before test")+        (\_ _ _ -> putStrLn "after test")+    }+```+ ### Plugins  Skeletest is fully pluggable; any configuration specified in `Main.hs` (e.g. `cliFlags` or `snapshotRenderer`) can be defined in a `Plugin` that you can import from another module or even another package.@@ -465,14 +487,8 @@ myPlugin :: Plugin myPlugin =   defaultPlugin-    { hooks =-        defaultHooks-          { runTest = \testInfo run -> do-              putStrLn "before test"-              result <- run-              putStrLn "after test"-              pure result-          }+    { cliFlags = myPluginFlags+    , hooks = myPluginHooks     } ``` 

@@ -1,7 +1,7 @@ cabal-version: 3.0  name: skeletest-version: 0.3.7+version: 0.4.0 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@@ -17,15 +17,17 @@   CHANGELOG.md   test/__snapshots__/ExampleSpec.snap.md   test/Skeletest/__snapshots__/AssertionsSpec.snap.md-  test/Skeletest/__snapshots__/PropSpec.snap.md   test/Skeletest/__snapshots__/MainSpec.snap.md   test/Skeletest/__snapshots__/PluginSpec.snap.md   test/Skeletest/__snapshots__/PredicateSpec.snap.md-  test/Skeletest/Internal/__snapshots__/SnapshotSpec.snap.md+  test/Skeletest/__snapshots__/PropSpec.snap.md   test/Skeletest/Internal/__snapshots__/CLISpec.snap.md+  test/Skeletest/Internal/__snapshots__/CaptureSpec.snap.md   test/Skeletest/Internal/__snapshots__/FixturesSpec.snap.md-  test/Skeletest/Internal/__snapshots__/TestTargetsSpec.snap.md+  test/Skeletest/Internal/__snapshots__/SnapshotSpec.snap.md   test/Skeletest/Internal/__snapshots__/SpecSpec.snap.md+  test/Skeletest/Internal/__snapshots__/TestTargetsSpec.snap.md+  test/Skeletest/Internal/Spec/__snapshots__/TestReporterSpec.snap.md  source-repository head   type: git@@ -36,21 +38,35 @@   exposed-modules:     Skeletest     Skeletest.Assertions+    Skeletest.Hooks+    Skeletest.Main+    Skeletest.Plugin+    Skeletest.Predicate+    Skeletest.Prop+    Skeletest.Prop.Gen+    Skeletest.Prop.Internal+    Skeletest.Prop.Range+    -- Internal modules     Skeletest.Internal.CLI     Skeletest.Internal.Capture     Skeletest.Internal.Constants     Skeletest.Internal.Error+    Skeletest.Internal.Exit     Skeletest.Internal.Fixtures     Skeletest.Internal.GHC     Skeletest.Internal.GHC.Compat+    Skeletest.Internal.Hooks+    Skeletest.Internal.Hooks.HookDef     Skeletest.Internal.Markers     Skeletest.Internal.Paths-    Skeletest.Internal.Plugin     Skeletest.Internal.Predicate     Skeletest.Internal.Preprocessor+    Skeletest.Internal.PreprocessorPlugin     Skeletest.Internal.Snapshot+    Skeletest.Internal.Snapshot.Renderer     Skeletest.Internal.Spec     Skeletest.Internal.Spec.Output+    Skeletest.Internal.Spec.TestReporter     Skeletest.Internal.Spec.Tree     Skeletest.Internal.TestInfo     Skeletest.Internal.TestRunner@@ -59,13 +75,9 @@     Skeletest.Internal.Utils.Diff     Skeletest.Internal.Utils.HList     Skeletest.Internal.Utils.Map-    Skeletest.Main-    Skeletest.Plugin-    Skeletest.Predicate-    Skeletest.Prop-    Skeletest.Prop.Gen-    Skeletest.Prop.Internal-    Skeletest.Prop.Range+    Skeletest.Internal.Utils.Term+    Skeletest.Internal.Utils.Text+    Skeletest.Internal.Utils.Timer   if impl(ghc >= 9.8) && impl(ghc < 9.10)     other-modules:         Skeletest.Internal.GHC.Compat_9_8@@ -84,7 +96,8 @@     , aeson-pretty     , ansi-terminal >= 0.7.0     , containers-    , Diff >= 1.0+    , Diff >= 1.0.2+    , deepseq     , directory     , exceptions     , filepath@@ -96,9 +109,11 @@     , pretty     , process     , recover-rtti+    , strip-ansi-escape     , template-haskell     , terminal-size >= 0.2.0     , text+    , time     , transformers     , unliftio >= 0.2.17   default-language: GHC2021@@ -128,12 +143,14 @@     Skeletest.Internal.FixturesSpec     Skeletest.Internal.SnapshotSpec     Skeletest.Internal.SpecSpec+    Skeletest.Internal.Spec.TestReporterSpec     Skeletest.Internal.TestTargetsSpec     Skeletest.MainSpec     Skeletest.OptionsSpec     Skeletest.PluginSpec     Skeletest.PredicateSpec     Skeletest.PropSpec+    Skeletest.TestUtils.ANSI     Skeletest.TestUtils.CallStack     Skeletest.TestUtils.Integration   build-depends:@@ -146,6 +163,7 @@     , skeletest     , process     , text+    , transformers     , unliftio   default-language: GHC2021   ghc-options: -Wall -Wcompat

@@ -16,7 +16,9 @@   withMarkers,   withMarker, -  -- * Assertions+  -- * Implementing tests++  -- ** Assertions   shouldBe,   shouldNotBe,   shouldSatisfy,@@ -27,6 +29,9 @@   HasCallStack,   Predicate,   Testable,++  -- ** Modify test execution+  skipTest,    -- * Properties   Property,

@@ -0,0 +1,80 @@+{-# LANGUAGE DuplicateRecordFields #-}++-- | The module that contains everything needed to implement custom hooks.+module Skeletest.Hooks (+  -- * Hooks+  X.Hooks (..),+  X.Hook,+  X.defaultHooks,++  -- ** Specific hooks++  -- *** modifySpecRegistry+  X.ModifySpecRegistryHook,+  X.ModifySpecRegistryHookContext (..),++  -- *** runTest+  X.RunTestHook,+  X.RunTestHookContext (..),++  -- *** onTestFailure+  X.OnTestFailureHook,+  X.OnTestFailureHookContext (..),++  -- *** runSpecs+  X.RunSpecsHook,+  X.RunSpecsHookContext (..),++  -- *** modifyTestSummary+  X.ModifyTestSummaryHook,+  X.ModifyTestSummaryHookContext (..),++  -- ** Implementing a hook+  X.runEarly,+  X.runLate,+  X.mkHook,+  X.mkHook_,+  X.mkPreHook,+  X.mkPreHook_,+  X.mkPostHook,+  X.mkPostHook_,++  -- * Re-exports++  -- ** TestResult+  X.TestResult (..),+  X.TestResultMessage (..),+  X.BoxSpec,+  X.BoxSpecContent (..),++  -- ** TestInfo+  X.TestInfo (..),++  -- ** Markers+  X.findMarker,+  X.hasMarker,+  X.hasMarkerNamed,++  -- ** SpecRegistry+  X.SpecRegistry,+  X.Spec,+  X.SpecInfo (..),+  X.SpecTree (..),+  X.SpecTest (..),+  X.getSpecTrees,+  X.withSpecTrees,+  X.mapSpecTrees,+  X.traverseSpecTrees,+  X.mapSpecTests,+  X.traverseSpecTests,+  X.filterSpecTests,+  X.mapSpecs,+  X.traverseSpecs,+) where++import Skeletest.Internal.Hooks qualified as X+import Skeletest.Internal.Markers qualified as X+import Skeletest.Internal.Spec.Output qualified as X+import Skeletest.Internal.Spec.Tree qualified as X+import Skeletest.Internal.TestInfo qualified as X+import Skeletest.Internal.TestRunner qualified as X

@@ -17,6 +17,11 @@   getFlag,   loadCliArgs, +  -- * General flags+  ANSIFlag (..),+  FormatFlag (..),+  getFormatFlag,+   -- * Internal   parseCliArgsWith,   FlagInfos,@@ -41,15 +46,14 @@ import Data.Sequence qualified as Seq import Data.Text (Text) import Data.Text qualified as Text-import Data.Text.IO qualified as Text import Data.Typeable (TypeRep, Typeable, typeOf, typeRep)-import Skeletest.Internal.Error (SkeletestError (..), invariantViolation)+import Skeletest.Internal.Error (invariantViolation, skeletestError)+import Skeletest.Internal.Exit (TestExitCode (..), exitWith) import Skeletest.Internal.TestTargets (TestTargets, parseTestTargets)+import Skeletest.Internal.Utils.Color qualified as Color+import Skeletest.Internal.Utils.Term qualified as Term import System.Environment (getArgs)-import System.Exit (exitFailure, exitSuccess)-import System.IO (stderr) import System.IO.Unsafe (unsafePerformIO)-import UnliftIO.Exception (throwIO)  #if !MIN_VERSION_base(4, 20, 0) import Data.Foldable (foldl')@@ -69,8 +73,8 @@ --   flagHelp = "The value for MyFixture" --   flagSpec = --     OptionalFlag---       { flagDefault = "foo"---       , flagParse = \case+--       { default_ = "foo"+--       , parse = \case --           "illegal" -> Left "invalid flag value" --           s -> Right (MyFlag s) --       }@@ -107,17 +111,16 @@    flagSpec :: FlagSpec a --- TODO(breaking-change): Remove 'flag' prefix from these fields data FlagSpec a   = SwitchFlag-      { flagFromBool :: Bool -> a+      { fromBool :: Bool -> a       }   | RequiredFlag-      { flagParse :: String -> Either String a+      { parse :: String -> Either String a       }   | OptionalFlag-      { flagDefault :: a-      , flagParse :: String -> Either String a+      { default_ :: a+      , parse :: String -> Either String a       }   | forall x.     MultiFlag@@ -142,10 +145,59 @@               , "Expected: " <> show rep <> "."               , "Got: " <> show dyn               ]-      Nothing -> throwIO $ CliFlagNotFound (Text.pack $ flagName @a)+      Nothing ->+        skeletestError . Text.unwords $+          [ "CLI flag '" <> Text.pack (flagName @a) <> "' was not registered."+          , "Did you add it to cliFlags in Main.hs?"+          ]  where   rep = typeRep (Proxy @a) +{----- General flags -----}++newtype ANSIFlag = ANSIFlag (Maybe Bool)+instance IsFlag ANSIFlag where+  flagName = "ansi"+  flagHelp = "Whether to enable ANSI output: auto (default), always, never"+  flagSpec =+    OptionalFlag+      { default_ = ANSIFlag Nothing+      , parse = \case+          "auto" -> Right . ANSIFlag $ Nothing+          "always" -> Right . ANSIFlag $ Just True+          "never" -> Right . ANSIFlag $ Just False+          s -> Left $ "invalid value: " <> s+      }++data FormatFlag+  = FormatFlag_Minimal+  | FormatFlag_Full+  | FormatFlag_Verbose+  deriving (Show, Eq)++instance IsFlag (Maybe FormatFlag) where+  flagName = "format"+  flagHelp = "The format of the output"+  flagSpec =+    OptionalFlag+      { default_ = Nothing+      , parse = \case+          "minimal" -> Right $ Just FormatFlag_Minimal+          "full" -> Right $ Just FormatFlag_Full+          "verbose" -> Right $ Just FormatFlag_Verbose+          s -> Left $ "Unknown format: " <> s+      }++getFormatFlag :: IO FormatFlag+getFormatFlag = getFlag >>= maybe getDefault pure+ where+  getDefault = do+    supportsANSI <- Term.supportsANSI Term.stdout+    pure $+      if supportsANSI+        then FormatFlag_Minimal+        else FormatFlag_Full+ {----- Load CLI arguments -----}  -- | Parse the CLI arguments using the given user-defined flags, then@@ -156,14 +208,14 @@   args0 <- getArgs   case parseCliArgs (builtinFlags <> flags) args0 of     CLISetupFailure msg -> do-      Text.hPutStrLn stderr $ "ERROR: " <> msg-      exitFailure+      Term.outputErr $ Color.red $ "ERROR: " <> msg+      exitWith ExitCLIFailure     CLIHelpRequested -> do-      Text.putStrLn helpText-      exitSuccess+      Term.output helpText+      exitWith ExitSuccess     CLIParseFailure msg -> do-      Text.hPutStrLn stderr $ msg <> "\n\n" <> helpText-      exitFailure+      Term.outputErr $ msg <> "\n\n" <> helpText+      exitWith ExitCLIFailure     CLIParseSuccess{testTargets, flagStore} -> do       setCliFlagStore flagStore       pure testTargets@@ -388,14 +440,14 @@   parse name spec0 vals =     case spec0 of       spec@SwitchFlag{} -> do-        pure (spec.flagFromBool $ (not . null) vals)+        pure (spec.fromBool $ (not . null) vals)       spec@RequiredFlag{} -> do         val <- maybe (throwRequired name) pure $ getLast vals-        spec.flagParse val+        spec.parse val       spec@OptionalFlag{} -> do         case getLast vals of-          Nothing -> pure spec.flagDefault-          Just val -> spec.flagParse val+          Nothing -> pure spec.default_+          Just val -> spec.parse val       MultiFlag{type_, parseMulti} -> do         parseMulti $           case type_ of

@@ -6,10 +6,11 @@ {-# LANGUAGE NoFieldSelectors #-}  module Skeletest.Internal.Capture (-  CaptureOutputFlag,-  withCaptureOutput,-  addCapturedOutput,+  captureOutputPlugin,   FixtureCapturedOutput (..),++  -- * CLI flag+  CaptureOutputFlag (..), ) where  import Data.Text (Text)@@ -18,9 +19,12 @@ import GHC.IO.Handle qualified as IO import Skeletest.Internal.CLI (   FlagSpec (..),+  FormatFlag (..),   IsFlag (..),   getFlag,+  getFormatFlag,  )+import Skeletest.Internal.CLI qualified as CLI import Skeletest.Internal.Fixtures (   Fixture (..),   FixtureSkeletestTmpDir (..),@@ -28,15 +32,32 @@   noCleanup,   withCleanup,  )+import Skeletest.Internal.Hooks qualified as Hooks import Skeletest.Internal.Spec.Output (BoxSpecContent (..)) import Skeletest.Internal.TestRunner (   TestResult (..),   TestResultMessage (..),  )+import Skeletest.Plugin (Hooks (..), Plugin (..), defaultHooks, defaultPlugin) import System.Directory (removePathForcibly) import System.IO qualified as IO import UnliftIO.Exception (finally) +captureOutputPlugin :: Plugin+captureOutputPlugin =+  defaultPlugin+    { cliFlags = [CLI.flag @CaptureOutputFlag]+    , hooks = captureOutputHooks+    }++captureOutputHooks :: Hooks+captureOutputHooks =+  defaultHooks+    { runTest = Hooks.mkHook $ \_ run inp -> do+        (output, result) <- withCaptureOutput (run inp)+        addCapturedOutput output result+    }+ newtype CaptureOutputFlag = CaptureOutputFlag Bool  instance IsFlag CaptureOutputFlag where@@ -44,8 +65,8 @@   flagHelp = "Whether to capture stdout/stderr: on (default), off"   flagSpec =     OptionalFlag-      { flagDefault = CaptureOutputFlag True-      , flagParse = \case+      { default_ = CaptureOutputFlag True+      , parse = \case           "off" -> Right $ CaptureOutputFlag False           "on" -> Right $ CaptureOutputFlag True           s -> Left $ "invalid value: " <> s@@ -79,26 +100,37 @@       IO.hSetBuffering h buf       IO.hClose orig -addCapturedOutput :: CapturedOutput -> TestResult -> TestResult-addCapturedOutput = maybe id updateResult+addCapturedOutput :: CapturedOutput -> TestResult -> IO TestResult+addCapturedOutput mCapturedOutput result = do+  format <- getFormatFlag+  let output = maybe [] renderOutput mCapturedOutput+  pure $+    if shouldShowOutput format output+      then result{message = addOutput output result.message}+      else result  where-  updateResult output result =-    result-      { testResultMessage =-          TestResultMessageBox . concat $-            [ toBoxContents result.testResultMessage-            , renderOutput output-            ]-      }+  renderOutput (stdout, stderr) =+    concat+      [ renderSection "Captured stdout" stdout+      , renderSection "Captured stderr" stderr+      ]+  renderSection name s =+    if Text.null s+      then []+      else [BoxHeader name, BoxText $ Text.stripEnd s]++  shouldShowOutput format output+    | null output = False+    | format == FormatFlag_Verbose = True+    | result.status.success = False+    | otherwise = True++  addOutput output resultMessage =+    TestResultMessageBox $ toBoxContents resultMessage <> output   toBoxContents = \case     TestResultMessageNone -> []     TestResultMessageInline msg -> [BoxText msg]     TestResultMessageBox box -> box-  renderOutput (stdout, stderr) =-    concat-      [ if Text.null stdout then [] else [BoxHeader "Captured stdout", BoxText stdout]-      , if Text.null stderr then [] else [BoxHeader "Captured stderr", BoxText stderr]-      ]  data FixtureCapturedOutputHandles = FixtureCapturedOutputHandles   { stdout :: LogHandle

@@ -3,51 +3,52 @@  module Skeletest.Internal.Error (   SkeletestError (..),+  skeletestError,   skeletestPluginError,   invariantViolation, ) where +import Control.Monad.IO.Class (MonadIO) import Data.Text (Text) import Data.Text qualified as Text import GHC qualified-import UnliftIO.Exception (Exception (..), impureThrow)+import GHC.Stack (HasCallStack, callStack, prettyCallStack)+import UnliftIO.Exception (Exception (..), impureThrow, throwIO)  data SkeletestError-  = -- | A user error during compilation, e.g. during the preprocessor or plugin phases.+  = -- | Thrown for most errors, unless an error needs to be specially caught.+    SkeletestError Text+  | -- | A user error during compilation, e.g. during the preprocessor or plugin phases.     CompilationError (Maybe GHC.SrcSpan) Text-  | -- | An error in a situation that should never happen, and indicates a bug.-    InvariantViolation Text-  | CliFlagNotFound Text-  | FixtureCircularDependency [Text]-  | SnapshotFileCorrupted FilePath-  | PropConfigAfterIO+  | -- | Skip the currently running test+    SkipTest Text   deriving (Show)  instance Exception SkeletestError where   displayException =     Text.unpack . \case+      SkeletestError msg -> msg       CompilationError _ msg ->         Text.unlines           [ ""           , "******************** skeletest failure ********************"           , msg           ]-      InvariantViolation msg ->-        Text.unlines-          [ "Invariant violation: " <> msg-          , "**** This is a skeletest bug. Please report it at https://github.com/brandonchinn178/skeletest/issues"-          ]-      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"+      SkipTest msg -> "SKIP: " <> msg +skeletestError :: (MonadIO m) => Text -> m a+skeletestError = throwIO . SkeletestError+ skeletestPluginError :: Maybe GHC.SrcSpan -> String -> a skeletestPluginError mloc = impureThrow . CompilationError mloc . Text.pack -invariantViolation :: String -> a-invariantViolation = impureThrow . InvariantViolation . Text.pack+invariantViolation :: (HasCallStack) => String -> a+invariantViolation = impureThrow . SkeletestError . Text.pack . toMessage+ where+  toMessage msg =+    unlines+      [ "Invariant violation: " <> msg+      , "**** This is a skeletest bug. Please report it at https://github.com/brandonchinn178/skeletest/issues"+      , ""+      , prettyCallStack callStack+      ]

@@ -0,0 +1,55 @@+{-# LANGUAGE LambdaCase #-}++module Skeletest.Internal.Exit (+  TestExitCode (..),+  exitWith,+  handleUnknownErrors,+) where++import Data.Text qualified as Text+import Skeletest.Internal.Utils.Term qualified as Term+import System.Exit qualified as Exit+import UnliftIO.Exception (+  displayException,+  fromException,+  handleJust,+ )++-- | All exit codes for Skeletest.+--+-- Should be kept in sync with README.+data TestExitCode+  = ExitSuccess+  | ExitTestFailure+  | ExitNoTests+  | ExitCLIFailure+  | ExitOutdatedSnapshots+  | ExitPreprocessorFailure+  | ExitOther+  deriving (Show, Eq, Ord)++fromExitCode :: TestExitCode -> Exit.ExitCode+fromExitCode = \case+  ExitSuccess -> Exit.ExitSuccess+  ExitTestFailure -> Exit.ExitFailure 1+  ExitNoTests -> Exit.ExitFailure 3+  ExitCLIFailure -> Exit.ExitFailure 4+  ExitOutdatedSnapshots -> Exit.ExitFailure 5+  ExitPreprocessorFailure -> Exit.ExitFailure 10+  ExitOther -> Exit.ExitFailure 99++exitWith :: TestExitCode -> IO a+exitWith code = do+  Term.flush -- Be absolutely sure to flush everything+  Exit.exitWith $ fromExitCode code++handleUnknownErrors :: IO a -> IO a+handleUnknownErrors = handleJust isUnknown $ \e -> do+  Term.outputErr $ (Text.pack . displayException) e+  exitWith ExitOther+ where+  isUnknown e =+    case fromException e of+      Nothing -> Just e+      -- Don't catch 'exitWith' calls+      Just (_ :: Exit.ExitCode) -> Nothing

@@ -2,6 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoFieldSelectors #-}  module Skeletest.Internal.Fixtures (@@ -33,10 +34,11 @@ import Data.Proxy (Proxy (..)) import Data.Text qualified as Text import Data.Typeable (TypeRep, Typeable, eqT, typeOf, typeRep, (:~:) (Refl))-import Skeletest.Internal.Error (SkeletestError (..), invariantViolation)+import Skeletest.Internal.Error (invariantViolation, skeletestError) import Skeletest.Internal.TestInfo (getTestInfo) import Skeletest.Internal.TestInfo qualified as TestInfo import Skeletest.Internal.Utils.Map qualified as Map.Utils+import Skeletest.Internal.Utils.Text (showT) import System.Directory (   createDirectory,   createDirectoryIfMissing,@@ -110,11 +112,16 @@         Just FixtureInProgress ->           -- get list of fixtures causing a circular dependency           let fixtures = map fst . filter (isInProgress . snd) . OMap.assocs $ getScopedFixtures registry-           in (registry, Left $ FixtureCircularDependency $ map (Text.pack . show) (fixtures <> [rep]))+              msg =+                Text.unwords+                  [ "Found circular dependency when resolving fixtures:"+                  , Text.intercalate " -> " $ map showT (fixtures <> [rep])+                  ]+           in (registry, Left msg)    case cachedFixture of     -- error when getting fixture-    Left e -> throwIO e+    Left msg -> skeletestError msg     -- fixture was cached, return it     Right (Just fixture) -> pure fixture     -- otherwise, execute it (allowing it to request other fixtures) and cache the result.

@@ -97,6 +97,7 @@  ) import Skeletest.Internal.GHC.Compat (genLoc) import Skeletest.Internal.GHC.Compat qualified as GHC.Compat+import Skeletest.Internal.Utils.Text (showT)  -- Has to be exactly GHC's Plugin type, for GHC to register it correctly. type Plugin = GHC.Plugin@@ -239,8 +240,8 @@  renderHsExpr :: HsExpr GhcRn -> Text renderHsExpr = \case-  HsExprUnsafe{ghcExpr = Just e} -> Text.pack $ show e-  HsExprUnsafe{hsExpr = e} -> Text.pack $ show e+  HsExprUnsafe{ghcExpr = Just e} -> showT e+  HsExprUnsafe{hsExpr = e} -> showT e  newHsExpr :: HsExprData p -> HsExpr p newHsExpr e =

@@ -0,0 +1,181 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE UndecidableInstances #-}++module Skeletest.Internal.Hooks (+  Hooks (..),+  defaultHooks,++  -- * Runtime+  UserHooks,+  setUserHooks,+  userHooks,++  -- * Hook implementation+  Hook (..),+  HookDef (..),+  HookPriority (..),+  runHook,++  -- * Hook DSL+  runEarly,+  runLate,+  mkHook,+  mkHook_,+  mkPreHook,+  mkPreHook_,+  mkPostHook,+  mkPostHook_,++  -- * Specific hooks++  -- ** modifySpecRegistry+  ModifySpecRegistryHook,+  ModifySpecRegistryHookContext (..),++  -- ** runTest+  RunTestHook,+  RunTestHookContext (..),++  -- ** onTestFailure+  OnTestFailureHook,+  OnTestFailureHookContext (..),++  -- ** runSpecs+  RunSpecsHook,+  RunSpecsHookContext (..),++  -- ** modifyTestSummary+  ModifyTestSummaryHook,+  ModifyTestSummaryHookContext (..),+) where++import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Text (Text)+import GHC.Records (HasField (..))+import Skeletest.Internal.Exit (TestExitCode)+import Skeletest.Internal.Hooks.HookDef+import Skeletest.Internal.Spec.Tree (SpecRegistry)+import Skeletest.Internal.TestInfo (TestInfo)+import Skeletest.Internal.TestRunner (TestResult)+import Skeletest.Internal.TestTargets (TestTargets)+import System.IO.Unsafe (unsafePerformIO)+import UnliftIO.Exception (SomeException)++-- | Hooks for extending Skeletest.+--+-- Use 'defaultHooks' instead of using v'Hooks' directly, to minimize+-- breaking changes.+data Hooks = Hooks+  { modifySpecRegistry :: ModifySpecRegistryHook+  , runTest :: RunTestHook+  , onTestFailure :: OnTestFailureHook+  , runSpecs :: RunSpecsHook+  , modifyTestSummary :: ModifyTestSummaryHook+  }++instance Semigroup Hooks where+  hooks1 <> hooks2 =+    Hooks+      { modifySpecRegistry = hooks1.modifySpecRegistry <> hooks2.modifySpecRegistry+      , runTest = hooks1.runTest <> hooks2.runTest+      , onTestFailure = hooks1.onTestFailure <> hooks2.onTestFailure+      , runSpecs = hooks1.runSpecs <> hooks2.runSpecs+      , modifyTestSummary = hooks1.modifyTestSummary <> hooks2.modifyTestSummary+      }+instance Monoid Hooks where+  mempty = defaultHooks++defaultHooks :: Hooks+defaultHooks =+  Hooks+    { modifySpecRegistry = mempty+    , runTest = mempty+    , onTestFailure = mempty+    , runSpecs = mempty+    , modifyTestSummary = mempty+    }++{----- Runtime -----}++userHooksRef :: IORef Hooks+userHooksRef = unsafePerformIO $ newIORef defaultHooks++setUserHooks :: Hooks -> IO ()+setUserHooks = writeIORef userHooksRef++userHooks :: UserHooks+userHooks = unsafePerformIO $ UserHooks <$> readIORef userHooksRef++newtype UserHooks = UserHooks Hooks++instance+  (HasField field Hooks (Hook ctx inp out)) =>+  HasField field UserHooks (ctx -> inp -> (inp -> IO out) -> IO out)+  where+  getField (UserHooks hooks) = runHook (getField @field hooks)++{----- modifySpecRegistry -----}++-- | Modify the specs in the test suite.+type ModifySpecRegistryHook =+  Hook+    ModifySpecRegistryHookContext+    SpecRegistry+    SpecRegistry++data ModifySpecRegistryHookContext = ModifySpecRegistryHookContext+  { testTargets :: TestTargets+  }++{----- runTest -----}++-- | Modify how a test is executed+type RunTestHook =+  Hook+    RunTestHookContext+    ()+    TestResult++data RunTestHookContext = RunTestHookContext+  { testInfo :: TestInfo+  }++{----- onTestFailure -----}++-- | Modify what happens if a test fails.+type OnTestFailureHook =+  Hook+    OnTestFailureHookContext+    SomeException+    TestResult++data OnTestFailureHookContext = OnTestFailureHookContext+  { testInfo :: TestInfo+  }++{----- runSpecs -----}++-- | Modify the action to run specs.+type RunSpecsHook =+  Hook+    RunSpecsHookContext+    SpecRegistry+    TestExitCode++data RunSpecsHookContext = RunSpecsHookContext+  {+  }++{----- modifyTestSummary -----}++-- | Modify the test summary at the end of the report.+type ModifyTestSummaryHook =+  Hook+    ModifyTestSummaryHookContext+    Text+    Text++data ModifyTestSummaryHookContext = ModifyTestSummaryHookContext+  {+  }

@@ -0,0 +1,121 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedRecordDot #-}++module Skeletest.Internal.Hooks.HookDef (+  Hook (..),+  HookDef (..),+  HookPriority (..),+  runHook,++  -- * Hook DSL+  runEarly,+  runLate,+  mkHook,+  mkHook_,+  mkPreHook,+  mkPreHook_,+  mkPostHook,+  mkPostHook_,+) where++import Control.Monad ((>=>))+import Data.List (sortOn)++-- | The implementation of a Skeletest hook in 'Skeletest.Plugin.Hooks'.+--+-- A hook of type @Hook ctx inp out@ means:+--+--   * The hook takes a value of type @ctx@ with extra read-only information+--     that may be relevant for the hook.+--   * The hook takes an action of type @inp -> IO out@ and returns a+--     potentially modified action of the same type.+--+-- @ctx@/@inp@ should generally be accessed with @OverloadedRecordDot@ or record+-- destructuring, to minimize breaking changes when adding fields to them.+newtype Hook ctx inp out = Hook [HookDef ctx inp out]+  deriving newtype (Monoid, Semigroup)++data HookDef ctx inp out = HookDef+  { priority :: HookPriority+  , impl :: ctx -> (inp -> IO out) -> (inp -> IO out)+  }++data HookPriority+  = NoPriority+  | EarlyPriority+  | LatePriority++defaultHookDef :: HookDef ctx inp out+defaultHookDef =+  HookDef+    { priority = NoPriority+    , impl = \_ run -> run+    }++runHook :: Hook ctx inp out -> ctx -> inp -> (inp -> IO out) -> IO out+runHook (Hook hookDefs) ctx inp run = foldr go run (orderHookDefs hookDefs) inp+ where+  orderHookDefs = sortOn $ \def ->+    case def.priority of+      NoPriority -> 0 :: Int+      EarlyPriority -> -1+      LatePriority -> 1+  go hookDef acc = hookDef.impl ctx acc++{----- DSL -----}++-- | Run the given hook earlier if possible.+runEarly :: Hook ctx inp out -> Hook ctx inp out+runEarly (Hook hookDefs) = Hook (map (\def -> def{priority = EarlyPriority}) hookDefs)++-- | Run the given hook later if possible.+runLate :: Hook ctx inp out -> Hook ctx inp out+runLate (Hook hookDefs) = Hook (map (\def -> def{priority = LatePriority}) hookDefs)++-- | Create a hook.+--+-- === Example+-- @+-- hooks :: Hooks+-- hooks =+--   defaultHooks+--     { runSpecs = runEarly . mkHook $ \ctx run -> pre >=> run >=> post+--     }+--   where+--     pre inp = do+--       inp' <- doStuff inp+--       pure inp'+--     post out = do+--       out' <- doMoreStuff out+--       pure out'+-- @+mkHook :: (ctx -> (inp -> IO out) -> (inp -> IO out)) -> Hook ctx inp out+mkHook f = Hook [defaultHookDef{impl = f}]++-- | Like 'mkHook', except for read-only hooks that don't need to modify+-- anything.+mkHook_ ::+  (ctx -> inp -> IO ()) ->+  (ctx -> inp -> out -> IO ()) ->+  Hook ctx inp out+mkHook_ pre post = mkHook $ \ctx run inp -> do+  pre ctx inp+  out <- run inp+  post ctx inp out+  pure out++-- | Like 'mkHook', except only supports modifying the input.+mkPreHook :: (ctx -> inp -> IO inp) -> Hook ctx inp out+mkPreHook pre = mkHook $ \ctx run -> pre ctx >=> run++-- | Like 'mkHook_', except with only a before action.+mkPreHook_ :: (ctx -> inp -> IO ()) -> Hook ctx inp out+mkPreHook_ pre = mkHook_ pre (\_ _ _ -> pure ())++-- | Like 'mkHook', except only supports modifying the output.+mkPostHook :: (ctx -> inp -> out -> IO out) -> Hook ctx inp out+mkPostHook post = mkHook $ \ctx run inp -> run inp >>= post ctx inp++-- | Like 'mkHook_', except with only an after action.+mkPostHook_ :: (ctx -> inp -> out -> IO ()) -> Hook ctx inp out+mkPostHook_ post = mkHook_ (\_ _ -> pure ()) post

@@ -3,13 +3,15 @@ module Skeletest.Internal.Paths (   setOriginalDirectory,   readTestFile,+  listTestFiles, ) where +import Control.Monad (forM) import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Text (Text) import Data.Text.IO qualified as Text import Skeletest.Internal.Error (invariantViolation)-import System.Directory (getCurrentDirectory)+import System.Directory (doesDirectoryExist, getCurrentDirectory, listDirectory) import System.Environment (lookupEnv) import System.FilePath ((</>)) import System.IO.Unsafe (unsafePerformIO)@@ -39,3 +41,24 @@ readTestFile fp = do   dir <- readIORef originalDirectoryRef   Text.readFile $ dir </> fp++listTestFiles :: IO [FilePath]+listTestFiles = do+  dir <- readIORef originalDirectoryRef+  listDirectoryRecursive dir+ where+  listDirectoryRecursive dir = do+    entries <- filter (`notElem` ignoredDirs) <$> listDirectory dir+    fmap concat . forM entries $ \entry -> do+      let absEntry = dir </> entry+      isDir <- doesDirectoryExist absEntry+      if isDir+        then map (entry </>) <$> listDirectoryRecursive absEntry+        else pure [entry]++  -- Hardcode some paths to ignore+  ignoredDirs =+    [ ".git"+    , "dist-newstyle"+    , ".stack-work"+    ]

@@ -1,238 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedRecordDot #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskellQuotes #-}-{-# LANGUAGE ViewPatterns #-}--module Skeletest.Internal.Plugin (-  plugin,-) where--import Data.Functor.Const (Const (..))-import Data.Maybe (fromMaybe, listToMaybe)-import Data.Text qualified as Text-import Skeletest.Internal.Constants (mainFileSpecsListIdentifier)-import Skeletest.Internal.Error (skeletestPluginError)-import Skeletest.Internal.GHC-import Skeletest.Internal.Paths (setOriginalDirectory)-import Skeletest.Internal.Predicate qualified as P-import Skeletest.Internal.Preprocessor qualified as Preprocessor-import Skeletest.Internal.Utils.HList (HList (..))-import Skeletest.Main qualified as Main-import Skeletest.Plugin qualified as Plugin--#if !MIN_VERSION_base(4, 20, 0)-import Data.Foldable (foldl')-#endif---- | The plugin to convert a module in the tests directory.--- Injected by the preprocessor.-plugin :: Plugin-plugin =-  mkPlugin-    PluginDef-      { isPure = True-      , modifyParsed = \opts modName modl ->-          let options = decodeOptions opts-           in if modName == options.mainModuleName-                then transformMainModule options modl-                else modl-      , onRename = \_ ctx modName expr ->-          if "Spec" `Text.isSuffixOf` modName-            then transformTestModule ctx expr-            else expr-      }- where-  decodeOptions =-    either (error . Text.unpack) id . \case-      [opts] -> Preprocessor.decodeOptions (Text.pack opts)-      _ -> Left ""---- | Add 'main' function.-transformMainModule :: Preprocessor.Options -> ParsedModule -> ParsedModule-transformMainModule options modl =-  modl-    { moduleFuncs = (hsVarName options.mainFuncName, Just mainFun) : modl.moduleFuncs-    }- where-  findVar name =-    fmap hsExprVar . listToMaybe $-      [ funName-      | (funName, _) <- modl.moduleFuncs-      , getHsName funName == name-      ]--  cliFlagsExpr = fromMaybe (hsExprList []) $ findVar "cliFlags"-  snapshotRenderersExpr = fromMaybe (hsExprList []) $ findVar "snapshotRenderers"-  hooksExpr = fromMaybe (hsExprVar $ hsName 'Plugin.defaultHooks) $ findVar "hooks"-  pluginsExpr = fromMaybe (hsExprList []) $ findVar "plugins"--  mainFun =-    FunDef-      { funType = HsTypeApps (HsTypeCon $ hsName ''IO) [HsTypeTuple []]-      , funPats = []-      , funBody =-          sequenceExpr-            [ setOriginalDirectoryExpr-            , runSkeletestExpr-            ]-      }-  sequenceExpr exprs = hsExprApps (hsExprVar $ hsName 'sequence_) [hsExprList exprs]-  setOriginalDirectoryExpr =-    hsExprApps (hsExprVar $ hsName 'setOriginalDirectory) $-      [hsExprLitString . Text.pack $ options.originalDirectory]-  runSkeletestExpr =-    hsExprApps-      (hsExprVar $ hsName 'Main.runSkeletest)-      [ hsExprApps (hsExprVar (hsName '(:))) $-          [ hsExprRecordCon-              (hsName 'Plugin.Plugin)-              [ (hsFieldName 'Plugin.Plugin "cliFlags", cliFlagsExpr)-              , (hsFieldName 'Plugin.Plugin "snapshotRenderers", snapshotRenderersExpr)-              , (hsFieldName 'Plugin.Plugin "hooks", hooksExpr)-              ]-          , pluginsExpr-          ]-      , hsExprVar $ hsVarName mainFileSpecsListIdentifier-      ]--transformTestModule :: Ctx -> HsExpr GhcRn -> HsExpr GhcRn-transformTestModule ctx =-  foldl' (.) id $-    [ replaceConMatch ctx-    , replaceIsoChecker ctx-    ]---- | Replace all uses of P.con with P.conMatches. See P.con.------ P.con $ User (P.eq "user1") (P.contains "@")--- ====>--- P.conMatches---   "User"---   Nothing---   ( \case---       User x0 x1 -> Just (HCons (pure x0) $ HCons (pure x1) $ HNil)---       _ -> Nothing---   )---   (HCons (P.eq "user1") $ HCons (P.contains "@") $ HNil)------ P.con User{name = P.eq "user1", email = P.contains "@"}--- ====>--- P.conMatches---   "User"---   (Just (HCons (Const "user") $ HCons (Const "email") $ HNil))---   ( \case---       User{name, email} -> Just (HCons (pure name) $ HCons (pure email) $ HNil)---       _ -> Nothing---   )---   (HCons (P.eq "user1") $ HCons (P.contains "@") $ HNil)-replaceConMatch :: Ctx -> HsExpr GhcRn -> HsExpr GhcRn-replaceConMatch ctx e =-  case getExpr e of-    -- Matches:-    --   P.con User{name = ...}-    --   P.con (User "...")-    HsExprApps (getExpr -> HsExprVar name) [arg]-      | isCon name ->-          convertCon arg-    -- Matches:-    --   P.con $ User "..."-    HsExprOp (getExpr -> HsExprVar name) (getExpr -> HsExprVar dollar) arg-      | ctx.matchesName (hsName '($)) dollar-      , isCon name ->-          convertCon arg-    -- Check if P.con is by itself-    HsExprVar name-      | isCon name ->-          skeletestPluginError (getLoc e) "P.con must be applied to a constructor"-    -- Check if P.con is being applied more than once-    HsExprApps (getExpr -> HsExprVar name) (_ : _ : _)-      | isCon name ->-          skeletestPluginError (getLoc e) "P.con must be applied to exactly one argument"-    _ -> e- where-  isCon = ctx.matchesName (hsName 'P.con)--  convertCon con =-    case getExpr con of-      HsExprCon conName -> convertPrefixCon conName []-      HsExprApps (getExpr -> HsExprCon conName) preds -> convertPrefixCon conName preds-      HsExprRecordCon conName fields -> convertRecordCon conName fields-      _ -> skeletestPluginError (getLoc e) "P.con must be applied to a constructor"-  convertPrefixCon conName preds =-    let-      exprNames = mkVarNames preds-     in-      hsExprApps (hsExprVar $ hsName 'P.conMatches) $-        [ hsExprLitString $ getHsName conName-        , hsExprCon $ hsName 'Nothing-        , mkDeconstruct (HsPatCon conName $ map HsPatVar exprNames) exprNames-        , mkPredList preds-        ]-  convertRecordCon conName fields =-    let-      (fieldNames, preds) = unzip fields-      fieldPats = [(field, HsPatVar field) | field <- fieldNames]-     in-      hsExprApps (hsExprVar $ hsName 'P.conMatches) $-        [ hsExprLitString $ getHsName conName-        , hsExprApps (hsExprCon $ hsName 'Just) [mkNamesList fieldNames]-        , mkDeconstruct (HsPatRecord conName fieldPats) fieldNames-        , mkPredList preds-        ]--  -- Generate variable names like x0, x1, ... for each element in the given list.-  mkVarNames =-    let mkVar i = "x" <> (Text.pack . show) i-     in zipWith (\i _ -> hsVarName (mkVar i)) [0 :: Int ..]--  -- Create the deconstruction function:-  ---  -- \actual ->-  --   case actual of-  --     User{name} -> Just (HCons (pure name) HNil)-  --     _ -> Nothing-  ---  -- However, if 'User' is the only constructor, GHC complains about the wildcard-  -- being redundant. So we'll obfuscate it a bit with-  ---  -- \actual ->-  --   case pure actual of-  --     Just User{name} -> Just (HCons (pure name) HNil)-  --     _ -> Nothing-  mkDeconstruct pat argNames =-    hsExprLam [HsPatVar $ hsVarName "actual"] $-      hsExprCase (hsExprApps (hsExprVar $ hsName 'pure) [hsExprVar $ hsVarName "actual"]) $-        [ (HsPatCon (hsName 'Just) [pat], hsExprApps (hsExprCon $ hsName 'Just) [mkValsList argNames])-        , (HsPatWild, hsExprCon $ hsName 'Nothing)-        ]--  mkHList f = \case-    [] -> hsExprCon (hsName 'HNil)-    x : xs ->-      hsExprApps (hsExprCon $ hsName 'HCons) $-        [ f x-        , mkHList f xs-        ]--  mkNamesList = mkHList $ \name -> hsExprApps (hsExprCon $ hsName 'Const) [hsExprLitString $ getHsName name]-  mkValsList = mkHList $ \val -> hsExprApps (hsExprVar $ hsName 'pure) [hsExprVar val]-  mkPredList = mkHList id---- | Replace all uses of P.=== with inlined IsoChecker value, with--- function name filled in.------ (encode . decode) P.=== id--- ====>--- IsoChecker (Fun "encode . decode" (encode . decode)) (Fun "id" id)-replaceIsoChecker :: Ctx -> HsExpr GhcRn -> HsExpr GhcRn-replaceIsoChecker ctx e =-  case getExpr e of-    HsExprOp l (getExpr -> HsExprVar eqeqeq) r-      | ctx.matchesName (hsName '(P.===)) eqeqeq ->-          inlineIsoChecker l r-    _ -> e- where-  inlineIsoChecker l r = hsExprApps (hsExprCon $ hsName 'P.IsoChecker) [mkFun l, mkFun r]-  mkFun f = hsExprApps (hsExprCon $ hsName 'P.Fun) [hsExprLitString $ renderHsExpr f, f]

@@ -9,13 +9,17 @@ {-# LANGUAGE NoFieldSelectors #-}  module Skeletest.Internal.Predicate (-  Predicate,+  Predicate (..),   PredicateResult (..),+  PredicateFuncResult (..),+  ShowFailCtx (..),   runPredicate,   renderPredicate,    -- * General   anything,+  anythingDeep,+  anyThunk,    -- * Ord   eq,@@ -59,21 +63,17 @@   hasPrefix,   hasInfix,   hasSuffix,+  empty,    -- * IO   returns,   throws, -  -- * Functions-  Fun (..),-  IsoChecker (..),-  (===),-  isoWith,--  -- * Snapshot testing-  matchesSnapshot,+  -- * Utilities+  render, ) where +import Control.DeepSeq (NFData) import Control.Monad.IO.Class (MonadIO) import Data.Foldable (toList) import Data.Foldable1 qualified as Foldable1@@ -86,29 +86,15 @@ import Data.Proxy (Proxy (..)) import Data.Text (Text) import Data.Text qualified as Text-import Data.Typeable (Typeable)+import Data.Text.Lazy qualified as LazyText import Debug.RecoverRTTI (anythingToString) import GHC.Generics ((:*:) (..))-import GHC.Stack qualified as GHC-import Skeletest.Internal.CLI (getFlag) import Skeletest.Internal.Error (invariantViolation)-import Skeletest.Internal.Snapshot (-  SnapshotContext (..),-  SnapshotResult (..),-  SnapshotUpdateFlag (..),-  checkSnapshot,-  getAndIncSnapshotIndex,-  getSnapshotRenderers,-  updateSnapshot,- )-import Skeletest.Internal.TestInfo (getTestInfo)-import Skeletest.Internal.Utils.Diff (showLineDiff) import Skeletest.Internal.Utils.HList (HList (..)) import Skeletest.Internal.Utils.HList qualified as HList-import Skeletest.Prop.Gen (Gen)-import Skeletest.Prop.Internal (PropertyM, forAll)+import Skeletest.Internal.Utils.Text (indent, parens) import UnliftIO (MonadUnliftIO)-import UnliftIO.Exception (Exception, displayException, try)+import UnliftIO.Exception (Exception, displayException, evaluate, evaluateDeep, try) import Prelude hiding (abs, all, and, any, elem, not, or, (&&), (||)) import Prelude qualified @@ -205,11 +191,12 @@  {----- General -----} --- | A predicate that matches any value-anything :: forall a m. (Monad m) => Predicate m a+-- | A predicate that matches any value after evaluating to WHNF.+anything :: forall a m. (MonadIO m) => Predicate m a anything =   Predicate-    { predicateFunc = \_ ->+    { predicateFunc = \a -> do+        _ <- evaluate a         pure           PredicateFuncResult             { predicateSuccess = True@@ -220,6 +207,41 @@     , predicateDispNeg = "not anything"     } +-- | A predicate that matches any value after evaluating it deeply.+--+-- @since 0.4.0+anythingDeep :: forall a m. (MonadIO m, NFData a) => Predicate m a+anythingDeep =+  Predicate+    { predicateFunc = \a -> do+        _ <- evaluateDeep a+        pure+          PredicateFuncResult+            { predicateSuccess = True+            , predicateExplain = "anything"+            , predicateShowFailCtx = noCtx+            }+    , predicateDisp = "anything"+    , predicateDispNeg = "not anything"+    }++-- | A predicate that matches any value without evaluating to WHNF.+--+-- @since 0.4.0+anyThunk :: forall a m. (Monad m) => Predicate m a+anyThunk =+  Predicate+    { predicateFunc = \_ ->+        pure+          PredicateFuncResult+            { predicateSuccess = True+            , predicateExplain = "any thunk"+            , predicateShowFailCtx = noCtx+            }+    , predicateDisp = "any thunk"+    , predicateDispNeg = "not any thunk"+    }+ {----- Ord -----}  -- | A predicate checking if the input is equal to the given value@@ -605,15 +627,25 @@   isPrefixOf :: a -> a -> Bool   isInfixOf :: a -> a -> Bool   isSuffixOf :: a -> a -> Bool+  isEmpty :: a -> Bool instance (Eq a) => HasSubsequences [a] where   isPrefixOf = List.isPrefixOf   isInfixOf = List.isInfixOf   isSuffixOf = List.isSuffixOf+  isEmpty = List.null instance HasSubsequences Text where   isPrefixOf = Text.isPrefixOf   isInfixOf = Text.isInfixOf   isSuffixOf = Text.isSuffixOf+  isEmpty = Text.null +-- | @since 0.4.0+instance HasSubsequences LazyText.Text where+  isPrefixOf = LazyText.isPrefixOf+  isInfixOf = LazyText.isInfixOf+  isSuffixOf = LazyText.isSuffixOf+  isEmpty = LazyText.null+ -- | A predicate checking if the input has the given prefix -- -- >>> [1, 2, 3] `shouldSatisfy` P.hasPrefix [1, 2]@@ -689,6 +721,33 @@   disp = "has suffix " <> render suffix   dispNeg = "does not have suffix " <> render suffix +-- | A predicate checking if the input is empty.+--+-- >>> [] `shouldSatisfy` P.empty+-- >>> "" `shouldSatisfy` P.empty+--+-- @since 0.4.0+empty :: (HasSubsequences a, Monad m) => Predicate m a+empty =+  Predicate+    { predicateFunc = \val -> do+        let success = isEmpty val+        pure+          PredicateFuncResult+            { predicateSuccess = success+            , predicateExplain =+                if success+                  then render val <> " " <> disp+                  else render val <> " " <> dispNeg+            , predicateShowFailCtx = noCtx+            }+    , predicateDisp = disp+    , predicateDispNeg = dispNeg+    }+ where+  disp = "is empty"+  dispNeg = "is not empty"+ {----- IO -----}  -- | A predicate checking if the input is an IO action that returns a value matching the given predicate.@@ -763,100 +822,6 @@   disp = "throws (" <> predicateDisp <> ")"   dispNeg = "does not throw (" <> predicateDisp <> ")" -{----- Functions -----}--data Fun a b = Fun String (a -> b)-data IsoChecker a b = IsoChecker (Fun a b) (Fun a b)---- | Verify if two functions are isomorphic.------ @--- prop "reverse . reverse === id" $ do---   let genList = Gen.list (Range.linear 0 10) $ Gen.int (Range.linear 0 1000)---   (reverse . reverse) P.=== id \`shouldSatisfy\` P.isoWith genList--- @-(===) :: (a -> b) -> (a -> b) -> IsoChecker a b-f === g = IsoChecker (Fun "lhs" f) (Fun "rhs" g)--infix 2 ===---- | See '(===)'.-isoWith :: (GHC.HasCallStack, Show a, Eq b) => Gen a -> Predicate PropertyM (IsoChecker a b)-isoWith gen =-  Predicate-    { predicateFunc = \(IsoChecker (Fun f1DispS f1) (Fun f2DispS f2)) -> do-        a <- GHC.withFrozenCallStack $ forAll gen-        let-          f1Disp = Text.pack f1DispS-          f2Disp = Text.pack f2DispS-          b1 = f1 a-          b2 = f2 a-          aDisp = parens $ render a-          b1Disp = parens $ render b1-          b2Disp = parens $ render b2-        pure-          PredicateFuncResult-            { predicateSuccess = b1 == b2-            , predicateExplain =-                Text.intercalate "\n" $-                  [ b1Disp <> " " <> (if b1 == b2 then "=" else "≠") <> " " <> b2Disp-                  , "where"-                  , indent $ b1Disp <> " = " <> f1Disp <> " " <> aDisp-                  , indent $ b2Disp <> " = " <> f2Disp <> " " <> aDisp-                  ]-            , predicateShowFailCtx = HideFailCtx-            }-    , predicateDisp = disp-    , predicateDispNeg = dispNeg-    }- where-  disp = "isomorphic"-  dispNeg = "not isomorphic"--{----- Snapshot -----}---- | A predicate checking if the input matches the snapshot.--- See the "Snapshot tests" section in the README.------ >>> user `shouldSatisfy` P.matchesSnapshot-matchesSnapshot :: (Typeable a, MonadIO m) => Predicate m a-matchesSnapshot =-  Predicate-    { predicateFunc = \actual -> do-        SnapshotUpdateFlag doUpdate <- getFlag-        testInfo <- getTestInfo-        snapshotIndex <- getAndIncSnapshotIndex-        renderers <- getSnapshotRenderers-        let ctx =-              SnapshotContext-                { snapshotRenderers = renderers-                , snapshotTestInfo = testInfo-                , snapshotIndex-                }--        result <--          if doUpdate-            then updateSnapshot ctx actual >> pure SnapshotMatches-            else checkSnapshot ctx actual--        pure-          PredicateFuncResult-            { predicateSuccess = result == SnapshotMatches-            , predicateExplain =-                case result of-                  SnapshotMissing -> "Snapshot does not exist. Update snapshot with --update."-                  SnapshotMatches -> "Matches snapshot"-                  SnapshotDiff snapshot renderedActual ->-                    Text.intercalate "\n" $-                      [ "Result differed from snapshot. Update snapshot with --update."-                      , showLineDiff ("expected", snapshot) ("actual", renderedActual)-                      ]-            , predicateShowFailCtx = HideFailCtx-            }-    , predicateDisp = "matches snapshot"-    , predicateDispNeg = "does not match snapshot"-    }- {----- Utilities -----}  mkPredicateOp ::@@ -924,13 +889,3 @@  render :: a -> Text render = Text.pack . anythingToString---- | Add parentheses if the given input contains spaces.-parens :: Text -> Text-parens s =-  if " " `Text.isInfixOf` s-    then "(" <> s <> ")"-    else s--indent :: Text -> Text-indent = Text.intercalate "\n" . map ("  " <>) . Text.splitOn "\n"

@@ -21,6 +21,7 @@ import Data.Text qualified as Text import Skeletest.Internal.Constants (mainFileSpecsListIdentifier) import Skeletest.Internal.Error (SkeletestError (..))+import Skeletest.Internal.Utils.Text (showT) import System.Directory (doesDirectoryExist, listDirectory) import System.FilePath (makeRelative, splitExtensions, takeDirectory, (</>)) import Text.Read (readMaybe)@@ -42,7 +43,7 @@     }  encodeOptions :: Options -> Text-encodeOptions = Text.pack . show+encodeOptions = showT  decodeOptions :: Text -> Either Text Options decodeOptions = readEither . unquote@@ -72,7 +73,7 @@   addLine line f = line <> "\n" <> f   quoted s = "\"" <> s <> "\"" -  pluginMod = "Skeletest.Internal.Plugin"+  pluginMod = "Skeletest.Internal.PreprocessorPlugin"   quote s = "\"" <> Text.replace "\"" "\\\"" s <> "\""   pluginPragma =     Text.unwords

@@ -0,0 +1,240 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE ViewPatterns #-}++module Skeletest.Internal.PreprocessorPlugin (+  plugin,+) where++import Data.Functor.Const (Const (..))+import Data.Maybe (fromMaybe, listToMaybe)+import Data.Text qualified as Text+import Skeletest.Internal.Constants (mainFileSpecsListIdentifier)+import Skeletest.Internal.Error (skeletestPluginError)+import Skeletest.Internal.GHC+import Skeletest.Internal.Paths (setOriginalDirectory)+import Skeletest.Internal.Predicate qualified as P+import Skeletest.Internal.Preprocessor qualified as Preprocessor+import Skeletest.Internal.Utils.HList (HList (..))+import Skeletest.Internal.Utils.Text (showT)+import Skeletest.Main qualified as Main+import Skeletest.Plugin qualified as Plugin+import Skeletest.Prop.Internal qualified as P++#if !MIN_VERSION_base(4, 20, 0)+import Data.Foldable (foldl')+#endif++-- | The plugin to convert a module in the tests directory.+-- Injected by the preprocessor.+plugin :: Plugin+plugin =+  mkPlugin+    PluginDef+      { isPure = True+      , modifyParsed = \opts modName modl ->+          let options = decodeOptions opts+           in if modName == options.mainModuleName+                then transformMainModule options modl+                else modl+      , onRename = \_ ctx modName expr ->+          if "Spec" `Text.isSuffixOf` modName+            then transformTestModule ctx expr+            else expr+      }+ where+  decodeOptions =+    either (error . Text.unpack) id . \case+      [opts] -> Preprocessor.decodeOptions (Text.pack opts)+      _ -> Left ""++-- | Add 'main' function.+transformMainModule :: Preprocessor.Options -> ParsedModule -> ParsedModule+transformMainModule options modl =+  modl+    { moduleFuncs = (hsVarName options.mainFuncName, Just mainFun) : modl.moduleFuncs+    }+ where+  findVar name =+    fmap hsExprVar . listToMaybe $+      [ funName+      | (funName, _) <- modl.moduleFuncs+      , getHsName funName == name+      ]++  cliFlagsExpr = fromMaybe (hsExprList []) $ findVar "cliFlags"+  snapshotRenderersExpr = fromMaybe (hsExprList []) $ findVar "snapshotRenderers"+  hooksExpr = fromMaybe (hsExprVar $ hsName 'Plugin.defaultHooks) $ findVar "hooks"+  pluginsExpr = fromMaybe (hsExprList []) $ findVar "plugins"++  mainFun =+    FunDef+      { funType = HsTypeApps (HsTypeCon $ hsName ''IO) [HsTypeTuple []]+      , funPats = []+      , funBody =+          sequenceExpr+            [ setOriginalDirectoryExpr+            , runSkeletestExpr+            ]+      }+  sequenceExpr exprs = hsExprApps (hsExprVar $ hsName 'sequence_) [hsExprList exprs]+  setOriginalDirectoryExpr =+    hsExprApps (hsExprVar $ hsName 'setOriginalDirectory) $+      [hsExprLitString . Text.pack $ options.originalDirectory]+  runSkeletestExpr =+    hsExprApps+      (hsExprVar $ hsName 'Main.runSkeletest)+      [ hsExprApps (hsExprVar (hsName '(:))) $+          [ hsExprRecordCon+              (hsName 'Plugin.Plugin)+              [ (hsFieldName 'Plugin.Plugin "cliFlags", cliFlagsExpr)+              , (hsFieldName 'Plugin.Plugin "snapshotRenderers", snapshotRenderersExpr)+              , (hsFieldName 'Plugin.Plugin "hooks", hooksExpr)+              ]+          , pluginsExpr+          ]+      , hsExprVar $ hsVarName mainFileSpecsListIdentifier+      ]++transformTestModule :: Ctx -> HsExpr GhcRn -> HsExpr GhcRn+transformTestModule ctx =+  foldl' (.) id $+    [ replaceConMatch ctx+    , replaceIsoChecker ctx+    ]++-- | Replace all uses of P.con with P.conMatches. See P.con.+--+-- P.con $ User (P.eq "user1") (P.contains "@")+-- ====>+-- P.conMatches+--   "User"+--   Nothing+--   ( \case+--       User x0 x1 -> Just (HCons (pure x0) $ HCons (pure x1) $ HNil)+--       _ -> Nothing+--   )+--   (HCons (P.eq "user1") $ HCons (P.contains "@") $ HNil)+--+-- P.con User{name = P.eq "user1", email = P.contains "@"}+-- ====>+-- P.conMatches+--   "User"+--   (Just (HCons (Const "user") $ HCons (Const "email") $ HNil))+--   ( \case+--       User{name, email} -> Just (HCons (pure name) $ HCons (pure email) $ HNil)+--       _ -> Nothing+--   )+--   (HCons (P.eq "user1") $ HCons (P.contains "@") $ HNil)+replaceConMatch :: Ctx -> HsExpr GhcRn -> HsExpr GhcRn+replaceConMatch ctx e =+  case getExpr e of+    -- Matches:+    --   P.con User{name = ...}+    --   P.con (User "...")+    HsExprApps (getExpr -> HsExprVar name) [arg]+      | isCon name ->+          convertCon arg+    -- Matches:+    --   P.con $ User "..."+    HsExprOp (getExpr -> HsExprVar name) (getExpr -> HsExprVar dollar) arg+      | ctx.matchesName (hsName '($)) dollar+      , isCon name ->+          convertCon arg+    -- Check if P.con is by itself+    HsExprVar name+      | isCon name ->+          skeletestPluginError (getLoc e) "P.con must be applied to a constructor"+    -- Check if P.con is being applied more than once+    HsExprApps (getExpr -> HsExprVar name) (_ : _ : _)+      | isCon name ->+          skeletestPluginError (getLoc e) "P.con must be applied to exactly one argument"+    _ -> e+ where+  isCon = ctx.matchesName (hsName 'P.con)++  convertCon con =+    case getExpr con of+      HsExprCon conName -> convertPrefixCon conName []+      HsExprApps (getExpr -> HsExprCon conName) preds -> convertPrefixCon conName preds+      HsExprRecordCon conName fields -> convertRecordCon conName fields+      _ -> skeletestPluginError (getLoc e) "P.con must be applied to a constructor"+  convertPrefixCon conName preds =+    let+      exprNames = mkVarNames preds+     in+      hsExprApps (hsExprVar $ hsName 'P.conMatches) $+        [ hsExprLitString $ getHsName conName+        , hsExprCon $ hsName 'Nothing+        , mkDeconstruct (HsPatCon conName $ map HsPatVar exprNames) exprNames+        , mkPredList preds+        ]+  convertRecordCon conName fields =+    let+      (fieldNames, preds) = unzip fields+      fieldPats = [(field, HsPatVar field) | field <- fieldNames]+     in+      hsExprApps (hsExprVar $ hsName 'P.conMatches) $+        [ hsExprLitString $ getHsName conName+        , hsExprApps (hsExprCon $ hsName 'Just) [mkNamesList fieldNames]+        , mkDeconstruct (HsPatRecord conName fieldPats) fieldNames+        , mkPredList preds+        ]++  -- Generate variable names like x0, x1, ... for each element in the given list.+  mkVarNames =+    let mkVar i = "x" <> showT i+     in zipWith (\i _ -> hsVarName (mkVar i)) [0 :: Int ..]++  -- Create the deconstruction function:+  --+  -- \actual ->+  --   case actual of+  --     User{name} -> Just (HCons (pure name) HNil)+  --     _ -> Nothing+  --+  -- However, if 'User' is the only constructor, GHC complains about the wildcard+  -- being redundant. So we'll obfuscate it a bit with+  --+  -- \actual ->+  --   case pure actual of+  --     Just User{name} -> Just (HCons (pure name) HNil)+  --     _ -> Nothing+  mkDeconstruct pat argNames =+    hsExprLam [HsPatVar $ hsVarName "actual"] $+      hsExprCase (hsExprApps (hsExprVar $ hsName 'pure) [hsExprVar $ hsVarName "actual"]) $+        [ (HsPatCon (hsName 'Just) [pat], hsExprApps (hsExprCon $ hsName 'Just) [mkValsList argNames])+        , (HsPatWild, hsExprCon $ hsName 'Nothing)+        ]++  mkHList f = \case+    [] -> hsExprCon (hsName 'HNil)+    x : xs ->+      hsExprApps (hsExprCon $ hsName 'HCons) $+        [ f x+        , mkHList f xs+        ]++  mkNamesList = mkHList $ \name -> hsExprApps (hsExprCon $ hsName 'Const) [hsExprLitString $ getHsName name]+  mkValsList = mkHList $ \val -> hsExprApps (hsExprVar $ hsName 'pure) [hsExprVar val]+  mkPredList = mkHList id++-- | Replace all uses of P.=== with inlined IsoChecker value, with+-- function name filled in.+--+-- (encode . decode) P.=== id+-- ====>+-- IsoChecker (Fun "encode . decode" (encode . decode)) (Fun "id" id)+replaceIsoChecker :: Ctx -> HsExpr GhcRn -> HsExpr GhcRn+replaceIsoChecker ctx e =+  case getExpr e of+    HsExprOp l (getExpr -> HsExprVar eqeqeq) r+      | ctx.matchesName (hsName '(P.===)) eqeqeq ->+          inlineIsoChecker l r+    _ -> e+ where+  inlineIsoChecker l r = hsExprApps (hsExprCon $ hsName 'P.IsoChecker) [mkFun l, mkFun r]+  mkFun f = hsExprApps (hsExprCon $ hsName 'P.Fun) [hsExprLitString $ renderHsExpr f, f]

@@ -1,56 +1,65 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoFieldSelectors #-}  module Skeletest.Internal.Snapshot (-  -- * Running snapshot-  SnapshotContext (..),-  SnapshotResult (..),-  updateSnapshot,-  checkSnapshot,+  -- * Predicate+  matchesSnapshot,    -- * Rendering-  SnapshotRenderer (..),-  defaultSnapshotRenderers,-  setSnapshotRenderers,-  getSnapshotRenderers,-  plainRenderer,-  renderWithShow,+  X.SnapshotRenderer (..),+  X.setSnapshotRenderers,+  X.getSnapshotRenderers,+  X.plainRenderer,+  X.renderWithShow,    -- ** SnapshotFile   SnapshotFile (..),+  SnapshotTestId,+  mkSnapshotTestId,   SnapshotValue (..),   decodeSnapshotFile,   encodeSnapshotFile,   normalizeSnapshotFile, -  -- * Infrastructure-  getAndIncSnapshotIndex,-  SnapshotUpdateFlag (..),+  -- * Plugin+  snapshotPlugin, ) where -import Control.Monad.IO.Class (MonadIO)-import Control.Monad.Trans.Except (runExceptT, throwE)-import Data.Aeson qualified as Aeson-import Data.Aeson.Encode.Pretty qualified as Aeson+import Control.Monad (guard, unless, when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Except qualified as Except+import Control.Monad.Trans.Maybe qualified as Maybe+import Control.Monad.Trans.State.Strict qualified as State import Data.Char (isAlpha, isPrint)+import Data.Foldable qualified as Seq (toList)+import Data.List (sortOn)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Map.Merge.Strict qualified as Map import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map-import Data.Maybe (fromMaybe, mapMaybe)+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)+import Data.Sequence (Seq)+import Data.Sequence qualified as Seq+import Data.Set (Set)+import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text import Data.Text.IO qualified as Text-import Data.Text.Lazy qualified as TextL-import Data.Text.Lazy.Encoding qualified as TextL import Data.Typeable (Typeable) import Data.Typeable qualified as Typeable import Data.Void (absurd) import Debug.RecoverRTTI (anythingToString)-import Skeletest.Internal.CLI (FlagSpec (..), IsFlag (..))-import Skeletest.Internal.Error (SkeletestError (..), invariantViolation)+import Skeletest.Internal.CLI (FlagSpec (..), IsFlag (..), getFlag)+import Skeletest.Internal.CLI qualified as CLI+import Skeletest.Internal.Error (skeletestError)+import Skeletest.Internal.Exit (TestExitCode (..)) import Skeletest.Internal.Fixtures (   Fixture (..),   FixtureScope (..),@@ -58,68 +67,90 @@   noCleanup,   withCleanup,  )-import Skeletest.Internal.Paths (readTestFile)+import Skeletest.Internal.Hooks qualified as Hooks+import Skeletest.Internal.Paths (listTestFiles, readTestFile)+import Skeletest.Internal.Predicate (+  Predicate (..),+  PredicateFuncResult (..),+  ShowFailCtx (..),+ )+import Skeletest.Internal.Snapshot.Renderer (+  SnapshotRenderer (..),+  defaultSnapshotRenderers,+  getSnapshotRenderers,+ )+import Skeletest.Internal.Snapshot.Renderer qualified as X import Skeletest.Internal.TestInfo (TestInfo (..), getTestInfo)-import Skeletest.Internal.Utils.Map qualified as Map.Utils-import System.Directory (createDirectoryIfMissing)-import System.FilePath (replaceExtension, splitFileName, takeDirectory, (</>))+import Skeletest.Internal.Utils.Color qualified as Color+import Skeletest.Internal.Utils.Diff (showLineDiff)+import Skeletest.Internal.Utils.Term qualified as Term+import Skeletest.Internal.Utils.Text (pluralize, showT)+import Skeletest.Plugin (Hooks (..), Plugin (..), Spec, SpecInfo (..), SpecTest (..), SpecTree (..), TestResult (..), defaultHooks, defaultPlugin, getSpecTrees)+import System.FilePath (+  replaceExtension,+  splitFileName,+  takeDirectory,+  takeExtensions,+  (</>),+ ) import System.IO.Error (isDoesNotExistError) import System.IO.Unsafe (unsafePerformIO)-import UnliftIO.Exception (throwIO, try)+import UnliftIO.Directory (createDirectoryIfMissing, removeFile)+import UnliftIO.Exception (handleJust) import UnliftIO.IORef (   IORef,   atomicModifyIORef',   modifyIORef',   newIORef,   readIORef,-  writeIORef,  ) -{----- Infrastructure -----}--data SnapshotTestFixture = SnapshotTestFixture-  { snapshotIndexRef :: IORef Int-  }--instance Fixture SnapshotTestFixture where-  fixtureAction = do-    snapshotIndexRef <- newIORef 0-    pure . noCleanup $ SnapshotTestFixture{..}--getAndIncSnapshotIndex :: (MonadIO m) => m Int-getAndIncSnapshotIndex = do-  SnapshotTestFixture{snapshotIndexRef} <- getFixture-  atomicModifyIORef' snapshotIndexRef $ \i -> (i + 1, i)--data SnapshotFileFixture = SnapshotFileFixture-  { snapshotFileRef :: IORef (Maybe SnapshotFile)-  }--instance Fixture SnapshotFileFixture where-  fixtureScope = PerFileFixture-  fixtureAction = do-    TestInfo{file} <- getTestInfo-    let snapshotPath = getSnapshotPath file+-- | A predicate checking if the input matches the snapshot.+-- See the "Snapshot tests" section in the README.+--+-- >>> user `shouldSatisfy` P.matchesSnapshot+matchesSnapshot :: (Typeable a, MonadIO m) => Predicate m a+matchesSnapshot =+  Predicate+    { predicateFunc = \actual -> do+        SnapshotUpdateFlag doUpdate <- getFlag+        SnapshotChecker check <-+          if doUpdate+            then (.checker) <$> getFixture @UpdateSnapshotFixture+            else (.checker) <$> getFixture @CheckSnapshotFixture+        result <- liftIO $ check actual+        pure+          PredicateFuncResult+            { predicateSuccess = result == SnapshotMatches+            , predicateExplain =+                Text.intercalate "\n" $+                  case result of+                    SnapshotMissing renderedVal ->+                      [ "Snapshot does not exist. Update snapshot with --update."+                      , showLineDiff ("expected", "") ("actual", renderedVal)+                      ]+                    SnapshotMatches ->+                      [ "Matches snapshot"+                      ]+                    SnapshotDiff snapshot renderedActual ->+                      [ "Result differed from snapshot. Update snapshot with --update."+                      , showLineDiff ("expected", snapshot) ("actual", renderedActual)+                      ]+            , predicateShowFailCtx = HideFailCtx+            }+    , predicateDisp = "matches snapshot"+    , predicateDispNeg = "does not match snapshot"+    } -    mSnapshotFile <--      try (readTestFile snapshotPath) >>= \case-        Left e-          | isDoesNotExistError e -> pure Nothing-          | otherwise -> throwIO e-        Right contents ->-          case decodeSnapshotFile contents of-            Just snapshotFile -> pure $ Just snapshotFile-            Nothing -> throwIO $ SnapshotFileCorrupted snapshotPath-    let snapshotChanged newSnapshot = mSnapshotFile /= Just newSnapshot+{----- Plugin -----} -    snapshotFileRef <- newIORef mSnapshotFile-    pure . withCleanup SnapshotFileFixture{..} $-      -- write snapshot back out when file is done-      readIORef snapshotFileRef >>= \case-        Just snapshotFile | snapshotChanged snapshotFile -> do-          createDirectoryIfMissing True (takeDirectory snapshotPath)-          Text.writeFile snapshotPath $ encodeSnapshotFile $ normalizeSnapshotFile snapshotFile-        _ -> pure ()+snapshotPlugin :: Plugin+snapshotPlugin =+  defaultPlugin+    { hooks = snapshotsHook+    , cliFlags = [CLI.flag @SnapshotUpdateFlag]+    , snapshotRenderers = defaultSnapshotRenderers+    }  newtype SnapshotUpdateFlag = SnapshotUpdateFlag Bool @@ -129,53 +160,12 @@   flagHelp = "Update snapshots"   flagSpec = SwitchFlag SnapshotUpdateFlag -{----- Running snapshot -----}--data SnapshotContext = SnapshotContext-  { snapshotRenderers :: [SnapshotRenderer]-  , snapshotTestInfo :: TestInfo-  , snapshotIndex :: Int-  }--updateSnapshot :: (Typeable a, MonadIO m) => SnapshotContext -> a -> m ()-updateSnapshot snapshotContext testResult = do-  SnapshotFileFixture{snapshotFileRef} <- getFixture-  modifyIORef' snapshotFileRef (Just . setSnapshot . fromMaybe emptySnapshotFile)- where-  SnapshotContext-    { snapshotRenderers = renderers-    , snapshotTestInfo = testInfo@TestInfo{file}-    , snapshotIndex-    } = snapshotContext--  emptySnapshotFile =-    SnapshotFile-      { testFile = Text.pack file-      , snapshots = Map.empty-      }--  testIdentifier = toTestIdentifier testInfo-  renderedTestResult = renderVal renderers testResult-  setSnapshot snapshotFile@SnapshotFile{snapshots} =-    let setForTest = Map.Utils.adjustNested (setAt snapshotIndex renderedTestResult) testIdentifier-     in snapshotFile{snapshots = setForTest snapshots}--  -- Set the given snapshot at the given index. If the index is too large,-  -- fill in with empty snapshots.-  ---  -- >>> setAt 3 "x" ["a"] == ["a", "", "", "x"]-  setAt i0 v =-    let go = \cases-          i [] -> replicate i emptySnapshotVal <> [v]-          0 (_ : xs) -> v : xs-          i (x : xs) -> x : go (i - 1) xs-     in if i0 < 0-          then invariantViolation $ "Got negative snapshot index: " <> show i0-          else go i0-  emptySnapshotVal = SnapshotValue{snapshotContent = "", snapshotLang = Nothing}+data SnapshotChecker = SnapshotChecker (forall a. (Typeable a) => a -> IO SnapshotResult)  data SnapshotResult   = SnapshotMissing+      { renderedVal :: Text+      }   | SnapshotMatches   | SnapshotDiff       { snapshotContent :: Text@@ -183,70 +173,422 @@       }   deriving (Show, Eq) -checkSnapshot :: (Typeable a, MonadIO m) => SnapshotContext -> a -> m SnapshotResult-checkSnapshot snapshotContext testResult =-  fmap (either id absurd) . runExceptT $ do-    SnapshotFileFixture{snapshotFileRef} <- getFixture-    fileSnapshots <--      readIORef snapshotFileRef >>= \case-        Nothing -> returnE SnapshotMissing-        Just SnapshotFile{snapshots} -> pure snapshots+snapshotsHook :: Hooks+snapshotsHook =+  defaultHooks+    { modifySpecRegistry = Hooks.mkPreHook_ $ \_ registry -> do+        -- Collect before the applyTestSelections hook to check for snapshots+        -- that don't correspond to any tests anymore+        modifyIORef' snapshotInfoStoreRef $ \store ->+          store+            { allSnapshotTestIds =+                Map.fromList+                  [ (getSnapshotPath specPath, getTestIds spec)+                  | SpecInfo{..} <- registry+                  ]+            }+        pure ()+    , runTest =+        Hooks.mkHook_+          ( \_ _ -> do+              SnapshotUpdateFlag isUpdate <- getFlag+              when isUpdate $ do+                -- Always initialize the file fixture to ensure snapshots get+                -- cleaned up for a test that removed all `P.matchesSnapshot`+                -- checks+                _ <- getFixture @UpdateSnapshotFixture_File+                pure ()+          )+          ( \ctx _ result -> do+              SnapshotUpdateFlag isUpdate <- getFlag+              when result.status.success $ do+                if isUpdate+                  then recordSnapshotsToFileFixture ctx.testInfo+                  else checkExtraTestSnapshots ctx.testInfo+              pure ()+          )+    , runSpecs = Hooks.mkPostHook $ \_ _ code -> do+        SnapshotUpdateFlag isUpdate <- getFlag+        if isUpdate+          then removeOutdatedSnapshots *> pure code+          else checkOutdatedSnapshots code+    , modifyTestSummary = Hooks.mkPreHook $ \_ summary -> do+        snapshotSummary <- getSnapshotSummary+        pure $ summary <> snapshotSummary+    } -    let snapshots = Map.Utils.findOrEmpty (toTestIdentifier testInfo) fileSnapshots-    snapshot <- maybe (returnE SnapshotMissing) pure $ safeIndex snapshots snapshotIndex+-- | Snapshot-related information to store globally.+data SnapshotInfoStore = SnapshotInfoStore+  { allSnapshotTestIds :: !(Map FilePath [SnapshotTestId])+  -- ^ Map from a test file's snapshot path to all test ids in the file+  , snapshotFilesWithExtraSnapshots :: !(Set FilePath)+  -- ^ Snapshot files that contain tests that contain extraneous snapshots.+  , numSnapshotsUpdated :: !Int+  -- ^ Number of snapshots that were updated+  , numSnapshotFilesCleanedUp :: !Int+  -- ^ Number of snapshot files that were cleaned up+  } -    let (snapshotContent, renderedTestResult) = (getContent snapshot, getContent renderedTestResultVal)-    returnE $-      if snapshotContent == renderedTestResult-        then SnapshotMatches-        else SnapshotDiff{snapshotContent, renderedTestResult}+-- | Map from "Test file's snapshot path" => "All test ids in the test file"+snapshotInfoStoreRef :: IORef SnapshotInfoStore+snapshotInfoStoreRef =+  unsafePerformIO . newIORef $+    SnapshotInfoStore+      { allSnapshotTestIds = Map.empty+      , snapshotFilesWithExtraSnapshots = Set.empty+      , numSnapshotsUpdated = 0+      , numSnapshotFilesCleanedUp = 0+      }+{-# NOINLINE snapshotInfoStoreRef #-}++getTestIds :: Spec -> [SnapshotTestId]+getTestIds = concatMap (go Seq.empty) . getSpecTrees  where-  SnapshotContext-    { snapshotRenderers = renderers-    , snapshotTestInfo = testInfo-    , snapshotIndex-    } = snapshotContext+  go context = \case+    group@SpecTree_Group{} -> concatMap (go (context Seq.|> group.label)) group.trees+    SpecTree_Test test -> [mkSnapshotTestId . Seq.toList $ context Seq.|> test.name] -  returnE = throwE-  renderedTestResultVal = renderVal renderers testResult+-- | Detect outdated snapshots, returning the filepath to the outdated+-- snapshot and the action to clean it up.+detectOutdatedSnapshots :: IO [(FilePath, IO ())]+detectOutdatedSnapshots = do+  allSnapshotFiles <- filter isSnapshotFile <$> listTestFiles+  store <- readIORef snapshotInfoStoreRef+  let allTests = Map.map Set.fromList store.allSnapshotTestIds+  mapMaybeM (detectOutdated allTests) allSnapshotFiles+ where+  isSnapshotFile fp = takeExtensions fp == ".snap.md"+  mapMaybeM f = fmap catMaybes . mapM f -  safeIndex xs0 i0 =-    let go = \cases-          _ [] -> Nothing-          0 (x : _) -> Just x-          i (_ : xs) -> go (i - 1) xs-     in if i0 < 0 then Nothing else go i0 xs0+  detectOutdated allTests = runDetectOutdatedM $ \snapshotFilePath -> do+    testIds <-+      case Map.lookup snapshotFilePath allTests of+        Just testIds -> pure testIds+        -- If Nothing, snapshot file does not correspond to any tests+        Nothing -> returnOutdated $ cleanupFile snapshotFilePath +    contents <- liftIO $ Text.readFile snapshotFilePath++    snapshotFile <-+      case decodeSnapshotFile contents of+        Just file -> pure file+        -- If Nothing, snapshot file is corrupted; we'll treat it the same as outdated.+        -- If this happens when '--update' is passed, it means no more tests in+        -- the file have snapshots, since it would've been regenerated. So just+        -- remove the snapshot file if we still encounter this.+        Nothing -> returnOutdated $ cleanupFile snapshotFilePath++    let outdatedSnapshots = Map.keysSet snapshotFile.snapshots Set.\\ testIds+    unless (null outdatedSnapshots) $+      returnOutdated $ do+        modifyIORef' snapshotInfoStoreRef $ \store ->+          store{numSnapshotsUpdated = store.numSnapshotsUpdated + length outdatedSnapshots}+        let snapshots' = Map.withoutKeys snapshotFile.snapshots outdatedSnapshots+        saveSnapshotFile snapshotFilePath snapshotFile{snapshots = snapshots'}++  cleanupFile path = do+    modifyIORef' snapshotInfoStoreRef $ \store ->+      store{numSnapshotFilesCleanedUp = store.numSnapshotFilesCleanedUp + 1}+    removeFile path++  runDetectOutdatedM ::+    (FilePath -> Except.ExceptT (IO ()) IO ()) ->+    FilePath ->+    IO (Maybe (FilePath, IO ()))+  runDetectOutdatedM action fp =+    either (\io -> Just (fp, io)) (\_ -> Nothing)+      <$> Except.runExceptT (action fp)+  returnOutdated = Except.throwE++removeOutdatedSnapshots :: IO ()+removeOutdatedSnapshots = mapM_ snd =<< detectOutdatedSnapshots++checkOutdatedSnapshots :: TestExitCode -> IO TestExitCode+checkOutdatedSnapshots code = do+  outdated <- map fst <$> detectOutdatedSnapshots+  store <- readIORef snapshotInfoStoreRef+  let outdated' = Set.fromList outdated <> store.snapshotFilesWithExtraSnapshots+  if Set.null outdated'+    then pure code+    else do+      mapM_ Term.output . concat $+        [ [""]+        , ["╓─ 🚨 " <> Color.bold "Outdated snapshots detected" <> " ────────────────"]+        , ["║  * " <> Text.pack fp | fp <- Set.toAscList outdated']+        , ["║"]+        , ["║  Update/remove these files with --update."]+        , ["╙─────────────────────────────────────────────────"]+        ]+      pure ExitOutdatedSnapshots++getSnapshotSummary :: IO Text+getSnapshotSummary = do+  store <- readIORef snapshotInfoStoreRef+  pure . Text.unlines . concat $+    [ when_ (store.numSnapshotsUpdated > 0) $+        "➤ " <> pluralize store.numSnapshotsUpdated "snapshot" <> " updated"+    , when_ (store.numSnapshotFilesCleanedUp > 0) $+        "➤ " <> pluralize store.numSnapshotFilesCleanedUp "snapshot file" <> " cleaned up"+    ]+ where+  when_ p x = if p then [x] else []++{----- Update snapshot -----}++-- | Collect snapshots for all tests in a file.+-- When test file is done, merge new snapshots into the existing snapshot file+-- and write to disk if it's changed.+data UpdateSnapshotFixture_File = UpdateSnapshotFixture_File+  { newFileSnapshotsRef :: IORef (Map SnapshotTestId [SnapshotValue])+  }++instance Fixture UpdateSnapshotFixture_File where+  fixtureScope = PerFileFixture+  fixtureAction = do+    testInfo <- getTestInfo+    newFileSnapshotsRef <- newIORef Map.empty+    pure . withCleanup UpdateSnapshotFixture_File{newFileSnapshotsRef} $ do+      finalizeUpdateSnapshotFixture testInfo newFileSnapshotsRef++data UpdateSnapshotFixture = UpdateSnapshotFixture+  { checker :: SnapshotChecker+  , newSnapshotsRef :: IORef (Seq SnapshotValue)+  }++instance Fixture UpdateSnapshotFixture where+  fixtureScope = PerTestFixture+  fixtureAction = do+    newSnapshotsRef <- newIORef Seq.empty+    let checker = SnapshotChecker (recordSnapshot newSnapshotsRef)+    pure $ noCleanup UpdateSnapshotFixture{checker, newSnapshotsRef}++-- | Collect `P.matchesSnapshot` results into a list per test.+recordSnapshot :: (Typeable a) => IORef (Seq SnapshotValue) -> a -> IO SnapshotResult+recordSnapshot newSnapshotsRef val = do+  renderers <- getSnapshotRenderers+  let newSnapshotVal = renderVal renderers val+  modifyIORef' newSnapshotsRef (Seq.|> newSnapshotVal)+  pure SnapshotMatches++-- | Copy snapshots to the file fixture when test is over.+recordSnapshotsToFileFixture :: TestInfo -> IO ()+recordSnapshotsToFileFixture testInfo = do+  UpdateSnapshotFixture_File{newFileSnapshotsRef} <- getFixture+  UpdateSnapshotFixture{newSnapshotsRef} <- getFixture+  newSnapshots <- Seq.toList <$> readIORef newSnapshotsRef+  modifyIORef' newFileSnapshotsRef (Map.insert (getSnapshotTestId testInfo) newSnapshots)++finalizeUpdateSnapshotFixture :: TestInfo -> IORef (Map SnapshotTestId [SnapshotValue]) -> IO ()+finalizeUpdateSnapshotFixture testInfo newFileSnapshotsRef = do+  let snapshotPath = getSnapshotPath testInfo.file+  snapshotFile <-+    loadSnapshotFile snapshotPath >>= \case+      SnapshotFileLoadResult_Exists file -> pure file+      _ -> pure $ emptySnapshotFile (Text.pack testInfo.file)+  newSnapshots <- Map.map Seq.toList <$> readIORef newFileSnapshotsRef+  let snapshots' = mergeSnapshots snapshotFile.snapshots newSnapshots+  when (snapshots' /= snapshotFile.snapshots) $ do+    modifyIORef' snapshotInfoStoreRef $ \store ->+      store{numSnapshotsUpdated = store.numSnapshotsUpdated + countChanges snapshotFile.snapshots snapshots'}+    saveSnapshotFile snapshotPath snapshotFile{snapshots = snapshots'}+ where+  countChanges old new =+    flip State.execState 0 $+      Map.mergeA+        ( Map.traverseMissing $ \_ snaps -> do+            State.modify' (+ length snaps)+        )+        ( Map.traverseMissing $ \_ snaps -> do+            State.modify' (+ length snaps)+        )+        ( Map.zipWithAMatched $ \_ snapsOld snapsNew -> do+            let (snapsOld', snapsNew') = (Set.fromList snapsOld, Set.fromList snapsNew)+            let added = Set.size $ snapsNew' Set.\\ snapsOld'+            let removed = Set.size $ snapsOld' Set.\\ snapsNew'+            State.modify' (+ (added + removed))+        )+        old+        new++  -- Merge snapshots, to avoid clearing snapshots of tests that were deselected.+  -- Extraneous snapshots will be cleared by 'detectOutdatedSnapshots'.+  mergeSnapshots old new =+    Map.filter (not . null) $+      Map.merge+        Map.preserveMissing -- Keep snapshots for tests that weren't run+        Map.preserveMissing -- Add new snapshots+        (Map.zipWithMatched $ \_ _o n -> n) -- Overwrite old snapshots+        old+        new++{----- Check snapshot -----}++data CheckSnapshotFixture_File = CheckSnapshotFixture_File+  { mSnapshotFile :: Maybe SnapshotFile+  }++instance Fixture CheckSnapshotFixture_File where+  fixtureScope = PerFileFixture+  fixtureAction = do+    testFile <- (.file) <$> getTestInfo+    let snapshotPath = getSnapshotPath testFile+    mSnapshotFile <-+      loadSnapshotFile snapshotPath >>= \case+        SnapshotFileLoadResult_Exists file -> pure $ Just file+        SnapshotFileLoadResult_Missing -> pure Nothing+        SnapshotFileLoadResult_Corrupted -> skeletestError $ "Snapshot file was corrupted: " <> Text.pack snapshotPath+    pure $ noCleanup CheckSnapshotFixture_File{mSnapshotFile}++data CheckSnapshotFixture = CheckSnapshotFixture+  { checker :: SnapshotChecker+  , snapshotIndexRef :: IORef Int+  }++instance Fixture CheckSnapshotFixture where+  fixtureScope = PerTestFixture+  fixtureAction = do+    testInfo <- getTestInfo+    snapshotIndexRef <- newIORef 0+    let checker = SnapshotChecker (runCheckSnapshot testInfo snapshotIndexRef)+    pure $ noCleanup CheckSnapshotFixture{checker, snapshotIndexRef}++runCheckSnapshot :: (Typeable a) => TestInfo -> IORef Int -> a -> IO SnapshotResult+runCheckSnapshot testInfo snapshotIndexRef val = runReturnE $ do+  CheckSnapshotFixture_File{mSnapshotFile} <- getFixture+  renderers <- getSnapshotRenderers++  let newSnapshotVal = renderVal renderers val+      snapshotMissing = SnapshotMissing newSnapshotVal.content++  index <- atomicModifyIORef' snapshotIndexRef $ \index -> (index + 1, index)++  snapshotFile <- maybe (returnE snapshotMissing) pure mSnapshotFile+  let testSnapshots = Map.findWithDefault [] (getSnapshotTestId testInfo) snapshotFile.snapshots+  snapshot <-+    maybe (returnE snapshotMissing) (pure . NonEmpty.head) $+      (NonEmpty.nonEmpty . drop index) testSnapshots++  returnE $+    if snapshot.content == newSnapshotVal.content+      then SnapshotMatches+      else+        SnapshotDiff+          { snapshotContent = snapshot.content+          , renderedTestResult = newSnapshotVal.content+          }+ where+  runReturnE = fmap (either id absurd) . Except.runExceptT+  returnE = Except.throwE++-- | Check if the snapshot file contains any extra snapshots for the current test+checkExtraTestSnapshots :: TestInfo -> IO ()+checkExtraTestSnapshots testInfo = do+  CheckSnapshotFixture_File{mSnapshotFile} <- getFixture+  fmap (fromMaybe ()) . Maybe.runMaybeT $ do+    snapshotFile <- Maybe.hoistMaybe mSnapshotFile+    testSnapshots <- Maybe.hoistMaybe $ Map.lookup (getSnapshotTestId testInfo) snapshotFile.snapshots+    CheckSnapshotFixture{snapshotIndexRef} <- getFixture+    index <- readIORef snapshotIndexRef+    when (length testSnapshots > index) $ do+      let snapshotPath = getSnapshotPath $ Text.unpack snapshotFile.testFile+      modifyIORef' snapshotInfoStoreRef $ \store ->+        store+          { snapshotFilesWithExtraSnapshots =+              Set.insert snapshotPath store.snapshotFilesWithExtraSnapshots+          }+ {----- Snapshot file -----}  data SnapshotFile = SnapshotFile   { testFile :: Text-  , snapshots :: Map TestIdentifier [SnapshotValue]-  -- ^ full test identifier => snapshots-  -- e.g. ["group1", "group2", "returns val1 and val2"] => ["val1", "val2"]+  , snapshots :: Map SnapshotTestId [SnapshotValue]+  -- ^ Map from test identifier to its snapshots, e.g.+  -- "group1 ≫ group2 ≫ returns val1 and val2" => ["val1", "val2"]   }   deriving (Show, Eq) +newtype SnapshotTestId = SnapshotTestId Text+  deriving (Show, Eq, Ord)+ data SnapshotValue = SnapshotValue-  { snapshotContent :: Text-  , snapshotLang :: Maybe Text+  { content :: Text+  , lang :: Maybe Text   }-  deriving (Show, Eq)+  deriving (Show, Eq, Ord) -getContent :: SnapshotValue -> Text-getContent SnapshotValue{snapshotContent} = snapshotContent+mkSnapshotTestId :: [Text] -> SnapshotTestId+mkSnapshotTestId =+  SnapshotTestId+    . Text.intercalate " ≫ "+    . map (sanitizeNonPrint . sanitizeArrows . Text.strip)+ where+  sanitizeArrows = Text.replace "≫" ">>" -type TestIdentifier = [Text]+  -- Replace non-print characters with their escaped representations+  sanitizeNonPrint s =+    case Text.break (not . isPrint) s of+      (_, "") -> s -- quick exit in common case where text names are all printable chars+      (pre, post) -> pre <> Text.concatMap escapeChar post+   where+    escapeChar c =+      if isPrint c+        then Text.singleton c+        else Text.drop 1 . Text.dropEnd 1 . showT $ c +getSnapshotTestId :: TestInfo -> SnapshotTestId+getSnapshotTestId testInfo = mkSnapshotTestId $ testInfo.contexts <> [testInfo.name]+ getSnapshotPath :: FilePath -> FilePath-getSnapshotPath testFile = testDir </> "__snapshots__" </> snapshotFileName+getSnapshotPath testFile = stripDotSlash $ testDir </> "__snapshots__" </> snapshotFileName  where   (testDir, testFileName) = splitFileName testFile   snapshotFileName = replaceExtension testFileName ".snap.md"+  stripDotSlash = \case+    '.' : '/' : dir -> dir+    dir -> dir -toTestIdentifier :: TestInfo -> TestIdentifier-toTestIdentifier TestInfo{contexts, name} = contexts <> [name]+emptySnapshotFile :: Text -> SnapshotFile+emptySnapshotFile testFile =+  SnapshotFile+    { testFile+    , snapshots = Map.empty+    } +data SnapshotFileLoadResult+  = SnapshotFileLoadResult_Missing+  | SnapshotFileLoadResult_Corrupted+  | SnapshotFileLoadResult_Exists SnapshotFile++loadSnapshotFile :: FilePath -> IO SnapshotFileLoadResult+loadSnapshotFile path =+  handleDNE (\_ -> pure SnapshotFileLoadResult_Missing) $ do+    contents <- readTestFile path+    pure $+      case decodeSnapshotFile contents of+        Just file -> SnapshotFileLoadResult_Exists file+        Nothing -> SnapshotFileLoadResult_Corrupted+ where+  handleDNE = handleJust (\e -> guard (isDoesNotExistError e) *> Just e)++saveSnapshotFile :: FilePath -> SnapshotFile -> IO ()+saveSnapshotFile path snapshotFile =+  if Map.null snapshotFile.snapshots+    then removeFile path+    else do+      rankTestId <- mkRankTestId <$> readIORef snapshotInfoStoreRef+      createDirectoryIfMissing True (takeDirectory path)+      Text.writeFile path . encodeSnapshotFile rankTestId . normalizeSnapshotFile $+        snapshotFile+ where+  mkRankTestId store =+    let testIds = Map.findWithDefault [] path store.allSnapshotTestIds+        testIdToRank = Map.fromList $ zip testIds [0 ..]+     in \testId ->+          Map.findWithDefault+            (maxBound @Int) -- Shouldn't happen, but just in case+            testId+            testIdToRank+ decodeSnapshotFile :: Text -> Maybe SnapshotFile decodeSnapshotFile = parseFile . Text.lines  where@@ -262,34 +604,34 @@     _ -> Nothing    parseSections ::-    SnapshotFile ->-    -- \^ The parsed snapshot file so far-    Maybe [Text] ->-    -- \^ The current test identifier, if one is set-    [Text] ->-    -- \^ The rest of the lines to process+    SnapshotFile -> -- The parsed snapshot file so far+    Maybe SnapshotTestId -> -- The current test identifier, if one is set+    [Text] -> -- The rest of the lines to process     Maybe SnapshotFile-  parseSections snapshotFile@SnapshotFile{snapshots} mTest = \case+  parseSections snapshotFile mTest = \case     [] -> pure snapshotFile     line : rest       -- ignore empty lines       | "" <- Text.strip line -> parseSections snapshotFile mTest rest       -- found a test section       | Just sectionName <- Text.stripPrefix "## " line -> do-          let testIdentifier = map Text.strip $ Text.splitOn " / " sectionName-          let snapshotFile' = snapshotFile{snapshots = Map.insert testIdentifier [] snapshots}+          let testIdentifier+                -- Backwards compat, skeletest < 0.4 separated with "/"+                | not $ "≫" `Text.isInfixOf` sectionName = mkSnapshotTestId $ Text.splitOn " / " sectionName+                | otherwise = SnapshotTestId sectionName+          let snapshotFile' = snapshotFile{snapshots = Map.insert testIdentifier [] snapshotFile.snapshots}           parseSections snapshotFile' (Just testIdentifier) rest       -- found the beginning of a snapshot-      | Just lang <- (Text.stripPrefix "```" . Text.strip) line -> do+      | Just lang <- Text.stripPrefix "```" line -> do           testIdentifier <- mTest-          (snapshot, rest') <- parseSnapshot [] rest+          (snapshot, rest') <- parseSnapshot Seq.empty rest           let             snapshotVal =               SnapshotValue-                { snapshotContent = snapshot-                , snapshotLang = if Text.null lang then Nothing else Just lang+                { content = snapshot+                , lang = if Text.null lang then Nothing else Just lang                 }-            snapshotFile' = snapshotFile{snapshots = Map.adjust (<> [snapshotVal]) testIdentifier snapshots}+            snapshotFile' = snapshotFile{snapshots = Map.adjust (<> [snapshotVal]) testIdentifier snapshotFile.snapshots}           parseSections snapshotFile' mTest rest'       -- anything else is invalid       | otherwise -> Nothing@@ -297,75 +639,32 @@   parseSnapshot snapshot = \case     [] -> Nothing     line : rest-      | "```" <- Text.strip line -> pure (Text.unlines snapshot, rest)-      | otherwise -> parseSnapshot (snapshot <> [line]) rest+      | "```" <- line -> pure (Text.unlines $ Seq.toList snapshot, rest)+      | otherwise -> parseSnapshot (snapshot Seq.|> line) rest -encodeSnapshotFile :: SnapshotFile -> Text-encodeSnapshotFile SnapshotFile{..} =-  Text.intercalate "\n" $-    h1 testFile : concatMap toSection (Map.toList snapshots)+encodeSnapshotFile :: (SnapshotTestId -> Int) -> SnapshotFile -> Text+encodeSnapshotFile rankTestId snapshotFile =+  Text.intercalate "\n" $ h1 snapshotFile.testFile : concatMap toSection snapshots  where-  toSection (testIdentifier, snaps) =-    h2 (Text.intercalate " / " testIdentifier) : map codeBlock snaps+  snapshots = sortOn (rankTestId . fst) . Map.toList $ snapshotFile.snapshots+  toSection (SnapshotTestId testId, snaps) = h2 testId : map codeBlock snaps    h1 s = "# " <> s <> "\n"   h2 s = "## " <> s <> "\n"-  codeBlock SnapshotValue{..} =+  codeBlock snapshot =     Text.concat-      [ "```" <> fromMaybe "" snapshotLang <> "\n"-      , snapshotContent+      [ "```" <> fromMaybe "" snapshot.lang <> "\n"+      , snapshot.content       , "```\n"       ]  normalizeSnapshotFile :: SnapshotFile -> SnapshotFile-normalizeSnapshotFile file@SnapshotFile{snapshots} =+normalizeSnapshotFile file =   file-    { snapshots = Map.fromList . map normalize . Map.toList $ snapshots-    }- where-  normalize (testIdentifier, vals) =-    ( map (sanitizeNonPrint . sanitizeSlashes . Text.strip) testIdentifier-    , map normalizeSnapshotVal vals-    )--  sanitizeSlashes = Text.replace " /" " \\/"--  sanitizeNonPrint = Text.concatMap $ \case-    c | (not . isPrint) c -> Text.drop 1 . Text.dropEnd 1 . Text.pack . show $ c-    c -> Text.singleton c--{----- Renderers -----}--data SnapshotRenderer-  = forall a.-  (Typeable a) =>-  SnapshotRenderer-  { render :: a -> Text-  , snapshotLang :: Maybe Text-  }--plainRenderer :: (Typeable a) => (a -> Text) -> SnapshotRenderer-plainRenderer render =-  SnapshotRenderer-    { render-    , snapshotLang = Nothing+    { snapshots = map normalizeSnapshotVal <$> file.snapshots     } -renderWithShow :: forall a. (Typeable a, Show a) => SnapshotRenderer-renderWithShow = plainRenderer (Text.pack . show @a)--defaultSnapshotRenderers :: [SnapshotRenderer]-defaultSnapshotRenderers =-  [ plainRenderer @String Text.pack-  , plainRenderer @Text id-  , jsonRenderer-  ]- where-  jsonRenderer =-    SnapshotRenderer-      { render = TextL.toStrict . TextL.decodeUtf8 . Aeson.encodePretty @Aeson.Value-      , snapshotLang = Just "json"-      }+{----- Render values -----}  renderVal :: (Typeable a) => [SnapshotRenderer] -> a -> SnapshotValue renderVal renderers a =@@ -373,35 +672,29 @@     case mapMaybe tryRender renderers of       [] ->         SnapshotValue-          { snapshotContent = Text.pack $ anythingToString a-          , snapshotLang = Nothing+          { content = Text.pack $ anythingToString a+          , lang = Nothing           }       rendered : _ -> rendered  where-  tryRender SnapshotRenderer{..} =-    let toValue v = SnapshotValue{snapshotContent = render v, snapshotLang}+  tryRender renderer@SnapshotRenderer{render} =+    let toValue v = SnapshotValue{content = render v, lang = renderer.snapshotLang}      in toValue <$> Typeable.cast a  normalizeSnapshotVal :: SnapshotValue -> SnapshotValue-normalizeSnapshotVal SnapshotValue{..} =+normalizeSnapshotVal snapshot =   SnapshotValue-    { snapshotContent = normalizeTrailingNewlines snapshotContent-    , snapshotLang = collapse $ Text.filter isAlpha <$> snapshotLang+    { content =+        normalizeTrailingNewlines+          . sanitizeBackTicks+          $ snapshot.content+    , lang = collapse $ Text.filter isAlpha <$> snapshot.lang     }  where   collapse = \case     Just "" -> Nothing     m -> m +  sanitizeBackTicks = Text.replace "```" "\\`\\`\\`"   -- Ensure there's exactly one trailing newline.   normalizeTrailingNewlines s = Text.dropWhileEnd (== '\n') s <> "\n"--snapshotRenderersRef :: IORef [SnapshotRenderer]-snapshotRenderersRef = unsafePerformIO $ newIORef []-{-# NOINLINE snapshotRenderersRef #-}--setSnapshotRenderers :: [SnapshotRenderer] -> IO ()-setSnapshotRenderers = writeIORef snapshotRenderersRef--getSnapshotRenderers :: (MonadIO m) => m [SnapshotRenderer]-getSnapshotRenderers = readIORef snapshotRenderersRef

@@ -0,0 +1,66 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedStrings #-}++module Skeletest.Internal.Snapshot.Renderer (+  SnapshotRenderer (..),+  getSnapshotRenderers,+  setSnapshotRenderers,++  -- * Renderer implementations+  plainRenderer,+  renderWithShow,+  defaultSnapshotRenderers,+) where++import Control.Monad.IO.Class (MonadIO)+import Data.Aeson qualified as Aeson+import Data.Aeson.Encode.Pretty qualified as Aeson+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Lazy qualified as TextL+import Data.Text.Lazy.Encoding qualified as TextL+import Data.Typeable (Typeable)+import Skeletest.Internal.Utils.Text (showT)+import System.IO.Unsafe (unsafePerformIO)+import UnliftIO.IORef (IORef, newIORef, readIORef, writeIORef)++data SnapshotRenderer+  = forall a.+  (Typeable a) =>+  SnapshotRenderer+  { render :: a -> Text+  , snapshotLang :: Maybe Text+  }++plainRenderer :: (Typeable a) => (a -> Text) -> SnapshotRenderer+plainRenderer render =+  SnapshotRenderer+    { render+    , snapshotLang = Nothing+    }++renderWithShow :: forall a. (Typeable a, Show a) => SnapshotRenderer+renderWithShow = plainRenderer (showT @a)++defaultSnapshotRenderers :: [SnapshotRenderer]+defaultSnapshotRenderers =+  [ plainRenderer @String Text.pack+  , plainRenderer @Text id+  , jsonRenderer+  ]+ where+  jsonRenderer =+    SnapshotRenderer+      { render = TextL.toStrict . TextL.decodeUtf8 . Aeson.encodePretty @Aeson.Value+      , snapshotLang = Just "json"+      }++snapshotRenderersRef :: IORef [SnapshotRenderer]+snapshotRenderersRef = unsafePerformIO $ newIORef []+{-# NOINLINE snapshotRenderersRef #-}++setSnapshotRenderers :: [SnapshotRenderer] -> IO ()+setSnapshotRenderers = writeIORef snapshotRenderersRef++getSnapshotRenderers :: (MonadIO m) => m [SnapshotRenderer]+getSnapshotRenderers = readIORef snapshotRenderersRef

@@ -1,15 +1,20 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoFieldSelectors #-}  module Skeletest.Internal.Spec (   -- * Spec interface   X.Spec,+  X.SpecM,   X.SpecTree (..),    -- ** Execution-  runSpecs,+  SpecRunner,+  newSpecRunner,    -- ** Entrypoint   X.SpecRegistry,@@ -20,7 +25,6 @@   X.Testable (..),   X.test,   X.it,-  X.prop,    -- ** Modifiers   X.xfail,@@ -33,29 +37,40 @@   X.withMarkers,   X.withMarker, -  -- ** Built-in hooks-  applyTestSelectionsHook,-  manualTestsHook,-  xfailHook,-  skipHook,-  focusHook,+  -- ** Runtime functionality+  skipTest,++  -- ** Plugin+  specTreePlugin, ) where  import Control.Concurrent (myThreadId)-import Control.Monad (forM)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.Trans.State.Strict qualified as State+import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe)+import Data.Text (Text) import Data.Text qualified as Text-import Data.Text.IO qualified as Text-import Skeletest.Internal.Capture (addCapturedOutput, withCaptureOutput)+import Data.Time (NominalDiffTime)+import GHC.Records (HasField (..))+import Skeletest.Internal.Error (SkeletestError (..))+import Skeletest.Internal.Exit (TestExitCode (..)) import Skeletest.Internal.Fixtures (FixtureScopeKey (..), cleanupFixtures)+import Skeletest.Internal.Hooks (+  ModifyTestSummaryHookContext (..),+  OnTestFailureHookContext (..),+  RunTestHookContext (..),+  userHooks,+ )+import Skeletest.Internal.Hooks qualified as Hooks import Skeletest.Internal.Markers (   findMarker,  )-import Skeletest.Internal.Spec.Output (-  reportGroup,-  reportTestInProgress,-  reportTestResultWithBoxMessage,-  reportTestResultWithInlineMessage,-  reportTestResultWithoutMessage,+import Skeletest.Internal.Spec.TestReporter (+  TestReporter,+  newTestReporter,  ) import Skeletest.Internal.Spec.Tree (   MarkerFocus (..),@@ -70,6 +85,8 @@   getSpecTrees,   mapSpecs,   pruneSpec,+  traverseSpecTests,+  traverseSpecs,  ) import Skeletest.Internal.Spec.Tree qualified as X import Skeletest.Internal.TestInfo (TestInfo (TestInfo), withTestInfo)@@ -77,97 +94,241 @@ import Skeletest.Internal.TestRunner (   TestResult (..),   TestResultMessage (..),+  TestResultStatus (..),   testResultFromAssertionFail,   testResultFromError,  ) import Skeletest.Internal.Utils.Color qualified as Color-import Skeletest.Plugin (Hooks (..), defaultHooks, filterSpecTests, hasMarker)-import System.Console.Terminal.Size qualified as Term+import Skeletest.Internal.Utils.Term qualified as Term+import Skeletest.Internal.Utils.Text (pluralize)+import Skeletest.Internal.Utils.Timer (renderDuration, withTimer)+import Skeletest.Plugin (Hooks (..), Plugin (..), defaultHooks, defaultPlugin, filterSpecTests, hasMarker)+import Skeletest.Plugin qualified as Plugin import UnliftIO.Exception (+  catch,   finally,   fromException,-  try,+  throwIO,  )  {----- Execute spec -----} --- | Run the given Specs and return whether all of the tests passed.-runSpecs :: Hooks -> SpecRegistry -> IO Bool-runSpecs hooks specs =-  (`finally` cleanupFixtures PerSessionFixtureKey) $-    fmap and . forM (pruneSpec specs) $ \SpecInfo{..} ->-      (`finally` cleanupFixtures (PerFileFixtureKey specPath)) $ do-        let emptyTestInfo =-              TestInfo-                { contexts = []-                , name = ""-                , markers = []-                , file = specPath-                }-        Text.putStrLn $ Text.pack specPath-        let specTrees = getSpecTrees specSpec-        runTrees emptyTestInfo specTrees- where-  runTrees baseTestInfo = fmap and . mapM (runTree baseTestInfo)-  runTree baseTestInfo = \case-    SpecTree_Group{..} -> do-      let lvl = getIndentLevel baseTestInfo-      reportGroup lvl label-      runTrees baseTestInfo{TestInfo.contexts = baseTestInfo.contexts <> [label]} trees-    SpecTree_Test test -> do-      let lvl = getIndentLevel baseTestInfo-      reportTestInProgress lvl test.name+data SpecRunner = SpecRunner+  { testSummary :: TestSummary+  , testReporter :: TestReporter+  } -      let testInfo =-            baseTestInfo-              { TestInfo.name = test.name-              , TestInfo.markers = test.markers+newSpecRunner :: SpecRegistry -> IO SpecRunner+newSpecRunner initialSpecs = do+  testSummary <- newTestSummary initialSpecs+  testReporter <- newTestReporter+  pure+    SpecRunner+      { testSummary+      , testReporter+      }++instance HasField "run" SpecRunner (SpecRegistry -> IO TestExitCode) where+  getField runner specs = withTestSummary $ do+    (`finally` cleanupFixtures PerSessionFixtureKey) $+      resolveExitCode <$> mapM runner.runFile (pruneSpec specs)+   where+    withTestSummary action = do+      runner.testSummary.update $ \d -> d{testsSelected = getTotalTests specs}+      recordDuration runner.testSummary action++instance HasField "runFile" SpecRunner (SpecInfo -> IO TestExitCode) where+  getField runner info = do+    (`finally` cleanupFixtures (PerFileFixtureKey info.specPath)) $ do+      runner.testReporter.reportFilePre info.specPath+      (code, duration) <- withTimer $ runner.runTrees emptyTestInfo trees+      runner.testReporter.reportFilePost info.specPath (code, duration)+      pure code+   where+    trees = getSpecTrees info.spec+    emptyTestInfo =+      TestInfo+        { contexts = []+        , name = ""+        , markers = []+        , file = info.specPath+        }++instance HasField "runTrees" SpecRunner (TestInfo -> [SpecTree] -> IO TestExitCode) where+  getField runner testInfo = fmap resolveExitCode . mapM runTree+   where+    runTree = \case+      SpecTree_Group{label, trees} -> runner.runGroup testInfo label trees+      SpecTree_Test test ->+        runner.runTest+          testInfo+            { TestInfo.name = test.name+            , TestInfo.markers = test.markers+            }+          test++instance HasField "runGroup" SpecRunner (TestInfo -> Text -> [SpecTree] -> IO TestExitCode) where+  getField runner testInfo label trees = do+    runner.testReporter.reportGroupPre testInfo label+    (code, duration) <- withTimer $ runner.runTrees testInfo' trees+    runner.testReporter.reportGroupPost testInfo label (code, duration)+    pure code+   where+    testInfo' = testInfo{TestInfo.contexts = testInfo.contexts <> [label]}++instance HasField "runTest" SpecRunner (TestInfo -> SpecTest -> IO TestExitCode) where+  getField runner testInfo test = withTestInfo testInfo $ do+    runner.testReporter.reportTestPre testInfo+    tid <- myThreadId+    (result, duration) <-+      (`finally` cleanupFixtures (PerTestFixtureKey tid)) $ do+        withTimer . runTestHook $ test.action `catch` onTestFailureHook mkTestResultError+    runner.testReporter.reportTestPost testInfo (result, duration)++    runner.testSummary.update $ \d ->+      d+        { testCategories =+            Map.alter+              (Just . (+ 1) . fromMaybe 0)+              result.status+              d.testCategories+        }++    pure $ if result.status.success then ExitSuccess else ExitTestFailure+   where+    runTestHook action =+      let ctx =+            RunTestHookContext+              { testInfo               }-      TestResult{..} <--        withTestInfo testInfo $ do-          tid <- myThreadId-          runTest testInfo test.action `finally` cleanupFixtures (PerTestFixtureKey tid)+       in userHooks.runTest ctx () $ \() -> action+    onTestFailureHook action e =+      let ctx =+            OnTestFailureHookContext+              { testInfo+              }+       in userHooks.onTestFailure ctx e action+    mkTestResultError e =+      case fromException e of+        Just e' -> testResultFromAssertionFail e'+        Nothing -> testResultFromError e -      case testResultMessage of-        TestResultMessageNone -> do-          reportTestResultWithoutMessage testResultLabel-        TestResultMessageInline msg -> do-          reportTestResultWithInlineMessage lvl testResultLabel msg-        TestResultMessageBox box -> do-          termSize <- Term.size-          reportTestResultWithBoxMessage termSize lvl test.name testResultLabel box-      pure testResultSuccess+instance HasField "printSummary" SpecRunner (IO ()) where+  getField runner = do+    summary0 <- runner.testSummary.render+    summary <-+      userHooks.modifyTestSummary+        ModifyTestSummaryHookContext+        summary0+        pure+    Term.output ""+    Term.outputN . colorize . Text.strip $ summary+   where+    colorize = Text.unlines . map Color.yellow . Text.lines -  runTest info action =-    hooks.runTest info $ do-      (mCapture, resultOrError) <- withCaptureOutput (try action)-      case resultOrError of-        Right result -> pure result-        Left e ->-          fmap (addCapturedOutput mCapture) $-            case fromException e of-              Just e' -> testResultFromAssertionFail e'-              Nothing -> testResultFromError e+-- | Resolve the given exit codes, returning the first non-success code.+resolveExitCode :: [TestExitCode] -> TestExitCode+resolveExitCode = go+ where+  go = \case+    [] -> ExitSuccess+    ExitSuccess : rest -> go rest+    code : _ -> code -  getIndentLevel testInfo = length testInfo.contexts + 1 -- +1 to include the module name+{----- Test summary -----} +newtype TestSummary = TestSummary (IORef TestSummaryData)++data TestSummaryData = TestSummaryData+  { totalTests :: !Int+  , testsSelected :: !Int+  , testCategories :: !(Map TestResultStatus Int)+  , snapshotsUpdated :: !Int+  , totalDuration :: !NominalDiffTime+  }++newTestSummary :: SpecRegistry -> IO TestSummary+newTestSummary specs = do+  fmap TestSummary . newIORef $+    TestSummaryData+      { totalTests = getTotalTests specs+      , testsSelected = 0+      , testCategories = Map.empty+      , snapshotsUpdated = 0+      , totalDuration = 0+      }++getTotalTests :: SpecRegistry -> Int+getTotalTests specs = State.execState (count specs) 0+ where+  count = traverseSpecs . traverseSpecTests $ \x -> State.modify (+ 1) *> pure x++recordDuration :: TestSummary -> IO a -> IO a+recordDuration (TestSummary ref) m = do+  (a, duration) <- withTimer m+  modifyIORef' ref $ \d -> d{totalDuration = duration}+  pure a++instance HasField "update" TestSummary ((TestSummaryData -> TestSummaryData) -> IO ()) where+  getField (TestSummary ref) = modifyIORef' ref+instance HasField "render" TestSummary (IO Text) where+  getField (TestSummary ref) = do+    TestSummaryData{..} <- readIORef ref+    let testsDeselected = totalTests - testsSelected+    pure . Text.unlines . concat $+      [ ["═════ Test report ═════"]+      , ["➤ " <> pluralize testsSelected "test" <> " ran in " <> renderDuration totalDuration]+      , [ "  • " <> pluralize count "test" <> " " <> status.name <> " " <> icon+        | (status, count) <- Map.toAscList testCategories+        , let icon =+                case status of+                  TestPassed -> Color.green "✔"+                  TestFailed -> Color.red "✘"+                  TestSkipped -> Color.yellow "≫"+                  TestStatus{success_}+                    | success_ -> Color.green "✔"+                    | otherwise -> Color.red "✘"+        ]+      , when_ (testsDeselected > 0) $+          "  • " <> pluralize testsDeselected "test" <> " deselected"+      ]+   where+    when_ p x = if p then [x] else []+ {----- Built-in hooks -----} +specTreePlugin :: Plugin+specTreePlugin =+  defaultPlugin+    { Plugin.hooks =+        mconcat+          [ xfailHook+          , skipHook+          , focusHook+          , applyTestSelectionsHook+          , manualTestsHook+          ]+    }+ applyTestSelectionsHook :: Hooks applyTestSelectionsHook =   defaultHooks-    { modifySpecRegistry = \case-        Just selections -> \modify -> fmap (map (applyTestSelections selections)) . modify-        Nothing -> id+    { modifySpecRegistry = Hooks.runLate . Hooks.mkPreHook $ \ctx inp ->+        pure $+          case ctx.testTargets of+            Just selections -> map (applyTestSelections selections) inp+            Nothing -> inp     }  manualTestsHook :: Hooks manualTestsHook =   defaultHooks-    { modifySpecRegistry = \case-        -- only hide manual tests when no selections are specified-        Just _ -> id-        Nothing -> \modify -> fmap (mapSpecs hideManual) . modify+    { modifySpecRegistry = Hooks.mkPreHook $ \ctx inp ->+        pure $+          case ctx.testTargets of+            -- only hide manual tests when no selections are specified+            Just _ -> inp+            Nothing -> mapSpecs hideManual inp     }  where   hideManual = filterSpecTests (not . hasMarker @MarkerManual . (.markers))@@ -175,50 +336,68 @@ xfailHook :: Hooks xfailHook =   defaultHooks-    { runTest = \testInfo runTest ->-        case findMarker testInfo.markers of-          Just (MarkerXFail reason) -> modify reason <$> runTest-          Nothing -> runTest+    { runTest = Hooks.mkPostHook $ \ctx _ ->+        case findMarker ctx.testInfo.markers of+          Just (MarkerXFail reason) -> pure . modify reason+          Nothing -> pure     }  where-  modify reason TestResult{..} =-    if testResultSuccess+  modify reason result =+    if result.status.success       then         TestResult-          { testResultSuccess = False-          , testResultLabel = Color.red "XPASS"-          , testResultMessage = TestResultMessageInline reason+          { status =+              TestStatus+                { name_ = "xpassed"+                , success_ = False+                }+          , label = Color.red "XPASS"+          , message = TestResultMessageInline reason           }       else         TestResult-          { testResultSuccess = True-          , testResultLabel = Color.yellow "XFAIL"-          , testResultMessage = TestResultMessageInline reason+          { status = TestPassed+          , label = Color.yellow "XFAIL"+          , message = TestResultMessageInline reason           }  skipHook :: Hooks skipHook =   defaultHooks-    { runTest = \testInfo runTest ->-        case findMarker (testInfo.markers) of-          Just (MarkerSkip reason) ->-            pure-              TestResult-                { testResultSuccess = True-                , testResultLabel = Color.yellow "SKIP"-                , testResultMessage = TestResultMessageInline reason-                }-          Nothing -> runTest+    { runTest = Hooks.mkHook $ \ctx run ->+        case findMarker (ctx.testInfo.markers) of+          Just (MarkerSkip reason) -> \_ -> pure $ skipResult reason+          Nothing -> run+    , onTestFailure = Hooks.mkHook $ \_ run e ->+        case fromException e of+          Just (SkipTest reason) -> pure $ skipResult reason+          _ -> run e     }+ where+  skipResult reason =+    TestResult+      { status = TestSkipped+      , label = Color.yellow "SKIP"+      , message = TestResultMessageInline reason+      } +-- | Like 'X.skip', except allows skipping tests at runtime.+--+-- @since 0.4.0+skipTest :: (MonadIO m) => String -> m a+skipTest reason = throwIO $ SkipTest (Text.pack reason)+ focusHook :: Hooks focusHook =   defaultHooks-    { modifySpecRegistry = \_ modify -> fmap applyFocus . modify+    { modifySpecRegistry = Hooks.runEarly . Hooks.mkPreHook $ \_ specs ->+        pure $+          if hasFocus specs+            then mapSpecs hideNotFocused specs+            else specs     }  where-  applyFocus specs = if hasFocus specs then mapSpecs hideNotFocused specs else specs-  hasFocus = any (anySpecTests isFocused . (.specSpec))+  hasFocus = any (anySpecTests isFocused . (.spec))   anySpecTests f spec =     let go = \case           SpecTree_Group{trees} -> concatMap go trees

@@ -1,66 +1,24 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-}  module Skeletest.Internal.Spec.Output (-  reportGroup,-  reportTestInProgress,-  reportTestResultWithoutMessage,-  reportTestResultWithInlineMessage,-  reportTestResultWithBoxMessage,+  -- * Rendering failures   renderPrettyFailure,++  -- * BoxSpec   BoxSpec,   BoxSpecContent (..),-  IndentLevel,-  indent, ) where  import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Text qualified as Text-import Data.Text.IO qualified as Text import Skeletest.Internal.Paths (readTestFile)-import System.Console.Terminal.Size qualified as Term-import System.IO qualified as IO+import Skeletest.Internal.Utils.Text (showT) import UnliftIO.Exception (SomeException, try) -reportGroup :: IndentLevel -> Text -> IO ()-reportGroup lvl name = do-  Text.putStrLn $ indent lvl name--reportTestInProgress :: IndentLevel -> Text -> IO ()-reportTestInProgress lvl testName = do-  Text.putStr $ indent lvl (testName <> ": ")-  IO.hFlush IO.stdout--reportTestResultWithoutMessage :: Text -> IO ()-reportTestResultWithoutMessage testResultLabel = do-  Text.putStrLn testResultLabel--reportTestResultWithInlineMessage :: IndentLevel -> Text -> Text -> IO ()-reportTestResultWithInlineMessage lvl testResultLabel testResultMessage = do-  Text.putStrLn testResultLabel-  Text.putStrLn $ indent (lvl + 1) testResultMessage--reportTestResultWithBoxMessage :: Maybe (Term.Window Int) -> IndentLevel -> Text -> Text -> BoxSpec -> IO ()-reportTestResultWithBoxMessage termSize lvl testName testResultLabel box = do-  if null box-    then do-      Text.putStrLn testResultLabel-    else do-      Text.putStr "\r"-      Text.putStrLn $ drawBoxHeader lvl testName <> ": " <> testResultLabel-      Text.putStrLn $ drawBoxBody termSize box--type IndentLevel = Int--indentSize :: Int-indentSize = 4--indentWith :: Text -> IndentLevel -> Text -> Text-indentWith fill lvl = Text.intercalate "\n" . map (Text.replicate (lvl * indentSize) fill <>) . Text.splitOn "\n"--indent :: IndentLevel -> Text -> Text-indent = indentWith " "+{----- Rendering failures -----}  -- | Render a test failure like: --@@ -106,7 +64,7 @@             Left e -> (Text.pack e, "")      pure . Text.intercalate "\n" $-      [ Text.pack path <> ":" <> (Text.pack . show) lineNum <> ":"+      [ Text.pack path <> ":" <> showT lineNum <> ":"       , "│"       , "│ " <> srcLine       , "│ " <> pointerLine@@ -114,31 +72,12 @@    getLineNum n = listToMaybe . take 1 . drop (n - 1) . Text.lines +{----- BoxSpec -----}++-- | The specification for boxed output. type BoxSpec = [BoxSpecContent]  data BoxSpecContent   = BoxText Text   | BoxHeader Text   deriving (Show, Eq)--drawBoxHeader :: IndentLevel -> Text -> Text-drawBoxHeader lvl testName = "╭" <> Text.drop 2 (indentWith "─" lvl "") <> " " <> testName--drawBoxBody :: Maybe (Term.Window Int) -> BoxSpec -> Text-drawBoxBody termSize boxContents = Text.intercalate "\n" $ concatMap draw boxContents <> [footer]- where-  termWidth = maybe 80 Term.width termSize-  width =-    maximum . (termWidth :) . flip concatMap boxContents $ \case-      BoxHeader s -> [Text.length s + indentSize + 2]-      BoxText s -> [Text.length line + 2 | line <- Text.lines s]--  footer = "╰" <> Text.replicate (width - 1) "─"--  draw = \case-    BoxHeader s ->-      [ drawLine ""-      , "╞═══ " <> s-      ]-    BoxText s -> map drawLine $ Text.lines s-  drawLine s = "│ " <> s

@@ -0,0 +1,319 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}++module Skeletest.Internal.Spec.TestReporter (+  TestReporter,+  newTestReporter,+) where++import Control.Concurrent (threadDelay)+import Control.Monad (when)+import Data.Foldable (traverse_)+import Data.IORef (IORef, atomicModifyIORef', newIORef)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (NominalDiffTime)+import GHC.Records (HasField (..))+import Skeletest.Internal.CLI (FormatFlag (..), getFormatFlag)+import Skeletest.Internal.Exit (TestExitCode (..))+import Skeletest.Internal.Spec.Output (BoxSpec, BoxSpecContent (..))+import Skeletest.Internal.TestInfo (TestInfo (..))+import Skeletest.Internal.TestRunner (TestResult (..), TestResultMessage (..))+import Skeletest.Internal.Utils.Color qualified as Color+import Skeletest.Internal.Utils.Term qualified as Term+import Skeletest.Internal.Utils.Text (indentWith)+import Skeletest.Internal.Utils.Timer (renderDuration)+import UnliftIO.Async (Async)+import UnliftIO.Async qualified as Async+import UnliftIO.MVar (MVar, modifyMVar_, newMVar)++{----- TestReporter -----}++data TestReporter = TestReporter+  { format :: FormatFlag+  , supportsANSI :: Bool+  , animationThread :: AnimationThread+  , minimalFormatFailures :: IORef (Set FilePath)+  }++newTestReporter :: IO TestReporter+newTestReporter = do+  format <- getFormatFlag+  supportsANSI <- Term.supportsANSI Term.stdout+  animationThread <- newAnimationThread+  minimalFormatFailures <- newIORef Set.empty+  pure TestReporter{format, supportsANSI, animationThread, minimalFormatFailures}++getFormatAction :: forall field a. (HasField field FormatActions (TestReporter -> a)) => TestReporter -> a+getFormatAction reporter = getField @field formatActions reporter+ where+  formatActions =+    case reporter.format of+      FormatFlag_Minimal -> formatActionsMinimal+      FormatFlag_Full -> formatActionsFull+      FormatFlag_Verbose -> formatActionsVerbose++instance HasField "reportFilePre" TestReporter (FilePath -> IO ()) where+  getField = getFormatAction @"reportFilePre"+instance HasField "reportFilePost" TestReporter (FilePath -> (TestExitCode, NominalDiffTime) -> IO ()) where+  getField = getFormatAction @"reportFilePost"+instance HasField "reportGroupPre" TestReporter (TestInfo -> Text -> IO ()) where+  getField = getFormatAction @"reportGroupPre"+instance HasField "reportGroupPost" TestReporter (TestInfo -> Text -> (TestExitCode, NominalDiffTime) -> IO ()) where+  getField = getFormatAction @"reportGroupPost"+instance HasField "reportTestPre" TestReporter (TestInfo -> IO ()) where+  getField = getFormatAction @"reportTestPre"+instance HasField "reportTestPost" TestReporter (TestInfo -> (TestResult, NominalDiffTime) -> IO ()) where+  getField = getFormatAction @"reportTestPost"++{----- Report formats -----}++data FormatActions = FormatActions+  { reportFilePre :: TestReporter -> FilePath -> IO ()+  , reportFilePost :: TestReporter -> FilePath -> (TestExitCode, NominalDiffTime) -> IO ()+  , reportGroupPre :: TestReporter -> TestInfo -> Text -> IO ()+  , reportGroupPost :: TestReporter -> TestInfo -> Text -> (TestExitCode, NominalDiffTime) -> IO ()+  , reportTestPre :: TestReporter -> TestInfo -> IO ()+  , reportTestPost :: TestReporter -> TestInfo -> (TestResult, NominalDiffTime) -> IO ()+  }++defaultFormatActions :: FormatActions+defaultFormatActions =+  FormatActions+    { reportFilePre = \_ _ -> pure ()+    , reportFilePost = \_ _ _ -> pure ()+    , reportGroupPre = \_ _ _ -> pure ()+    , reportGroupPost = \_ _ _ _ -> pure ()+    , reportTestPre = \_ _ -> pure ()+    , reportTestPost = \_ _ _ -> pure ()+    }++formatActionsMinimal :: FormatActions+formatActionsMinimal =+  defaultFormatActions+    { reportFilePre+    , reportFilePost+    , reportTestPre+    , reportTestPost+    }+ where+  reportFilePre reporter fp = do+    when (not reporter.supportsANSI) $ do+      Term.outputN $ renderFile fp++  reportFilePost reporter fp (_, duration) = do+    fileHadFailure <-+      atomicModifyIORef' reporter.minimalFormatFailures $ \failures ->+        (Set.delete fp failures, fp `Set.member` failures)+    when (not fileHadFailure) $ do+      Term.output . Text.concat $+        [ if reporter.supportsANSI then renderFile fp else ""+        , Color.green "OK"+        , renderDurationLabel reporter duration+        ]++  renderFile fp = "◈ " <> Text.pack fp <> ": "++  reportTestPre reporter testInfo = do+    when reporter.supportsANSI $ do+      reporter.animationThread.start+        Animation+          { fps = 5+          , render = \t -> spinner t <> " " <> minimalTestLabel reporter testInfo+          }+   where+    spinner = mkAnimation $ map Color.yellow ["▶ ▷ ▷", "▷ ▶ ▷", "▷ ▷ ▶"]++  reportTestPost reporter testInfo (result, duration) = do+    when reporter.supportsANSI $ do+      reporter.animationThread.clear+    when (not result.status.success) $ do+      hadPreviousFailure <-+        atomicModifyIORef' reporter.minimalFormatFailures $ \failures ->+          (Set.insert testInfo.file failures, testInfo.file `Set.member` failures)+      if reporter.supportsANSI+        then do+          Term.outputN "◈ "+        else do+          when (not hadPreviousFailure) $ Term.outputN "\n"+          Term.outputN $ drawBoxHeader 1 (BoxHeaderType_Inline "")+      Term.output . Text.concat $+        [ minimalTestLabel reporter testInfo+        , ": "+        , result.label+        , renderDurationLabel reporter duration+        ]+      renderTestResultMessage 0 result++  minimalTestLabel reporter testInfo =+    Text.intercalate " ≫ " . concat $+      [ if reporter.supportsANSI then [Text.pack testInfo.file] else []+      , testInfo.contexts+      , [testInfo.name]+      ]++formatActionsFull :: FormatActions+formatActionsFull =+  defaultFormatActions+    { reportFilePre+    , reportGroupPre+    , reportTestPre+    , reportTestPost+    }+ where+  reportFilePre _ fp = do+    Term.output $ Text.pack fp++  reportGroupPre _ testInfo name = do+    Term.output $ fullIndent indentLevel name+   where+    indentLevel = getIndentLevel testInfo++  reportTestPre reporter testInfo = do+    let testLabel = getTestLabel testInfo+    if reporter.supportsANSI+      then do+        reporter.animationThread.start+          Animation+            { fps = 12+            , render = \t -> testLabel <> spinner t+            }+      else do+        Term.outputN testLabel+   where+    spinner = mkAnimation $ map Color.yellow ["⠋", "⠙", "⠹", "⠸", "⠼", "⠴", "⠦", "⠧", "⠇", "⠏"]++  reportTestPost reporter testInfo (result, duration) = do+    when reporter.supportsANSI $ do+      reporter.animationThread.clear+      Term.outputInPlace $ getTestLabel testInfo+    withBoxHeader $ do+      Term.output $ result.label <> durationLabel+    renderTestResultMessage indentLevel result+   where+    indentLevel = getIndentLevel testInfo+    isBox = \case+      TestResultMessageBox _ -> True+      _ -> False+    withBoxHeader action+      | not $ isBox result.message = do+          action+      | reporter.supportsANSI = do+          Term.outputInPlace $ drawBoxHeader indentLevel (BoxHeaderType_Inline $ testInfo.name <> ": ")+          action+      | otherwise = do+          action+          Term.output $ drawBoxHeader indentLevel BoxHeaderType_NextLine+    durationLabel = renderDurationLabel reporter duration++  getTestLabel testInfo = fullIndent (getIndentLevel testInfo) (testInfo.name <> ": ")++-- Verbose is the same as full, except with some minor changes, so+-- we'll re-use full and inspect format directly+formatActionsVerbose :: FormatActions+formatActionsVerbose = formatActionsFull++renderDurationLabel :: TestReporter -> NominalDiffTime -> Text+renderDurationLabel reporter duration =+  if reporter.format == FormatFlag_Verbose || duration > 0.1+    then " " <> Color.gray ("(" <> renderDuration duration <> ")")+    else ""++renderTestResultMessage :: IndentLevel -> TestResult -> IO ()+renderTestResultMessage indentLevel result =+  case result.message of+    TestResultMessageNone -> pure ()+    TestResultMessageInline msg -> do+      Term.output $ fullIndent (indentLevel + 1) msg+    TestResultMessageBox box -> do+      Term.outputN $ drawBoxBody box+      Term.output drawBoxFooter++{----- BoxSpec -----}++data BoxHeaderType+  = -- | e.g.+    --   "╭── my test: FAIL"+    BoxHeaderType_Inline Text+  | -- | e.g.+    --   "    my test: FAIL"+    --   "╭───╯"+    BoxHeaderType_NextLine++drawBoxHeader :: IndentLevel -> BoxHeaderType -> Text+drawBoxHeader lvl type_ = "╭" <> dashes <> suffix+ where+  dashes = Text.replicate (4 * lvl - 2) "─"+  suffix =+    case type_ of+      BoxHeaderType_Inline s -> " " <> s+      BoxHeaderType_NextLine -> "─╯"++drawBoxBody :: BoxSpec -> Text+drawBoxBody boxContents = Text.unlines $ concatMap draw boxContents+ where+  draw = \case+    BoxHeader s ->+      [ "│"+      , "╞═══ " <> s+      ]+    BoxText s ->+      [ "│ " <> line+      | line <- Text.lines s+      ]++drawBoxFooter :: Text+drawBoxFooter = "╰" <> Text.replicate (Term.width - 1) "─"++{----- Indentation -----}++type IndentLevel = Int++getIndentLevel :: TestInfo -> IndentLevel+getIndentLevel testInfo = length testInfo.contexts + 1++fullIndent :: IndentLevel -> Text -> Text+fullIndent = indentWith 4 " "++{----- Animation -----}++newtype AnimationThread = AnimationThread (MVar (Maybe (Async ())))++newAnimationThread :: IO AnimationThread+newAnimationThread = AnimationThread <$> newMVar Nothing++data Animation = Animation+  { fps :: Int+  , render :: Int -> Text+  }++mkAnimation :: [Text] -> Int -> Text+mkAnimation frames =+  -- Do not eta-expand this; this should cache the frames correctly+  (frames !!) . toIndex+ where+  toIndex t = t `mod` length frames++instance HasField "start" AnimationThread (Animation -> IO ()) where+  getField (AnimationThread mThreadVar) animation = modifyMVar_ mThreadVar $ \mThread -> do+    traverse_ Async.uninterruptibleCancel mThread+    thread <- Async.async (loop 0)+    pure $ Just thread+   where+    loop (i :: Int) = do+      Term.outputInPlace $ animation.render i+      threadDelay (1000000 `div` animation.fps)+      loop (i + 1)++instance HasField "clear" AnimationThread (IO ()) where+  getField (AnimationThread mThreadVar) = modifyMVar_ mThreadVar $ \mThread -> do+    traverse_ Async.uninterruptibleCancel mThread+    Term.clearInPlace+    pure Nothing

@@ -6,6 +6,7 @@ module Skeletest.Internal.Spec.Tree (   -- * Spec interface   Spec,+  SpecM,   SpecTree (..),   SpecTest (..), @@ -20,7 +21,6 @@   Testable (..),   test,   it,-  prop,    -- ** Modifiers   MarkerXFail (..),@@ -42,6 +42,7 @@   withSpecTrees,   mapSpecTrees,   traverseSpecTrees,+  getSpecTests,   mapSpecTests,   filterSpecTests,   traverseSpecTests,@@ -52,8 +53,10 @@ import Control.Monad (guard, (>=>)) import Control.Monad.Trans.Reader qualified as Trans import Control.Monad.Trans.Writer (Writer, execWriter, tell)+import Data.Foldable qualified as Seq import Data.Functor.Identity (runIdentity) import Data.Maybe (catMaybes, mapMaybe)+import Data.Sequence qualified as Seq import Data.Text (Text) import Data.Text qualified as Text import Skeletest.Assertions (Testable, runTestable)@@ -65,11 +68,10 @@ import Skeletest.Internal.TestRunner (TestResult) import Skeletest.Internal.TestTargets (TestTarget, matchesTest) import Skeletest.Internal.TestTargets qualified as TestTargets-import Skeletest.Prop.Internal (Property) -type Spec = Spec' ()+type Spec = SpecM () -newtype Spec' a = Spec (Writer [SpecTree] a)+newtype SpecM a = Spec (Writer [SpecTree] a)   deriving (Functor, Applicative, Monad)  data SpecTree@@ -131,6 +133,11 @@   Spec mapSpecTrees f = runIdentity . traverseSpecTrees (\go -> pure . f (runIdentity . go)) +getSpecTests :: Spec -> [SpecTest]+getSpecTests = Seq.toList . execWriter . traverseSpecTests go+ where+  go stest = tell (Seq.singleton stest) *> pure stest+ traverseSpecTests :: (Monad m) => (SpecTest -> m SpecTest) -> Spec -> m Spec traverseSpecTests f = traverseSpecTrees $ \go ->   traverse $@@ -154,11 +161,11 @@  data SpecInfo = SpecInfo   { specPath :: FilePath-  , specSpec :: Spec+  , spec :: Spec   }  traverseSpecs :: (Applicative f) => (Spec -> f Spec) -> SpecRegistry -> f SpecRegistry-traverseSpecs f = traverse $ \info -> (\spec -> info{specSpec = spec}) <$> f info.specSpec+traverseSpecs f = traverse $ \info -> (\spec -> info{spec = spec}) <$> f info.spec  mapSpecs :: (Spec -> Spec) -> SpecRegistry -> SpecRegistry mapSpecs f = runIdentity . traverseSpecs (pure . f)@@ -166,16 +173,16 @@ -- | Remove specs with no tests. pruneSpec :: SpecRegistry -> SpecRegistry pruneSpec = mapMaybe $ \info -> do-  let spec = mapSpecTrees (\go -> filter (not . isEmptySpec) . map go) info.specSpec+  let spec = mapSpecTrees (\go -> filter (not . isEmptySpec) . map go) info.spec   guard $ (not . null . getSpecTrees) spec-  pure info{specSpec = spec}+  pure info{spec = spec}  where   isEmptySpec = \case     SpecTree_Group _ [] -> True     _ -> False  applyTestSelections :: TestTarget -> SpecInfo -> SpecInfo-applyTestSelections selections info = info{specSpec = applySelections info.specSpec}+applyTestSelections selections info = info{spec = applySelections info.spec}  where   applySelections = (`Trans.runReader` []) . traverseSpecTrees apply @@ -231,17 +238,6 @@ -- @ it :: String -> IO () -> Spec it = test---- | Define a property test.------ @--- describe \"User\" $ do---   prop "decode . encode === Just" $ do---     let genUser = ...---     (decode . encode) P.=== Just \`shouldSatisfy\` P.isoWith genUser--- @-prop :: String -> Property -> Spec-prop = test  {----- Modifiers -----} 

@@ -1,4 +1,7 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoFieldSelectors #-}  module Skeletest.Internal.TestInfo (@@ -12,7 +15,8 @@ import Data.Map (Map) import Data.Map qualified as Map import Data.Text (Text)-import Skeletest.Internal.Error (invariantViolation)+import GHC.Stack (HasCallStack)+import Skeletest.Internal.Error (skeletestError) import Skeletest.Internal.Markers (SomeMarker) import System.IO.Unsafe (unsafePerformIO) import UnliftIO (MonadUnliftIO)@@ -24,6 +28,9 @@   { contexts :: [Text]   , name :: Text   , markers :: [SomeMarker]+  -- ^ Markers this test was tagged with or inherited from its groups.+  --+  -- May be queried with 'Skeletest.Plugin.findMarker' or 'Skeletest.Plugin.hasMarker'.   , file :: FilePath   -- ^ Relative to CWD   }@@ -48,10 +55,8 @@   tid <- myThreadId   Map.lookup tid <$> readIORef testInfoMapRef -getTestInfo :: (MonadIO m) => m TestInfo+getTestInfo :: (MonadIO m, HasCallStack) => m TestInfo getTestInfo =   lookupTestInfo >>= \case     Just info -> pure info-    -- it's not possible for a user to write code that's executed within a test,-    -- because we define the entire main function.-    Nothing -> invariantViolation "test info not initialized"+    Nothing -> skeletestError "getTestInfo was called from outside a test context"

@@ -1,4 +1,6 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoFieldSelectors #-}@@ -9,6 +11,7 @@    -- * TestResult   TestResult (..),+  TestResultStatus (..),   TestResultMessage (..),   testResultPass,   testResultFromAssertionFail,@@ -26,6 +29,7 @@ import Data.Text qualified as Text import Data.Typeable (typeOf) import GHC.IO.Exception qualified as GHC+import GHC.Records (HasField (..)) import GHC.Stack (CallStack) import GHC.Stack qualified as GHC import Skeletest.Internal.Error (SkeletestError)@@ -60,11 +64,34 @@ {----- TestResult -----}  data TestResult = TestResult-  { testResultSuccess :: Bool-  , testResultLabel :: Text-  , testResultMessage :: TestResultMessage+  { status :: TestResultStatus+  , label :: Text+  , message :: TestResultMessage   } +data TestResultStatus+  = TestPassed+  | TestFailed+  | TestSkipped+  | TestStatus+      { name_ :: Text+      , success_ :: Bool+      }+  deriving (Eq, Ord)++instance HasField "name" TestResultStatus Text where+  getField = \case+    TestPassed -> "passed"+    TestFailed -> "failed"+    TestSkipped -> "skipped"+    TestStatus{name_} -> name_+instance HasField "success" TestResultStatus Bool where+  getField = \case+    TestPassed -> True+    TestFailed -> False+    TestSkipped -> True+    TestStatus{success_} -> success_+ data TestResultMessage   = TestResultMessageNone   | TestResultMessageInline Text@@ -73,9 +100,9 @@ testResultPass :: TestResult testResultPass =   TestResult-    { testResultSuccess = True-    , testResultLabel = Color.green "OK"-    , testResultMessage = TestResultMessageNone+    { status = TestPassed+    , label = Color.green "OK"+    , message = TestResultMessageNone     }  testResultFromAssertionFail :: AssertionFail -> IO TestResult@@ -83,9 +110,9 @@   msg <- renderAssertionFail e   pure     TestResult-      { testResultSuccess = False-      , testResultLabel = Color.red "FAIL"-      , testResultMessage = TestResultMessageBox [BoxText msg]+      { status = TestFailed+      , label = Color.red "FAIL"+      , message = TestResultMessageBox [BoxText msg]       }  testResultFromError :: SomeException -> IO TestResult@@ -96,14 +123,12 @@   msg <- f <$> renderMsg   pure     TestResult-      { testResultSuccess = False-      , testResultLabel = Color.red "ERROR"-      , testResultMessage = TestResultMessageBox [BoxText msg]+      { status = TestFailed+      , label = Color.red "ERROR"+      , message = TestResultMessageBox [BoxText msg]       }  where   renderMsg-    -- In GHC 9.10+, SomeException shows the callstack, which we don't-    -- want to see for known Skeletest errors     | Just (err :: SkeletestError) <- fromException e = do         pure $ Text.pack $ displayException err     -- Handle pattern match fail in a do-block

@@ -3,6 +3,7 @@   red,   yellow,   gray,+  bold, ) where  import Data.Text (Text)@@ -23,3 +24,6 @@  gray :: Text -> Text gray = withANSI [ANSI.SetColor ANSI.Foreground ANSI.Vivid ANSI.Black]++bold :: Text -> Text+bold = withANSI [ANSI.SetConsoleIntensity ANSI.BoldIntensity]

@@ -0,0 +1,169 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-}++module Skeletest.Internal.Utils.Term (+  init,+  setANSISupport,++  -- * Global attributes+  Handle,+  width,+  stdout,+  stderr,+  supportsANSI,++  -- * Output helpers+  flush,+  output,+  outputN,+  outputErr,+  outputErrN,+  clearInPlace,+  outputInPlace,+) where++import Control.Exception (evaluate)+import Control.Monad (forM_, replicateM_)+import Data.Foldable (traverse_)+import Data.String.AnsiEscapeCodes.Strip.Text (stripAnsiEscapeCodes)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.IO qualified as Text+import GHC.IO.Handle qualified as IO+import System.Console.ANSI qualified as ANSI+import System.Console.Terminal.Size qualified as TermSize+import System.IO qualified as IO+import System.IO.Unsafe (unsafePerformIO)+import UnliftIO.MVar (MVar, modifyMVar_, newMVar, readMVar, withMVar)+import Prelude hiding (init)++data GlobalTermData = GlobalTermData+  { width :: Int+  , stdout :: Handle+  , stderr :: Handle+  }++newtype Handle = Handle {var :: MVar Handle'}++data Handle' = Handle'+  { handle :: IO.Handle+  , supportsANSI :: Bool+  , lastInPlaceOutput :: Maybe Text+  -- ^ See 'outputInPlace'+  }++globalTermData :: GlobalTermData+globalTermData = unsafePerformIO $ do+  width <- maybe 80 TermSize.width <$> TermSize.size+  stdout <- getHandle IO.stdout+  stderr <- getHandle IO.stderr+  pure GlobalTermData{..}+ where+  getHandle h = do+    handle <- IO.hDuplicate h+    supportsANSI <- ANSI.hSupportsANSI handle+    let lastInPlaceOutput = Nothing+    Handle <$> newMVar Handle'{..}+{-# NOINLINE globalTermData #-}++init :: IO ()+init = do+  -- Configure stdout/stderr globally, both for Term.output and for anything+  -- writing directly to stdout/stderr (e.g. user tests with --capture-output=off)+  forM_ [IO.stdout, IO.stderr] $ \h -> do+    IO.hSetEncoding h IO.utf8+    IO.hSetBuffering h IO.LineBuffering++  -- Make sure globalTermData is initialized+  _ <- evaluate globalTermData+  pure ()++-- Use the terminal width at the beginning of the test suite; don't+-- handle users changing terminal width in the middle right now+width :: Int+width = globalTermData.width++stdout :: Handle+stdout = globalTermData.stdout++stderr :: Handle+stderr = globalTermData.stderr++supportsANSI :: Handle -> IO Bool+supportsANSI (Handle hvar) = (.supportsANSI) <$> readMVar hvar++setANSISupport :: Bool -> IO ()+setANSISupport x =+  forM_ [globalTermData.stdout, globalTermData.stderr] $ \(Handle hvar) -> do+    modifyMVar_ hvar $ \h -> pure h{supportsANSI = x}++flush :: IO ()+flush = do+  forM_ [globalTermData.stdout, globalTermData.stderr] $ \(Handle hvar) -> do+    withMVar hvar $ \h -> IO.hFlush h.handle++output :: Text -> IO ()+output = outputWith globalTermData.stdout++outputN :: Text -> IO ()+outputN = outputNWith globalTermData.stdout++outputErr :: Text -> IO ()+outputErr = outputWith globalTermData.stderr++outputErrN :: Text -> IO ()+outputErrN = outputNWith globalTermData.stderr++outputWith :: Handle -> Text -> IO ()+outputWith (Handle hvar) s = modifyMVar_ hvar $ \h -> outputWith' h s++outputNWith :: Handle -> Text -> IO ()+outputNWith (Handle hvar) s = modifyMVar_ hvar $ \h -> outputNWith' h s++outputWith' :: Handle' -> Text -> IO Handle'+outputWith' h s = do+  Text.hPutStrLn h.handle s+  pure h{lastInPlaceOutput = Nothing}++outputNWith' :: Handle' -> Text -> IO Handle'+outputNWith' h s = do+  Text.hPutStr h.handle s+  IO.hFlush h.handle+  pure h{lastInPlaceOutput = Nothing}++-- | Same as 'outputN', except if called multiple times in a row, will update+-- the message in-place.+--+-- Should only be used when stdout supports ANSI, but this isn't checked.+--+-- Long-term, should probably be replaced with concurrent-output, but it's+-- currently hardcoded to IO.stdout.+outputInPlace :: Text -> IO ()+outputInPlace s = modifyMVar_ globalTermData.stdout.var $ \h0 -> do+  h1 <- clearInPlaceWith' h0+  h2 <- outputNWith' h1 s+  pure h2{lastInPlaceOutput = Just s}++-- | Clear last in-place output. See 'outputInPlace'.+clearInPlace :: IO ()+clearInPlace = modifyMVar_ globalTermData.stdout.var $ \h -> clearInPlaceWith' h++clearInPlaceWith' :: Handle' -> IO Handle'+clearInPlaceWith' h = do+  traverse_ clearLastInPlaceOutput h.lastInPlaceOutput+  pure h{lastInPlaceOutput = Nothing}+ where+  clearLastInPlaceOutput lastOutput = do+    let n = calculateNumLines lastOutput+    Text.hPutStr h.handle "\r\ESC[K" -- Clear the current line+    replicateM_ (n - 1) $ do+      -- Clear any lines above+      Text.hPutStr h.handle "\ESC[F\ESC[K"++  calculateNumLines =+    let calc = length . Text.chunksOf globalTermData.width . stripAnsiEscapeCodes+     in sum . map calc . Text.lines

@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}++module Skeletest.Internal.Utils.Text (+  showT,+  pluralize,+  parens,++  -- * Indentation+  IndentSize,+  IndentLevel,+  indent,+  indentWith,+) where++import Data.Text (Text)+import Data.Text qualified as Text++-- TODO: Remove when Text.show is available in the version of 'text' that's+-- shipped with the lowest version of GHC we support.+showT :: (Show a) => a -> Text+showT = Text.pack . show++pluralize :: (Num a, Eq a, Show a) => a -> Text -> Text+pluralize n item = showT n <> " " <> item <> (if n == 1 then "" else "s")++-- | Add parentheses if the given input contains spaces.+parens :: Text -> Text+parens s =+  if " " `Text.isInfixOf` s+    then "(" <> s <> ")"+    else s++indent :: Text -> Text+indent = indentWith 2 " " 1++type IndentSize = Int+type IndentLevel = Int++indentWith :: IndentSize -> Text -> IndentLevel -> Text -> Text+indentWith indentSize fill lvl =+  Text.intercalate "\n"+    . map (Text.replicate (lvl * indentSize) fill <>)+    . Text.splitOn "\n"

@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}++module Skeletest.Internal.Utils.Timer (+  withTimer,+  renderDuration,+) where++import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime)+import Numeric (showFFloat)++withTimer :: IO a -> IO (a, NominalDiffTime)+withTimer m = do+  start <- getCurrentTime+  a <- m+  end <- getCurrentTime+  pure (a, end `diffUTCTime` start)++renderDuration :: NominalDiffTime -> Text+renderDuration duration = (Text.pack . showRounded) duration <> "s"+ where+  showRounded n = showFFloat (Just 2) (realToFrac n :: Double) ""

@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}@@ -21,61 +22,101 @@   Spec, ) where -import Control.Monad (unless, (<=<))-import Skeletest.Internal.CLI (Flag, flag, loadCliArgs)-import Skeletest.Internal.Capture (CaptureOutputFlag)+import Control.Monad (when)+import Data.Foldable (traverse_)+import Skeletest.Internal.CLI (+  ANSIFlag (..),+  Flag,+  FormatFlag,+  flag,+  getFlag,+  loadCliArgs,+ )+import Skeletest.Internal.Capture (CaptureOutputFlag (..), captureOutputPlugin)+import Skeletest.Internal.Exit (TestExitCode (..), exitWith, handleUnknownErrors)+import Skeletest.Internal.Hooks (+  ModifySpecRegistryHookContext (..),+  RunSpecsHookContext (..),+  setUserHooks,+  userHooks,+ ) import Skeletest.Internal.Snapshot (   SnapshotRenderer (..),-  SnapshotUpdateFlag,-  defaultSnapshotRenderers,   renderWithShow,   setSnapshotRenderers,+  snapshotPlugin,  ) import Skeletest.Internal.Spec (   Spec,   SpecInfo (..),-  applyTestSelectionsHook,-  focusHook,-  manualTestsHook,-  runSpecs,-  skipHook,-  xfailHook,+  newSpecRunner,+  specTreePlugin,  )+import Skeletest.Internal.Spec.Tree (getSpecTests)+import Skeletest.Internal.Utils.Color qualified as Color+import Skeletest.Internal.Utils.Term qualified as Term import Skeletest.Plugin (Hooks (..), Plugin (..))-import Skeletest.Prop.Internal (PropLimitFlag, PropSeedFlag)-import System.Exit (exitFailure)+import Skeletest.Prop.Internal (propPlugin)  runSkeletest :: [Plugin] -> [(FilePath, Spec)] -> IO ()-runSkeletest = runSkeletest' . mconcat--runSkeletest' :: Plugin -> [(FilePath, Spec)] -> IO ()-runSkeletest' Plugin{hooks = hooks0, ..} testModules = do+runSkeletest userPlugins testModules = handleUnknownErrors $ do+  Term.init   selections <- loadCliArgs builtinFlags cliFlags-  setSnapshotRenderers (snapshotRenderers <> defaultSnapshotRenderers)+  resolveANSISupport +  setSnapshotRenderers snapshotRenderers+  setUserHooks hooks+   let initialSpecs = map mkSpec testModules-  success <- runSpecs hooks <=< hooks.modifySpecRegistry selections pure $ initialSpecs-  unless success exitFailure- where-  hooks = mconcat builtinHooks <> hooks0+  specs <-+    userHooks.modifySpecRegistry+      ModifySpecRegistryHookContext+        { testTargets = selections+        }+      initialSpecs+      pure+  when (null $ concatMap (getSpecTests . (.spec)) specs) $ do+    Term.outputErr $ Color.red "ERROR: No tests selected!"+    exitWith ExitNoTests -  builtinHooks =-    [ xfailHook-    , skipHook-    , focusHook-    , applyTestSelectionsHook-    , manualTestsHook+  runner <- newSpecRunner initialSpecs+  exitCode <-+    userHooks.runSpecs+      RunSpecsHookContext+      specs+      runner.run+  runner.printSummary+  exitWith exitCode+ where+  builtinPlugins =+    [ specTreePlugin+    , snapshotPlugin+    , captureOutputPlugin+    , propPlugin     ] -  builtinFlags =-    [ flag @SnapshotUpdateFlag-    , flag @PropSeedFlag-    , flag @PropLimitFlag-    , flag @CaptureOutputFlag+  hooks = foldMap (.hooks) $ builtinPlugins <> userPlugins+  snapshotRenderers = foldMap (.snapshotRenderers) $ builtinPlugins <> userPlugins++  cliFlags = foldMap (.cliFlags) userPlugins+  builtinFlags = foldMap (.cliFlags) builtinPlugins <> generalFlags+  generalFlags =+    [ flag @ANSIFlag+    , flag @(Maybe FormatFlag)     ] -  mkSpec (specPath, specSpec) =+  mkSpec (specPath, spec) =     SpecInfo       { specPath-      , specSpec+      , spec       }++resolveANSISupport :: IO ()+resolveANSISupport = do+  CaptureOutputFlag captureOutput <- getFlag+  ANSIFlag mUseANSI <- getFlag+  traverse_ Term.setANSISupport $+    if+      | Just userANSI <- mUseANSI -> Just userANSI+      | not captureOutput -> Just False -- if --capture-output=off, ANSI could mess up output+      | otherwise -> Nothing

@@ -1,60 +1,19 @@-{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE NoFieldSelectors #-} +-- | The module that contains everything needed to implement a plugin. module Skeletest.Plugin (   -- * Plugin   Plugin (..),   defaultPlugin,    -- * Hooks-  Hooks (..),-  defaultHooks,--  -- * Re-exports--  -- ** TestResult-  X.TestResult (..),-  X.TestResultMessage (..),-  X.BoxSpec,-  X.BoxSpecContent (..),--  -- ** TestInfo-  X.TestInfo (..),--  -- ** Markers-  X.findMarker,-  X.hasMarker,-  X.hasMarkerNamed,--  -- ** SpecRegistry-  X.SpecRegistry,-  X.Spec,-  X.SpecInfo (..),-  X.SpecTree (..),-  X.SpecTest (..),-  X.getSpecTrees,-  X.withSpecTrees,-  X.mapSpecTrees,-  X.traverseSpecTrees,-  X.mapSpecTests,-  X.traverseSpecTests,-  X.filterSpecTests,-  X.mapSpecs,-  X.traverseSpecs,+  module Skeletest.Hooks, ) where +import Skeletest.Hooks import Skeletest.Internal.CLI (Flag)-import Skeletest.Internal.Markers qualified as X-import Skeletest.Internal.Snapshot (SnapshotRenderer)-import Skeletest.Internal.Spec.Output qualified as X-import Skeletest.Internal.Spec.Tree (SpecRegistry)-import Skeletest.Internal.Spec.Tree qualified as X-import Skeletest.Internal.TestInfo (TestInfo (..))-import Skeletest.Internal.TestInfo qualified as X-import Skeletest.Internal.TestRunner (TestResult (..))-import Skeletest.Internal.TestRunner qualified as X-import Skeletest.Internal.TestTargets (TestTargets)+import Skeletest.Internal.Snapshot.Renderer (SnapshotRenderer)  -- | A plugin for extending Skeletest. --@@ -83,40 +42,4 @@     { cliFlags = []     , snapshotRenderers = []     , hooks = defaultHooks-    }---- | Hooks for extending Skeletest.------ Use 'defaultHooks' instead of using v'Hooks' directly, to minimize--- breaking changes.-data Hooks = Hooks-  { modifySpecRegistry :: TestTargets -> (SpecRegistry -> IO SpecRegistry) -> (SpecRegistry -> IO SpecRegistry)-  -- ^ Modify all the specs in the test suite, being able to modify before/after-  -- previously registered hooks.-  ---  -- For example:-  -- @-  -- \_ modify -> pre >=> modify >=> post-  -- @-  ---  -- @since 0.3.4-  , runTest :: TestInfo -> IO TestResult -> IO TestResult-  -- ^ Modify how a test is executed-  }--instance Semigroup Hooks where-  hooks1 <> hooks2 =-    Hooks-      { modifySpecRegistry = \targets -> hooks2.modifySpecRegistry targets . hooks1.modifySpecRegistry targets-      , runTest = \testInfo -> hooks2.runTest testInfo . hooks1.runTest testInfo-      }--instance Monoid Hooks where-  mempty = defaultHooks--defaultHooks :: Hooks-defaultHooks =-  Hooks-    { modifySpecRegistry = \_ -> id-    , runTest = \_ -> id     }

@@ -44,6 +44,7 @@   hasPrefix,   hasInfix,   hasSuffix,+  empty,    -- * IO   returns,@@ -58,4 +59,6 @@ ) where  import Skeletest.Internal.Predicate+import Skeletest.Internal.Snapshot+import Skeletest.Prop.Internal import Prelude ()

@@ -10,6 +10,7 @@   runProperty,    -- * Test+  prop,   forAll,   discard, @@ -27,9 +28,14 @@   label,   collect, -  -- * CLI flags-  PropSeedFlag,-  PropLimitFlag,+  -- * Assertions+  isoWith,+  (===),+  Fun (..),+  IsoChecker (..),++  -- * Plugin+  propPlugin, ) where  import Control.Monad (ap)@@ -49,7 +55,11 @@ 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.Error (SkeletestError (..))+import Skeletest.Internal.CLI qualified as CLI+import Skeletest.Internal.Error (skeletestError)+import Skeletest.Internal.Predicate (Predicate (..), PredicateFuncResult (..), ShowFailCtx (..), render)+import Skeletest.Internal.Spec.Tree (Spec)+import Skeletest.Internal.Spec.Tree qualified as Spec import Skeletest.Internal.TestInfo (TestInfo, getTestInfo) import Skeletest.Internal.TestRunner (   AssertionFail (..),@@ -62,8 +72,11 @@   testResultPass,  ) import Skeletest.Internal.Utils.Color qualified as Color+import Skeletest.Internal.Utils.Text (indent, parens)+import Skeletest.Plugin (Plugin (..), defaultPlugin)+import Skeletest.Prop.Gen (Gen) import Text.Read (readEither, readMaybe)-import UnliftIO.Exception (SomeException, fromException, throwIO, toException)+import UnliftIO.Exception (SomeException, fromException, toException) import UnliftIO.IORef (IORef, newIORef, readIORef, writeIORef)  #if !MIN_VERSION_base(4, 20, 0)@@ -100,7 +113,7 @@       a <- fa       case k a of         PropertyPure [] b -> pure b-        PropertyPure _ _ -> throwIO PropConfigAfterIO+        PropertyPure _ _ -> skeletestError "Property configuration function must be done before any forAll or IO actions"         PropertyIO _ mb -> mb instance MonadIO PropertyM where   liftIO = PropertyIO [] . liftIO@@ -176,8 +189,8 @@   PropertyIO cfg m -> do     (seed, extraConfig) <- loadPropFlags     let cfg' = resolveConfig $ cfg <> extraConfig-    (prop, getException) <- fromPropertyIO m-    report <- Hedgehog.checkReport cfg' size seed prop reportProgress+    (prop_, getException) <- fromPropertyIO m+    report <- Hedgehog.checkReport cfg' size seed prop_ reportProgress      testInfo <- getTestInfo     case Hedgehog.reportStatus report of@@ -198,7 +211,7 @@               -- N.B. testFailContext is reversed!               failure{testFailContext = failure.testFailContext <> reverse info}           Right err -> do-            let addInfo msg = msg <> "\n\n" <> Text.unlines info+            let addInfo msg = msg <> "\n\n" <> Text.intercalate "\n" info             testResultFromErrorWith addInfo err  where   size = 0@@ -229,7 +242,7 @@ toTestResultPass :: Hedgehog.Report Hedgehog.Result -> TestResult toTestResultPass report =   testResultPass-    { testResultMessage =+    { message =         TestResultMessageInline . Color.gray . Text.pack . List.intercalate "\n" . concat $           [ [show testCount <> " tests, " <> show discards <> " discards"]           , renderCoverage report.reportCoverage testCount@@ -353,6 +366,17 @@  {----- Test -----} +-- | Define a property test.+--+-- @+-- describe \"User\" $ do+--   prop "decode . encode === Just" $ do+--     let genUser = ...+--     (decode . encode) P.=== Just \`shouldSatisfy\` P.isoWith genUser+-- @+prop :: String -> Property -> Spec+prop = Spec.test+ forAll :: (GHC.HasCallStack, Show a) => Hedgehog.Gen a -> PropertyM a forAll gen = GHC.withFrozenCallStack $ propM (Hedgehog.forAll gen) @@ -415,8 +439,67 @@ collect :: (Show a, GHC.HasCallStack) => a -> Property collect a = GHC.withFrozenCallStack $ propM $ Hedgehog.collect a -{----- CLI flags -----}+{----- Assertions -----} +data Fun a b = Fun String (a -> b)+data IsoChecker a b = IsoChecker (Fun a b) (Fun a b)++-- | Verify if two functions are isomorphic.+--+-- @+-- prop "reverse . reverse === id" $ do+--   let genList = Gen.list (Range.linear 0 10) $ Gen.int (Range.linear 0 1000)+--   (reverse . reverse) P.=== id \`shouldSatisfy\` P.isoWith genList+-- @+(===) :: (a -> b) -> (a -> b) -> IsoChecker a b+f === g = IsoChecker (Fun "lhs" f) (Fun "rhs" g)++infix 2 ===++-- | See '(===)'.+isoWith :: (GHC.HasCallStack, Show a, Eq b) => Gen a -> Predicate PropertyM (IsoChecker a b)+isoWith gen =+  Predicate+    { predicateFunc = \(IsoChecker (Fun f1DispS f1) (Fun f2DispS f2)) -> do+        a <- GHC.withFrozenCallStack $ forAll gen+        let+          f1Disp = Text.pack f1DispS+          f2Disp = Text.pack f2DispS+          b1 = f1 a+          b2 = f2 a+          aDisp = parens $ render a+          b1Disp = parens $ render b1+          b2Disp = parens $ render b2+        pure+          PredicateFuncResult+            { predicateSuccess = b1 == b2+            , predicateExplain =+                Text.intercalate "\n" $+                  [ b1Disp <> " " <> (if b1 == b2 then "=" else "≠") <> " " <> b2Disp+                  , "where"+                  , indent $ b1Disp <> " = " <> f1Disp <> " " <> aDisp+                  , indent $ b2Disp <> " = " <> f2Disp <> " " <> aDisp+                  ]+            , predicateShowFailCtx = HideFailCtx+            }+    , predicateDisp = disp+    , predicateDispNeg = dispNeg+    }+ where+  disp = "isomorphic"+  dispNeg = "not isomorphic"++{----- Plugin -----}++propPlugin :: Plugin+propPlugin =+  defaultPlugin+    { cliFlags =+        [ CLI.flag @PropSeedFlag+        , CLI.flag @PropLimitFlag+        ]+    }+ newtype PropSeedFlag = PropSeedFlag (Maybe Hedgehog.Seed)  instance IsFlag PropSeedFlag where@@ -425,8 +508,8 @@   flagHelp = "The seed to use for property tests"   flagSpec =     OptionalFlag-      { flagDefault = PropSeedFlag Nothing-      , flagParse = parse+      { default_ = PropSeedFlag Nothing+      , parse = parse       }    where     parse s = maybe (Left $ "Invalid seed: " <> s) Right $ do@@ -443,6 +526,6 @@   flagHelp = "The number of tests to run per property test"   flagSpec =     OptionalFlag-      { flagDefault = PropLimitFlag Nothing-      , flagParse = fmap (PropLimitFlag . Just) . readEither+      { default_ = PropLimitFlag Nothing+      , parse = fmap (PropLimitFlag . Just) . readEither       }

@@ -27,11 +27,15 @@ import Data.Text.IO qualified as Text import GHC.IO.Encoding (setLocaleEncoding, utf8) import Skeletest.Internal.Error (SkeletestError)+import Skeletest.Internal.Exit (+  TestExitCode (..),+  exitWith,+  handleUnknownErrors,+ ) import Skeletest.Internal.Preprocessor (processFile) import Skeletest.Internal.Preprocessor qualified as Preprocessor import System.Environment (getArgs)-import System.Exit (exitFailure)-import System.IO (hPutStrLn, stderr)+import System.IO qualified as IO import UnliftIO.Directory (getCurrentDirectory) import UnliftIO.Exception (displayException, handle) @@ -52,10 +56,12 @@  -- | Output SkeletestError handleErrors :: IO a -> IO a-handleErrors = handle $ \(e :: SkeletestError) -> do-  hPutStrLn stderr $ normalizeLines $ displayException e-  exitFailure+handleErrors = handleUnknownErrors . handleSkeletestErrors  where+  handleSkeletestErrors = handle $ \(e :: SkeletestError) -> do+    IO.hPutStrLn IO.stderr $ normalizeLines $ displayException e+    exitWith ExitPreprocessorFailure+   normalizeLines     | __GLASGOW_HASKELL__ == (908 :: Int) = dropWhileEnd (== '\n')     | otherwise = id

@@ -38,7 +38,7 @@     let flags =           mkFlagInfos "foo" Nothing $             RequiredFlag-              { flagParse = pure . MyFlag+              { parse = pure . MyFlag               }     describe "long flag" $ do       it "parses" $ do@@ -58,7 +58,7 @@     let flags =           mkFlagInfos "foo" (Just 'f') $             RequiredFlag-              { flagParse = pure . MyFlag+              { parse = pure . MyFlag               }     describe "short flag" $ do       it "parses" $ do@@ -80,7 +80,7 @@         let flags' =               mkFlagInfos "foo" (Just 'f') $                 RequiredFlag-                  { flagParse = pure . MyFlag+                  { parse = pure . MyFlag                   }         parseCliArgsWith flags' ["-fasdf"]           `shouldSatisfy` P.con CLIParseSuccess{flagStore = containsFlag (MyFlag "asdf")}@@ -92,8 +92,8 @@     let flags =           mkFlagInfos "foo" Nothing $             OptionalFlag-              { flagDefault = MyFlag ""-              , flagParse = pure . MyFlag+              { default_ = MyFlag ""+              , parse = pure . MyFlag               }     describe "OptionalFlag" $ do       it "returns last flag" $ do@@ -110,7 +110,7 @@     let flags =           mkFlagInfos "foo" Nothing $             RequiredFlag-              { flagParse = pure . MyFlag+              { parse = pure . MyFlag               }     describe "RequiredFlag" $ do       it "returns last flag" $ do@@ -127,7 +127,7 @@     let flags =           mkFlagInfos "foo" Nothing $             SwitchFlag-              { flagFromBool = MyFlag . show+              { fromBool = MyFlag . show               }     describe "SwitchFlag" $ do       it "returns True if set" $ do

@@ -46,6 +46,28 @@       stdout `shouldSatisfy` P.matchesSnapshot       code `shouldBe` ExitSuccess +    integration . it "is rendered on test success with --format=verbose" $ do+      runner <- getFixture @TestRunner+      runner.addTestFile "ExampleSpec.hs" $+        [ "{-# LANGUAGE OverloadedRecordDot #-}"+        , "{-# LANGUAGE OverloadedStrings #-}"+        , "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , "import System.IO qualified as IO"+        , ""+        , "spec = do"+        , "  it \"before\" $ do"+        , "    " <> render_hPutStrLn handle "before"+        , "  it \"test\" $ do"+        , "    " <> render_hPutStrLn handle "line1"+        , "    " <> render_hPutStrLn handle "line2"+        ]+      (code, stdout, stderr) <- runner.runTestsWith def{cliArgs = ["--format=verbose"]}+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot+      code `shouldBe` ExitSuccess+     integration . it "is rendered on test failure" $ do       runner <- getFixture @TestRunner       runner.addTestFile "ExampleSpec.hs" $@@ -108,7 +130,7 @@         , "    " <> render_hPutStrLn handle "line1"         , "    " <> render_hPutStrLn handle "line2"         ]-      (code, stdout, stderr) <- runner.runTestsWith def{cliArgs = ["--capture-output=off"]}+      (code, stdout, stderr) <- runner.runTestsWith def{cliArgs = ["--capture-output=off"], simulateANSI = False}       List.intercalate "\n\n" [">>> stdout", stdout, ">>> stderr", stderr] `shouldSatisfy` P.matchesSnapshot       code `shouldBe` ExitSuccess 

@@ -5,7 +5,9 @@ module Skeletest.Internal.SnapshotSpec (spec) where  import Data.Aeson qualified as Aeson+import Data.Map qualified as Map import Data.String (fromString)+import Data.Text (Text) import Data.Text qualified as Text import Skeletest import Skeletest.Internal.Snapshot (@@ -13,6 +15,7 @@   SnapshotValue (..),   decodeSnapshotFile,   encodeSnapshotFile,+  mkSnapshotTestId,   normalizeSnapshotFile,  ) import Skeletest.Predicate qualified as P@@ -22,8 +25,10 @@  spec :: Spec spec = do+  let noopRank = const 0+   prop "decodeSnapshotFile . encodeSnapshotFile === pure" $ do-    (decodeSnapshotFile . encodeSnapshotFile) P.=== pure `shouldSatisfy` P.isoWith genSnapshotFile+    (decodeSnapshotFile . encodeSnapshotFile noopRank) P.=== pure `shouldSatisfy` P.isoWith genSnapshotFile    prop "normalizeSnapshotFile is idempotent" $ do     file <- forAll genSnapshotFileRaw@@ -31,6 +36,90 @@     let normalizeSnapshotFile' = foldr (.) id $ replicate n normalizeSnapshotFile     normalizeSnapshotFile' file `shouldBe` normalizeSnapshotFile file +  it "sanitizes literal ``` lines" $ do+    let roundtrip x = (decodeSnapshotFile . encodeSnapshotFile noopRank) x `shouldBe` Just x+    roundtrip $ mkSnapshot "```"+    roundtrip $ mkSnapshot "    ```"+    roundtrip $ mkSnapshot "a```b"++  it "handles snapshots for test with ≫ in the name" $ do+    () `shouldSatisfy` P.matchesSnapshot++  integration . it "creates a new snapshot" $ do+    runner <- getFixture @TestRunner+    runner.addTestFile "ExampleSpec.hs" $+      [ "module ExampleSpec (spec) where"+      , ""+      , "import Skeletest"+      , "import qualified Skeletest.Predicate as P"+      , ""+      , "spec = it \"test\" $ do"+      , "  \"example result\" `shouldSatisfy` P.matchesSnapshot"+      ]++    (stdout, stderr) <- expectFailure $ runner.runTestsWith def{cliArgs = []}+    stderr `shouldBe` ""+    stdout `shouldSatisfy` P.matchesSnapshot++    _ <- expectSuccess $ runner.runTestsWith def{cliArgs = ["-u"]}+    snapshot <- runner.readTestFile "__snapshots__/ExampleSpec.snap.md"+    snapshot `shouldSatisfy` P.hasInfix "example result"++    _ <- expectSuccess $ runner.runTestsWith def{cliArgs = []}+    pure ()++  integration . it "updates an existing snapshot" $ do+    runner <- getFixture @TestRunner+    runner.addTestFile "ExampleSpec.hs" $+      [ "module ExampleSpec (spec) where"+      , ""+      , "import Skeletest"+      , "import qualified Skeletest.Predicate as P"+      , ""+      , "spec = it \"fails\" $ do"+      , "  unlines [\"new1\", \"same1\", \"same2\", \"new2\"] `shouldSatisfy` P.matchesSnapshot"+      ]+    runner.addTestFile "__snapshots__/ExampleSpec.snap.md" $+      [ "# Example"+      , ""+      , "## fails"+      , ""+      , "```"+      , "same1"+      , "old1"+      , "same2"+      , "old2"+      , "```"+      ]++    (stdout, stderr) <- expectFailure $ runner.runTestsWith def{cliArgs = []}+    stderr `shouldBe` ""+    stdout `shouldSatisfy` P.matchesSnapshot++    _ <- expectSuccess $ runner.runTestsWith def{cliArgs = ["-u"]}+    snapshot <- runner.readTestFile "__snapshots__/ExampleSpec.snap.md"+    snapshot `shouldSatisfy` P.hasInfix "new1\nsame1\nsame2\nnew2"++    _ <- expectSuccess $ runner.runTestsWith def{cliArgs = []}+    pure ()++  integration . it "only updates if test passes" $ do+    runner <- getFixture @TestRunner+    runner.addTestFile "ExampleSpec.hs" $+      [ "module ExampleSpec (spec) where"+      , ""+      , "import Skeletest"+      , "import qualified Skeletest.Predicate as P"+      , ""+      , "spec = it \"fails\" $ do"+      , "  \"content\" `shouldSatisfy` P.matchesSnapshot"+      , "  failTest \"failure\""+      ]++    _ <- expectFailure $ runner.runTestsWith def{cliArgs = ["-u"]}+    runner.lookupTestFile "__snapshots__/ExampleSpec.snap.md"+      `shouldReturn` Nothing+   integration . it "detects corrupted snapshot files" $ do     runner <- getFixture @TestRunner     runner.addTestFile "ExampleSpec.hs" $@@ -44,10 +133,17 @@       ]     runner.addTestFile "__snapshots__/ExampleSpec.snap.md" ["asdf"] -    (stdout, stderr) <- expectFailure runner.runTests-    stderr `shouldBe` ""-    stdout `shouldSatisfy` P.matchesSnapshot+    (stdout1, stderr1) <- expectCode 5 $ runner.runTestsWith def{cliArgs = []}+    stderr1 `shouldBe` ""+    stdout1 `shouldSatisfy` P.matchesSnapshot +    (stdout2, stderr2) <- expectSuccess $ runner.runTestsWith def{cliArgs = ["-u"]}+    stderr2 `shouldBe` ""+    stdout2 `shouldSatisfy` P.matchesSnapshot++    runner.readTestFile "__snapshots__/ExampleSpec.snap.md"+      `shouldReturn` "# ./ExampleSpec.hs\n\n## should error\n\n```\n\n```\n"+   integration . it "uses registered snapshot renderers" $ do     runner <- getFixture @TestRunner     runner.setMainFile@@ -81,34 +177,239 @@     let result = Aeson.decode $ fromString "{\"hello\": [\"world\", 1]}"     (result :: Maybe Aeson.Value) `shouldSatisfy` P.just P.matchesSnapshot -  integration . it "shows helpful failure messages" $ do+  integration . it "cleans up outdated snapshots" $ do     runner <- getFixture @TestRunner-    runner.addTestFile "ExampleSpec.hs" $-      [ "module ExampleSpec (spec) where"+    -- snapshot test was deleted, file has no other snapshot tests+    runner.addTestFile "Foo/Test1Spec.hs" $+      [ "module Foo.Test1Spec (spec) where"+      , "import Skeletest"+      , "import qualified Skeletest.Predicate as P"+      , "spec = do"+      , "  it \"test other\" $ do"+      , "    pure ()"+      ]+    runner.addTestFile "Foo/__snapshots__/Test1Spec.snap.md" $+      [ "# Foo/Test1Spec.hs"       , ""+      , "## test"+      , ""+      , "```"+      , "old snapshot"+      , "```"+      ]+    let expected1 = Nothing+    -- snapshot test was deleted, file still has other snapshots+    runner.addTestFile "Foo/Test2Spec.hs" $+      [ "module Foo.Test2Spec (spec) where"       , "import Skeletest"       , "import qualified Skeletest.Predicate as P"+      , "spec = do"+      , "  it \"test other\" $ do"+      , "    \"result\" `shouldSatisfy` P.matchesSnapshot"+      ]+    runner.addTestFile "Foo/__snapshots__/Test2Spec.snap.md" $+      [ "# Foo/Test2Spec.hs"       , ""-      , "spec = it \"fails\" $ do"-      , "  unlines [\"new1\", \"same1\", \"same2\", \"new2\"] `shouldSatisfy` P.matchesSnapshot"+      , "## test"+      , ""+      , "```"+      , "old snapshot"+      , "```"+      , ""+      , "## test other"+      , ""+      , "```"+      , "result"+      , "```"       ]-    runner.addTestFile "__snapshots__/ExampleSpec.snap.md" $-      [ "# Example"+    let expected2 =+          Just . Text.unlines $+            [ "# Foo/Test2Spec.hs"+            , ""+            , "## test other"+            , ""+            , "```"+            , "result"+            , "```"+            ]+    -- test still exists without snapshots+    runner.addTestFile "Foo/Test3Spec.hs" $+      [ "module Foo.Test3Spec (spec) where"+      , "import Skeletest"+      , "import qualified Skeletest.Predicate as P"+      , "spec = do"+      , "  it \"test\" $ do"+      , "    pure ()"+      , "  it \"test other\" $ do"+      , "    \"result\" `shouldSatisfy` P.matchesSnapshot"+      ]+    runner.addTestFile "Foo/__snapshots__/Test3Spec.snap.md" $+      [ "# Foo/Test3Spec.hs"       , ""-      , "## fails"+      , "## test"       , ""       , "```"-      , "same1"-      , "old1"-      , "same2"-      , "old2"+      , "old snapshot"       , "```"+      , ""+      , "## test other"+      , ""+      , "```"+      , "result"+      , "```"       ]+    let expected3 =+          Just . Text.unlines $+            [ "# Foo/Test3Spec.hs"+            , ""+            , "## test other"+            , ""+            , "```"+            , "result"+            , "```"+            ]+    -- test still exists with fewer snapshots+    runner.addTestFile "Foo/Test4Spec.hs" $+      [ "module Foo.Test4Spec (spec) where"+      , "import Skeletest"+      , "import qualified Skeletest.Predicate as P"+      , "spec = it \"test\" $ do"+      , "  \"result\" `shouldSatisfy` P.matchesSnapshot"+      ]+    runner.addTestFile "Foo/__snapshots__/Test4Spec.snap.md" $+      [ "# Foo/Test4Spec.hs"+      , ""+      , "## test"+      , ""+      , "```"+      , "result"+      , "```"+      , ""+      , "```"+      , "old snapshot"+      , "```"+      ]+    let expected4 =+          Just . Text.unlines $+            [ "# Foo/Test4Spec.hs"+            , ""+            , "## test"+            , ""+            , "```"+            , "result"+            , "```"+            ]+    -- test file still exists, no tests with snapshots+    runner.addTestFile "Foo/Test5Spec.hs" $+      [ "module Foo.Test5Spec (spec) where"+      , "import Skeletest"+      , "import qualified Skeletest.Predicate as P"+      , "spec = do"+      , "  it \"test\" $ do"+      , "    pure ()"+      ]+    runner.addTestFile "Foo/__snapshots__/Test5Spec.snap.md" $+      [ "# Foo/Test5Spec.hs"+      , ""+      , "## test"+      , ""+      , "```"+      , "old snapshot"+      , "```"+      ]+    let expected5 = Nothing+    -- test file no longer exists+    runner.addTestFile "Foo/__snapshots__/Test6Spec.snap.md" $+      [ "# Foo/Test6Spec.hs"+      , ""+      , "## test"+      , ""+      , "```"+      , "old snapshot"+      , "```"+      ]+    let expected6 = Nothing -    (stdout, stderr) <- expectFailure runner.runTests-    stderr `shouldBe` ""-    stdout `shouldSatisfy` P.matchesSnapshot+    (stdout1, stderr1) <- expectCode 5 $ runner.runTestsWith def+    stderr1 `shouldBe` ""+    stdout1 `shouldSatisfy` P.matchesSnapshot +    (stdout2, stderr2) <- expectSuccess $ runner.runTestsWith def{cliArgs = ["-u"]}+    stderr2 `shouldBe` ""+    stdout2 `shouldSatisfy` P.matchesSnapshot++    runner.lookupTestFile "Foo/__snapshots__/Test1Spec.snap.md"+      `shouldReturn` expected1+    runner.lookupTestFile "Foo/__snapshots__/Test2Spec.snap.md"+      `shouldReturn` expected2+    runner.lookupTestFile "Foo/__snapshots__/Test3Spec.snap.md"+      `shouldReturn` expected3+    runner.lookupTestFile "Foo/__snapshots__/Test4Spec.snap.md"+      `shouldReturn` expected4+    runner.lookupTestFile "Foo/__snapshots__/Test5Spec.snap.md"+      `shouldReturn` expected5+    runner.lookupTestFile "Foo/__snapshots__/Test6Spec.snap.md"+      `shouldReturn` expected6++  integration . it "does not clean up deselected tests" $ do+    runner <- getFixture @TestRunner+    runner.addTestFile "Test1Spec.hs" $+      [ "module Test1Spec (spec) where"+      , "import Skeletest"+      , "import qualified Skeletest.Predicate as P"+      , "spec = do"+      , "  it \"focused test\" $ do"+      , "    \"result\" `shouldSatisfy` P.matchesSnapshot"+      , "  it \"other test\" $ do"+      , "    \"result\" `shouldSatisfy` P.matchesSnapshot"+      ]+    runner.addTestFile "Test2Spec.hs" $+      [ "module Test2Spec (spec) where"+      , "import Skeletest"+      , "import qualified Skeletest.Predicate as P"+      , "spec = do"+      , "  it \"other test\" $ do"+      , "    \"result\" `shouldSatisfy` P.matchesSnapshot"+      ]+    let expected1 =+          Text.unlines+            [ "# ./Test1Spec.hs"+            , ""+            , "## focused test"+            , ""+            , "```"+            , "result"+            , "```"+            , ""+            , "## other test"+            , ""+            , "```"+            , "result"+            , "```"+            ]+    let expected2 =+          Text.unlines+            [ "# ./Test2Spec.hs"+            , ""+            , "## other test"+            , ""+            , "```"+            , "result"+            , "```"+            ]++    _ <- expectSuccess $ runner.runTestsWith def{cliArgs = ["-u"]}+    runner.readTestFile "__snapshots__/Test1Spec.snap.md"+      `shouldReturn` expected1+    runner.readTestFile "__snapshots__/Test2Spec.snap.md"+      `shouldReturn` expected2++    _ <- expectSuccess $ runner.runTestsWith def{cliArgs = ["[focused test]", "-u"]}+    runner.readTestFile "__snapshots__/Test1Spec.snap.md"+      `shouldReturn` expected1+    runner.readTestFile "__snapshots__/Test2Spec.snap.md"+      `shouldReturn` expected2+   integration . it "works when test changes directories" $ do     runner <- getFixture @TestRunner     runner.addTestFile "ExampleSpec.hs" $@@ -145,14 +446,29 @@   genHsModuleName = Gen.text (Range.linear 0 50) $ Gen.choice [Gen.alphaNum, pure '\'']    genSnapshot = do-    ident <- Gen.list (Range.linear 1 10) (Gen.text (Range.linear 1 100) Gen.unicode)+    -- ≫ in test names should be sanitized prior to this+    let chars = Gen.filter (/= '≫') Gen.unicode+    ident <- Gen.list (Range.linear 1 10) (Gen.text (Range.linear 1 100) chars)     vals <- Gen.list rangeSnapshotsPerTest genSnapshotVal-    pure (ident, vals)+    pure (mkSnapshotTestId ident, vals)    genSnapshotVal = do-    snapshotContent <- Gen.text rangeSnapshotSize Gen.unicode-    snapshotLang <- Gen.maybe $ Gen.text (Range.linear 1 5) Gen.unicode+    content <- Gen.text rangeSnapshotSize Gen.unicode+    lang <- Gen.maybe $ Gen.text (Range.linear 1 5) Gen.unicode     pure SnapshotValue{..}  genSnapshotFile :: Gen SnapshotFile genSnapshotFile = normalizeSnapshotFile <$> genSnapshotFileRaw++mkSnapshot :: Text -> SnapshotFile+mkSnapshot content =+  normalizeSnapshotFile+    SnapshotFile+      { testFile = "FooSpec.hs"+      , snapshots =+          Map.singleton (mkSnapshotTestId ["test"]) . (: []) $+            SnapshotValue+              { content+              , lang = Nothing+              }+      }

@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Skeletest.Internal.Spec.TestReporterSpec (spec) where++import Skeletest+import Skeletest.Predicate qualified as P+import Skeletest.TestUtils.Integration++spec :: Spec+spec = do+  integration . describe "Report format" $ do+    sequence_+      [ it ("renders --format=" <> format <> " with " <> ansiLabel) $ do+          runner <- getFixture @TestRunner+          runner.addTestFile "ExampleSpec.hs" $+            [ "module ExampleSpec (spec) where"+            , ""+            , "import Skeletest"+            , ""+            , "spec = do"+            , "  it \"should pass\" $ 1 `shouldBe` (1 :: Int)"+            , "  it \"should fail\" $ 1 `shouldBe` (2 :: Int)"+            , "  skip \"no run\" . it \"should skip\" $ pure ()"+            ]+          (_, stdout, stderr) <-+            runner.runTestsWith+              def+                { simulateANSI = useANSI+                , cliArgs = ["--format=" <> format]+                }+          stderr `shouldBe` ""+          stdout `shouldSatisfy` P.matchesSnapshot+      | useANSI <- [True, False]+      , let ansiLabel = if useANSI then "ANSI" else "non-ANSI"+      , format <- ["minimal", "full", "verbose"]+      ]

@@ -0,0 +1,134 @@+# test/Skeletest/Internal/Spec/TestReporterSpec.hs++## Report format ≫ renders --format=minimal with ANSI++```+◈ ./ExampleSpec.hs ≫ should fail: FAIL+│ ./ExampleSpec.hs:7:+│ │+│ │   it "should fail" $ 1 `shouldBe` (2 :: Int)+│ │                        ^^^^^^^^^^+│ +│ 1 ≠ 2+╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 3 tests ran in 0.00s+  • 1 test passed ✔+  • 1 test failed ✘+  • 1 test skipped ≫+```++## Report format ≫ renders --format=full with ANSI++```+./ExampleSpec.hs+    should pass: OK+╭── should fail: FAIL+│ ./ExampleSpec.hs:7:+│ │+│ │   it "should fail" $ 1 `shouldBe` (2 :: Int)+│ │                        ^^^^^^^^^^+│ +│ 1 ≠ 2+╰───────────────────────────────────────────────────────────────────────────────+    should skip: SKIP+        no run++═════ Test report ═════+➤ 3 tests ran in 0.00s+  • 1 test passed ✔+  • 1 test failed ✘+  • 1 test skipped ≫+```++## Report format ≫ renders --format=verbose with ANSI++```+./ExampleSpec.hs+    should pass: OK (0.00s)+╭── should fail: FAIL (0.00s)+│ ./ExampleSpec.hs:7:+│ │+│ │   it "should fail" $ 1 `shouldBe` (2 :: Int)+│ │                        ^^^^^^^^^^+│ +│ 1 ≠ 2+╰───────────────────────────────────────────────────────────────────────────────+    should skip: SKIP (0.00s)+        no run++═════ Test report ═════+➤ 3 tests ran in 0.00s+  • 1 test passed ✔+  • 1 test failed ✘+  • 1 test skipped ≫+```++## Report format ≫ renders --format=minimal with non-ANSI++```+◈ ./ExampleSpec.hs: +╭── should fail: FAIL+│ ./ExampleSpec.hs:7:+│ │+│ │   it "should fail" $ 1 `shouldBe` (2 :: Int)+│ │                        ^^^^^^^^^^+│ +│ 1 ≠ 2+╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 3 tests ran in 0.00s+  • 1 test passed ✔+  • 1 test failed ✘+  • 1 test skipped ≫+```++## Report format ≫ renders --format=full with non-ANSI++```+./ExampleSpec.hs+    should pass: OK+    should fail: FAIL+╭───╯+│ ./ExampleSpec.hs:7:+│ │+│ │   it "should fail" $ 1 `shouldBe` (2 :: Int)+│ │                        ^^^^^^^^^^+│ +│ 1 ≠ 2+╰───────────────────────────────────────────────────────────────────────────────+    should skip: SKIP+        no run++═════ Test report ═════+➤ 3 tests ran in 0.00s+  • 1 test passed ✔+  • 1 test failed ✘+  • 1 test skipped ≫+```++## Report format ≫ renders --format=verbose with non-ANSI++```+./ExampleSpec.hs+    should pass: OK (0.00s)+    should fail: FAIL (0.00s)+╭───╯+│ ./ExampleSpec.hs:7:+│ │+│ │   it "should fail" $ 1 `shouldBe` (2 :: Int)+│ │                        ^^^^^^^^^^+│ +│ 1 ≠ 2+╰───────────────────────────────────────────────────────────────────────────────+    should skip: SKIP (0.00s)+        no run++═════ Test report ═════+➤ 3 tests ran in 0.00s+  • 1 test passed ✔+  • 1 test failed ✘+  • 1 test skipped ≫+```

@@ -20,7 +20,23 @@         , "  it \"should not run\" $ undefined"         , "  it \"should not run either\" $ undefined"         ]+      (stdout, stderr) <- expectSuccess runner.runTests+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot +  describe "skipTest" $ do+    integration . it "skips tests at runtime" $ do+      runner <- getFixture @TestRunner+      runner.addTestFile "ExampleSpec.hs" $+        [ "module ExampleSpec (spec) where"+        , ""+        , "import Skeletest"+        , ""+        , "spec = do"+        , "  it \"should be skipped\" $ do"+        , "    skipTest \"reason\""+        , "    error \"fail\""+        ]       (stdout, stderr) <- expectSuccess runner.runTests       stderr `shouldBe` ""       stdout `shouldSatisfy` P.matchesSnapshot@@ -130,7 +146,7 @@         , "  it \"bar2\" $ pure ()"         ] -      (stdout, stderr) <- expectSuccess $ runner.runTestsWith def{cliArgs = ["*"]}+      (stdout, stderr) <- expectSuccess $ runner.runTestsWith def{cliArgs = ["*", "--format=full"]}       stderr `shouldBe` ""       stdout         `shouldSatisfy` P.and@@ -156,7 +172,7 @@         , "  it \"bar2\" $ pure ()"         ] -      (stdout, stderr) <- expectSuccess $ runner.runTestsWith def{cliArgs = ["@foo"]}+      (stdout, stderr) <- expectSuccess $ runner.runTestsWith def{cliArgs = ["@foo", "--format=full"]}       stderr `shouldBe` ""       stdout         `shouldSatisfy` P.and@@ -185,7 +201,7 @@         , "  it \"bar2\" $ pure ()"         ] -      (stdout, stderr) <- expectSuccess $ runner.runTestsWith def{cliArgs = ["@my-marker"]}+      (stdout, stderr) <- expectSuccess $ runner.runTestsWith def{cliArgs = ["@my-marker", "--format=full"]}       stderr `shouldBe` ""       stdout         `shouldSatisfy` P.and

@@ -1,10 +1,14 @@ # test/Skeletest/Internal/CLISpec.hs -## getFlag / errors if flag is not registered+## getFlag ≫ errors if flag is not registered  ``` ./ExampleSpec.hs ╭── should error: ERROR │ CLI flag 'my-flag' was not registered. Did you add it to cliFlags in Main.hs? ╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘ ```

@@ -0,0 +1,202 @@+# test/Skeletest/Internal/CaptureSpec.hs++## stdout ≫ is hidden on test success++```+./ExampleSpec.hs+    before: OK+    test: OK++═════ Test report ═════+➤ 2 tests ran in 0.00s+  • 2 tests passed ✔+```++## stdout ≫ is rendered on test success with --format=verbose++```+./ExampleSpec.hs+╭── before: OK (0.00s)+│+╞═══ Captured stdout+│ before+╰───────────────────────────────────────────────────────────────────────────────+╭── test: OK (0.00s)+│+╞═══ Captured stdout+│ line1+│ line2+╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 2 tests ran in 0.00s+  • 2 tests passed ✔+```++## stdout ≫ is rendered on test failure++```+./ExampleSpec.hs+    before: OK+╭── test: FAIL+│ ./ExampleSpec.hs:14:+│ │+│ │     1 `shouldBe` 2+│ │       ^^^^^^^^^^+│ +│ 1 ≠ 2+│+╞═══ Captured stdout+│ line1+│ line2+╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 2 tests ran in 0.00s+  • 1 test passed ✔+  • 1 test failed ✘+```++## stdout ≫ is rendered on test error++```+./ExampleSpec.hs+    before: OK+╭── test: ERROR+│ ExampleSpec.hs:14:+│ │+│ │     Just _ <- pure Nothing+│ │     ^^^^^^+│ +│ Pattern match failure in 'do' block+│+╞═══ Captured stdout+│ line1+│ line2+╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 2 tests ran in 0.00s+  • 1 test passed ✔+  • 1 test failed ✘+```++## stdout ≫ is not captured with --capture-output=off++```+>>> stdout++./ExampleSpec.hs+    before: before+OK+    test: line1+line2+OK++═════ Test report ═════+➤ 2 tests ran in 0.00s+  • 2 tests passed ✔++>>> stderr+```++## stderr ≫ is hidden on test success++```+./ExampleSpec.hs+    before: OK+    test: OK++═════ Test report ═════+➤ 2 tests ran in 0.00s+  • 2 tests passed ✔+```++## stderr ≫ is rendered on test success with --format=verbose++```+./ExampleSpec.hs+╭── before: OK (0.00s)+│+╞═══ Captured stderr+│ before+╰───────────────────────────────────────────────────────────────────────────────+╭── test: OK (0.00s)+│+╞═══ Captured stderr+│ line1+│ line2+╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 2 tests ran in 0.00s+  • 2 tests passed ✔+```++## stderr ≫ is rendered on test failure++```+./ExampleSpec.hs+    before: OK+╭── test: FAIL+│ ./ExampleSpec.hs:14:+│ │+│ │     1 `shouldBe` 2+│ │       ^^^^^^^^^^+│ +│ 1 ≠ 2+│+╞═══ Captured stderr+│ line1+│ line2+╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 2 tests ran in 0.00s+  • 1 test passed ✔+  • 1 test failed ✘+```++## stderr ≫ is rendered on test error++```+./ExampleSpec.hs+    before: OK+╭── test: ERROR+│ ExampleSpec.hs:14:+│ │+│ │     Just _ <- pure Nothing+│ │     ^^^^^^+│ +│ Pattern match failure in 'do' block+│+╞═══ Captured stderr+│ line1+│ line2+╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 2 tests ran in 0.00s+  • 1 test passed ✔+  • 1 test failed ✘+```++## stderr ≫ is not captured with --capture-output=off++```+>>> stdout++./ExampleSpec.hs+    before: OK+    test: OK++═════ Test report ═════+➤ 2 tests ran in 0.00s+  • 2 tests passed ✔++>>> stderr++before+line1+line2+```

@@ -1,15 +1,20 @@ # test/Skeletest/Internal/FixturesSpec.hs -## getFixture / detects circular dependencies+## getFixture ≫ detects circular dependencies  ``` ./ExampleSpec.hs ╭── should error: ERROR-│ Found circular dependency when resolving fixtures: FixtureA -> FixtureB -> FixtureD -> FixtureA-╰────────────────────────────────────────────────────────────────────────────────────────────────+│ Found circular dependency when resolving fixtures: FixtureA -> FixtureB -> Fix+tureD -> FixtureA+╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘ ``` -## getFixture / throws the appropriate error when setup fails+## getFixture ≫ throws the appropriate error when setup fails  ``` ./ExampleSpec.hs@@ -29,4 +34,8 @@ │  │ Fixture setup failed ╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 2 tests ran in 0.00s+  • 2 tests failed ✘ ```

@@ -1,33 +1,40 @@ # test/Skeletest/Internal/SnapshotSpec.hs -## detects corrupted snapshot files+## handles snapshots for test with >> in the name  ```-./ExampleSpec.hs-╭── should error: ERROR-│ Snapshot file was corrupted: ./__snapshots__/ExampleSpec.snap.md-╰───────────────────────────────────────────────────────────────────────────────+() ``` -## renders JSON values+## creates a new snapshot -```json-{-    "hello": [-        "world",-        1-    ]-} ```+◈ ./ExampleSpec.hs ≫ test: FAIL+│ ./ExampleSpec.hs:7:+│ │+│ │   "example result" `shouldSatisfy` P.matchesSnapshot+│ │                    ^^^^^^^^^^^^^^^+│ +│ Snapshot does not exist. Update snapshot with --update.+│ --- expected+│ +++ actual+│ @@ --0,0 +1 @@+│ +example result+╰─────────────────────────────────────────────────────────────────────────────── -## shows helpful failure messages+═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘+``` +## updates an existing snapshot+ ```-./ExampleSpec.hs-╭── fails: FAIL+◈ ./ExampleSpec.hs ≫ fails: FAIL │ ./ExampleSpec.hs:7: │ │-│ │   unlines ["new1", "same1", "same2", "new2"] `shouldSatisfy` P.matchesSnapshot+│ │   unlines ["new1", "same1", "same2", "new2"] `shouldSatisfy` P.matchesSnapsh+ot │ │                                              ^^^^^^^^^^^^^^^ │  │ Result differed from snapshot. Update snapshot with --update.@@ -40,5 +47,92 @@ │  same2 │ -old2 │ +new2-╰─────────────────────────────────────────────────────────────────────────────────+╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘+```++## detects corrupted snapshot files++```+◈ ./ExampleSpec.hs ≫ should error: ERROR+│ Snapshot file was corrupted: __snapshots__/ExampleSpec.snap.md+╰───────────────────────────────────────────────────────────────────────────────++╓─ 🚨 Outdated snapshots detected ────────────────+║  * __snapshots__/ExampleSpec.snap.md+║+║  Update/remove these files with --update.+╙─────────────────────────────────────────────────++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘+```++```+◈ ./ExampleSpec.hs: OK++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test passed ✔+➤ 1 snapshot updated+```++## renders JSON values++```json+{+    "hello": [+        "world",+        1+    ]+}+```++## cleans up outdated snapshots++```+./Foo/Test1Spec.hs+    test other: OK+./Foo/Test2Spec.hs+    test other: OK+./Foo/Test3Spec.hs+    test: OK+    test other: OK+./Foo/Test4Spec.hs+    test: OK+./Foo/Test5Spec.hs+    test: OK++╓─ 🚨 Outdated snapshots detected ────────────────+║  * Foo/__snapshots__/Test1Spec.snap.md+║  * Foo/__snapshots__/Test2Spec.snap.md+║  * Foo/__snapshots__/Test3Spec.snap.md+║  * Foo/__snapshots__/Test4Spec.snap.md+║  * Foo/__snapshots__/Test5Spec.snap.md+║  * Foo/__snapshots__/Test6Spec.snap.md+║+║  Update/remove these files with --update.+╙─────────────────────────────────────────────────++═════ Test report ═════+➤ 6 tests ran in 0.00s+  • 6 tests passed ✔+```++```+◈ ./Foo/Test1Spec.hs: OK+◈ ./Foo/Test2Spec.hs: OK+◈ ./Foo/Test3Spec.hs: OK+◈ ./Foo/Test4Spec.hs: OK+◈ ./Foo/Test5Spec.hs: OK++═════ Test report ═════+➤ 6 tests ran in 0.00s+  • 6 tests passed ✔+➤ 5 snapshots updated+➤ 1 snapshot file cleaned up ```

@@ -1,35 +1,32 @@ # test/Skeletest/Internal/SpecSpec.hs -## focus / fails with -Werror--```-ExampleSpec.hs:6:3: error: [GHC-63394] [-Wx-focused-tests, -Werror=x-focused-tests]-    In the use of ‘focus’-    (imported from Skeletest, but defined in Skeletest.Internal.Spec.Tree):-    "focus should only be used in development"-  |-6 |   focus . it "in progress" $ pure ()-  |   ^^^^^-```--## focus / only runs focused test+## skip ≫ skips tests completely  ``` ./ExampleSpec.hs-    in progress: OK+    should not run: SKIP+        broken tests+    should not run either: SKIP+        broken tests++═════ Test report ═════+➤ 2 tests ran in 0.00s+  • 2 tests skipped ≫ ``` -## skip / skips tests completely+## skipTest ≫ skips tests at runtime  ``` ./ExampleSpec.hs-    should not run: SKIP-        broken tests-    should not run either: SKIP-        broken tests+    should be skipped: SKIP+        reason++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test skipped ≫ ``` -## xfail / checks for expected failures+## xfail ≫ checks for expected failures  ``` ./ExampleSpec.hs@@ -37,9 +34,13 @@         broken tests     should fail too: XFAIL         broken tests++═════ Test report ═════+➤ 2 tests ran in 0.00s+  • 2 tests passed ✔ ``` -## xfail / errors on unexpected passes+## xfail ≫ errors on unexpected passes  ``` ./ExampleSpec.hs@@ -47,4 +48,33 @@         broken tests     should fail too: XPASS         broken tests++═════ Test report ═════+➤ 2 tests ran in 0.00s+  • 2 tests xpassed ✘+```++## focus ≫ only runs focused test++```+./ExampleSpec.hs+    in progress: OK++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test passed ✔+  • 1 test deselected+```++## focus ≫ fails with -Werror++```+ExampleSpec.hs:6:3: error: [GHC-63394] [-Wx-focused-tests, -Werror=x-focused-tes+ts]+    In the use of ‘focus’+    (imported from Skeletest, but defined in Skeletest.Internal.Spec.Tree):+    "focus should only be used in development"+  |+6 |   focus . it "in progress" $ pure ()+  |   ^^^^^ ```

@@ -1,6 +1,6 @@ # test/Skeletest/Internal/TestTargetsSpec.hs -## parseTestTargets / fails with a helpful error message+## parseTestTargets ≫ fails with a helpful error message  ``` Could not parse test target: unexpected '!'

@@ -17,11 +17,9 @@         , ""         , "plugins = [defaultPlugin{hooks = myHooks}]"         , "myHooks = defaultHooks"-        , "  { runTest = \\_ run -> do"-        , "      putStrLn \"before test\""-        , "      result <- run"-        , "      putStrLn \"after test\""-        , "      pure result"+        , "  { runTest = runEarly $ mkHook_"+        , "      (\\_ _ -> putStrLn \"before test\")"+        , "      (\\_ _ _ -> putStrLn \"after test\")"         , "  }"         ]       runner.addTestFile "ExampleSpec.hs" $@@ -29,7 +27,7 @@         , "import Skeletest"         , "spec = it \"should run\" $ pure ()"         ]-      (stdout, _) <- expectSuccess runner.runTests+      (stdout, _) <- expectSuccess $ runner.runTestsWith def{simulateANSI = False}       stdout `shouldSatisfy` P.matchesSnapshot    describe "modifySpecRegistry" $ do@@ -48,7 +46,7 @@         , ""         , "plugins = [defaultPlugin{hooks = myHooks}]"         , "myHooks = defaultHooks"-        , "  { modifySpecRegistry = \\_ modify -> (fmap . mapSpecs . filterSpecTests) isValid . modify"+        , "  { modifySpecRegistry = mkPreHook $ \\_ -> pure . mapSpecs (filterSpecTests isValid)"         , "  }"         , " where"         , "  isValid = not . (\"SKIP\" `T.isPrefixOf`) . (.name)"

@@ -411,7 +411,8 @@                 , "                     Just (User x0)"                 , "                       -> Just"                 , "                            (Skeletest.Internal.Utils.HList.HCons"-                , "                               (pure x0) Skeletest.Internal.Utils.HList.HNil)"+                , "                               (pure x0) Skeletest.Internal.Utils.HList.HNi"+                , "l)"                 , "                     _ -> Nothing"                 , "              (Skeletest.Internal.Utils.HList.HCons"                 , "                 (P.eq \"\") Skeletest.Internal.Utils.HList.HNil)"

@@ -0,0 +1,199 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoFieldSelectors #-}++{-| Simulate an ANSI terminal.++TODO: Break out into separate package?+-}+module Skeletest.TestUtils.ANSI (+  Terminal (..),+  TerminalType (..),+  defaultTerminal,+) where++import Control.Monad.Trans.State.Strict qualified as State+import Data.Char (isDigit)+import Data.List.NonEmpty qualified as NonEmpty+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Records (HasField (..))+import Skeletest.Internal.Utils.Text (showT)+import Text.Read (readMaybe)++data Terminal = Terminal+  { type_ :: TerminalType+  , width :: Int+  }++data TerminalType+  = -- | "\r" as CR, "\ESC" as "^["+    DumbTerminal+  | -- | Strip colors, "\r" as CR, cursor movements as "\uFFFD"+    LogTerminal+  | -- | Strip colors, apply "\r" and cursor movements+    AnsiTerminal++defaultTerminal :: Terminal+defaultTerminal =+  Terminal+    { type_ = DumbTerminal+    , width = 80+    }++-- | Transform a text stream to only contain printable characters you'd actually+-- see in a terminal.+instance HasField "resolve" Terminal (Text -> Text) where+  getField term = resolve term . parse+   where+    resolve =+      case term.type_ of+        DumbTerminal -> resolveDumb+        LogTerminal -> resolveLog+        AnsiTerminal -> resolveAnsi++data Token+  = Token_Text Text+  | Token_CR+  | -- | Contains everything after the "\ESC[" sequence+    Token_Color Text+  | Token_Cursor CursorCode++data CursorCode+  = -- | "\ESC[#F" - Cursor Previous Line+    CSI_CPL Int+  | -- | "\ESC[#K" - Erase in Line+    CSI_EL Int++parse :: Text -> [Token]+parse = go0+ where+  go0 s =+    let (pre, post) = Text.break (`elem` ['\r', '\ESC']) s+     in concat+          [ if Text.null pre then [] else [Token_Text pre]+          , go1 post+          ]++  go1 s0 =+    case Text.uncons s0 of+      Nothing -> []+      Just ('\r', s1) -> Token_CR : go0 s1+      Just ('\ESC', s1) -> fromMaybe (error $ "unsupported escape code: " <> show s0) $ do+        ('[', s2) <- Text.uncons s1+        let (params, s3) = Text.span (\c -> isDigit c || c == ';') s2+        (c, s4) <- Text.uncons s3+        token <-+          case c of+            'm' -> Just $ Token_Color (params <> Text.singleton c)+            'F' -> Token_Cursor . CSI_CPL <$> readParamOr 1 params+            'K' -> Token_Cursor . CSI_EL <$> readParamOr 0 params+            _ -> Nothing+        Just $ token : go0 s4+      _ -> error $ "failed to parse: " <> show s0++  readParamOr n = \case+    "" -> Just n+    params -> readMaybe (Text.unpack params)++wrapLines :: Terminal -> Text -> Text+wrapLines term = Text.unlines . concatMap (rewrap term) . Text.lines++rewrap :: Terminal -> Text -> [Text]+rewrap term s = if Text.null s then [s] else Text.chunksOf term.width s++resolveDumb :: Terminal -> [Token] -> Text+resolveDumb term = wrapLines term . Text.concat . map resolve+ where+  resolve = \case+    Token_Text s -> s+    Token_CR -> "\n"+    Token_Color s -> resolveCSI s+    Token_Cursor csi -> resolveCSI $ toCode csi+  resolveCSI s = "^[[" <> s+  toCode = \case+    CSI_CPL n -> showT n <> "F"+    CSI_EL n -> showT n <> "K"++resolveLog :: Terminal -> [Token] -> Text+resolveLog term = wrapLines term . Text.concat . mapMaybe resolve+ where+  resolve = \case+    Token_Text s -> Just s+    Token_CR -> Just "\n"+    Token_Color _ -> Nothing+    Token_Cursor _ -> Just "\xFFFD"++resolveAnsi :: Terminal -> [Token] -> Text+resolveAnsi term = runTerm . mapM_ interpretToken+ where+  -- State tracked during resolution:+  --   ( [Text]     -- Terminal lines, 0th element is at bottom of screen+  --   , (Int, Int) -- Cursor position as (Row, Col)+  --                --   Row 0 = bottom of the screen+  --                --   Col 0 = left of the screen+  --   )+  --+  -- Invariants:+  --   * Every terminal line has length at most term.width+  --   * Row < length buf+  runTerm m = Text.unlines . reverse . fst $ State.execState m initialState+  initialState = ([""], (0, 0))++  updateCoord f = State.modify $ \(buf, pos) -> (buf, f pos)+  updateCurrLine f = State.modify $ \(buf, pos@(row, _)) ->+    let (linesBelow, line, linesAbove) = splitLines row buf+        buf' = linesBelow <> (f line : linesAbove)+     in (buf', pos)+  splitLines row buf =+    case splitAt row buf of+      (_, []) -> error "row out of bounds"+      (linesBelow, line : linesAbove) -> (linesBelow, line, linesAbove)++  interpretToken = \case+    Token_Text s -> addText s+    Token_CR -> updateCoord $ \(row, _) -> (row, 0)+    Token_Color _ -> pure ()+    Token_Cursor csi -> runCursor csi++  addText s = State.modify $ \(buf, (row, col)) ->+    let (linesBelow, line, linesAbove) = splitLines row buf+        newChunks =+          wrapLast . concatMap (rewrap term) . Text.splitOn "\n" $+            Text.take col line <> s+        newLines = overwrite newChunks (line : reverse linesBelow)+        buf' = reverse newLines <> linesAbove+        row' = max 0 $ row - length newChunks + 1+        col' =+          maybe 0 (Text.length . NonEmpty.last) $+            NonEmpty.nonEmpty newChunks+     in (buf', (row', col'))+   where+    overwrite = \cases+      newLines [] -> newLines+      [] oldLines -> oldLines+      (newLine : newLines) (oldLine : oldLines) ->+        let oldLine' =+              -- If this is the last new line, it might be a partial overwrite+              if null newLines+                then Text.drop (Text.length newLine) oldLine+                else ""+         in (newLine <> oldLine') : overwrite newLines oldLines+    -- If last chunk happens to exactly match term.width,+    -- the cursor should wrap to a new line+    wrapLast chunks =+      case NonEmpty.last <$> NonEmpty.nonEmpty chunks of+        Just lastChunk+          | Text.length lastChunk == term.width -> chunks <> [""]+        _ -> chunks++  runCursor = \case+    CSI_CPL n -> do+      updateCoord $ \(row, _) -> (row + n, 0)+    CSI_EL 0 -> do+      (_, (_, col)) <- State.get+      updateCurrLine $ \line -> Text.take col line+    CSI_EL _ -> error "TODO: handle EL with numeric param"

@@ -16,14 +16,15 @@ #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'+      (_, post2) = span isCallStackLine $ drop 1 post+   in Text.unpack . Text.unlines $ pre ++ post2  where-  mapLast f = \case-    [] -> []-    [x] -> [f x]-    x : xs -> x : mapLast f xs+  isCallStackLine line =+    or+      [ ", called at" `Text.isInfixOf` line+      , -- True if this line is the wrapped continuation of the previous line+        (fmap fst . Text.uncons) line `notElem` map Just ['│', '╰']+      ] #else sanitizeTraceback = id #endif

@@ -23,15 +23,22 @@   def, ) where +import Control.Monad (guard)+import Data.Char (isDigit) import Data.Default (Default (..)) import Data.IORef (IORef, modifyIORef, newIORef, readIORef)+import Data.Text (Text) import Data.Text qualified as Text+import Data.Text.IO qualified as Text import GHC.Records (HasField (..)) import Skeletest+import Skeletest.TestUtils.ANSI (Terminal (..), TerminalType (..), defaultTerminal) import System.Directory (createDirectoryIfMissing) import System.Exit (ExitCode (..)) import System.FilePath (takeDirectory, (</>))+import System.IO.Error (isDoesNotExistError) import System.Process qualified as Process+import UnliftIO.Exception (handleJust)  data MarkerIntegration = MarkerIntegration   deriving (Show)@@ -51,7 +58,6 @@  data TestRunnerSettings = TestRunnerSettings   { mainFileContents :: FileContents-  , testFiles :: [(FilePath, FileContents)]   }  -- | File contents as a list of lines.@@ -66,7 +72,6 @@     defaultSettings =       TestRunnerSettings         { mainFileContents = ["import Skeletest.Main"]-        , testFiles = []         }  instance HasField "setMainFile" TestRunner (FileContents -> IO ()) where@@ -75,27 +80,37 @@       settings{mainFileContents = contents}  instance HasField "addTestFile" TestRunner (FilePath -> FileContents -> IO ()) where-  getField runner fp contents =-    modifyIORef runner.settingsRef $ \settings ->-      settings{testFiles = (fp, contents) : settings.testFiles}+  getField runner fp contents = do+    let path = runner.dir </> fp+    createDirectoryIfMissing True (takeDirectory path)+    writeFile path (unlines contents) -instance HasField "readTestFile" TestRunner (FilePath -> IO String) where-  getField runner fp = readFile $ runner.dir </> fp+instance HasField "lookupTestFile" TestRunner (FilePath -> IO (Maybe Text)) where+  getField runner fp =+    handleDNE (\_ -> pure Nothing) . fmap Just $+      runner.readTestFile fp+   where+    handleDNE = handleJust (\e -> guard (isDoesNotExistError e) *> Just e) +instance HasField "readTestFile" TestRunner (FilePath -> IO Text) where+  getField runner fp = Text.readFile $ runner.dir </> fp+ data TestArgs = TestArgs   { cwd :: Maybe FilePath   , cliArgs :: [String]   , ghcArgs :: [String]   , mainFile :: String+  , simulateANSI :: Bool   }  instance Default TestArgs where   def =     TestArgs       { cwd = Nothing-      , cliArgs = []+      , cliArgs = ["--format=full"]       , ghcArgs = []       , mainFile = "Main.hs"+      , simulateANSI = True       }  instance HasField "runTests" TestRunner (IO (ExitCode, String, String)) where@@ -104,8 +119,7 @@ instance HasField "runTestsWith" TestRunner (TestArgs -> IO (ExitCode, String, String)) where   getField runner args = do     settings <- readIORef runner.settingsRef-    addFile args.mainFile settings.mainFileContents-    mapM_ (uncurry addFile) settings.testFiles+    runner.addTestFile args.mainFile settings.mainFileContents      let ghcArgs =           concat@@ -121,13 +135,14 @@         runProcWith           (maybe id setCWD args.cwd)           (runner.dir </> "test-runner")-          args.cliArgs+          cliArgs       result -> pure result    where-    addFile fp contents = do-      let path = runner.dir </> fp-      createDirectoryIfMissing True (takeDirectory path)-      writeFile path (unlines contents)+    cliArgs =+      concat+        [ args.cliArgs+        , [if args.simulateANSI then "--ansi=always" else "--ansi=never"]+        ]      setCWD dir p = p{Process.cwd = Just dir}     runProcWith f cmd args_ = do@@ -135,25 +150,44 @@       (code, stdout, stderr) <- Process.readCreateProcessWithExitCode proc ""       pure (code, sanitize stdout, sanitize stderr) -    sanitize = Text.unpack . stripOverwrites . stripControlChars . Text.strip . Text.pack-    stripOverwrites s =-      case Text.breakOn "\r" s of-        (_, "") -> s-        (pre, post) -> Text.dropWhileEnd (/= '\n') pre <> stripOverwrites (Text.drop 1 post)-    stripControlChars s =-      case Text.breakOn "\x1b" s of-        (_, "") -> s-        (pre, post) -> pre <> stripControlChars (Text.drop 1 . Text.dropWhile (/= 'm') $ post)+    term =+      defaultTerminal+        { type_ = if args.simulateANSI then AnsiTerminal else LogTerminal+        , width = 80 -- Default for non-ANSI terminals in Skeletest.Internal.Utils.Term+        } -expectCode :: (HasCallStack) => ExitCode -> IO (ExitCode, String, String) -> IO (String, String)+    sanitize =+      Text.unpack+        . Text.strip+        . term.resolve+        . scrubDurations+        . Text.pack+    scrubDurations s =+      case Text.break isDigit s of+        (pre, post)+          -- Check if it's of the form `#.##s`+          | (duration, post') <- Text.splitAt 5 post+          , [c0, '.', c1, c2, 's'] <- Text.unpack duration+          , all isDigit [c0, c1, c2] ->+              pre <> "0.00s" <> scrubDurations post'+          -- Consume the digit, continue on the rest of the string+          | Just (c, post') <- Text.uncons post ->+              pre <> Text.cons c (scrubDurations post')+          -- 'post' is empty; we've checked the whole string+          | otherwise ->+              pre++expectCode :: (HasCallStack) => Int -> IO (ExitCode, String, String) -> IO (String, String) expectCode expected m = do   (code, stdout, stderr) <- m   context (unlines ["===== stdout =====", stdout, "===== stderr =====", stderr]) $-    code `shouldBe` expected+    code `shouldBe` expectedCode   pure (stdout, stderr)+ where+  expectedCode = if expected == 0 then ExitSuccess else ExitFailure expected  expectSuccess :: (HasCallStack) => IO (ExitCode, String, String) -> IO (String, String)-expectSuccess = expectCode ExitSuccess+expectSuccess = expectCode 0  expectFailure :: (HasCallStack) => IO (ExitCode, String, String) -> IO (String, String)-expectFailure = expectCode $ ExitFailure 1+expectFailure = expectCode 1

@@ -1,37 +1,6 @@ # test/Skeletest/AssertionsSpec.hs -## context / should show failure context--```-./ExampleSpec.hs-╭── should fail: FAIL-│ ./ExampleSpec.hs:7:-│ │-│ │     1 `shouldBe` (2 :: Int)-│ │       ^^^^^^^^^^-│ -│ hello-│ world-│ -│ 1 ≠ 2-╰───────────────────────────────────────────────────────────────────────────────-```--## failTest / should show failure--```-./ExampleSpec.hs-╭── should fail: FAIL-│ ./ExampleSpec.hs:5:-│ │-│ │ spec = it "should fail" $ failTest "error message"-│ │                           ^^^^^^^^-│ -│ error message-╰───────────────────────────────────────────────────────────────────────────────-```--## shouldBe / should show helpful failure+## shouldBe ≫ should show helpful failure  ``` ./ExampleSpec.hs@@ -43,9 +12,13 @@ │  │ 1 ≠ 2 ╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘ ``` -## shouldNotBe / should show helpful failure+## shouldNotBe ≫ should show helpful failure  ``` ./ExampleSpec.hs@@ -63,15 +36,37 @@ │ Got: │   1 ╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘ ``` -## shouldNotSatisfy / should show helpful failure+## shouldSatisfy ≫ should show helpful failure  ``` ./ExampleSpec.hs ╭── should fail: FAIL │ ./ExampleSpec.hs:6: │ │+│ │ spec = it "should fail" $ (-1) `shouldSatisfy` P.gt (0 :: Int)+│ │                                ^^^^^^^^^^^^^^^+│ +│ -1 ≯ 0+╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘+```++## shouldNotSatisfy ≫ should show helpful failure++```+./ExampleSpec.hs+╭── should fail: FAIL+│ ./ExampleSpec.hs:6:+│ │ │ │ spec = it "should fail" $ 1 `shouldNotSatisfy` P.gt (0 :: Int) │ │                             ^^^^^^^^^^^^^^^^^^ │ @@ -83,9 +78,13 @@ │ Got: │   1 ╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘ ``` -## shouldReturn / should show helpful failure+## shouldReturn ≫ should show helpful failure  ``` ./ExampleSpec.hs@@ -97,22 +96,51 @@ │  │ 1 ≠ 2 ╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘ ``` -## shouldSatisfy / should show helpful failure+## context ≫ should show failure context  ``` ./ExampleSpec.hs ╭── should fail: FAIL-│ ./ExampleSpec.hs:6:+│ ./ExampleSpec.hs:7: │ │-│ │ spec = it "should fail" $ (-1) `shouldSatisfy` P.gt (0 :: Int)-│ │                                ^^^^^^^^^^^^^^^+│ │     1 `shouldBe` (2 :: Int)+│ │       ^^^^^^^^^^ │ -│ -1 ≯ 0+│ hello+│ world+│ +│ 1 ≠ 2 ╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘ ``` +## failTest ≫ should show failure++```+./ExampleSpec.hs+╭── should fail: FAIL+│ ./ExampleSpec.hs:5:+│ │+│ │ spec = it "should fail" $ failTest "error message"+│ │                           ^^^^^^^^+│ +│ error message+╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘+```+ ## shows backtrace of failed assertions  ```@@ -135,6 +163,10 @@ │  │ -1 ≯ 0 ╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘ ```  ## shows helpful error on pattern match fail@@ -149,8 +181,26 @@ │  │ Pattern match failure in 'do' block ╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘ ``` +## shows unrecognized exceptions++```+./ExampleSpec.hs+╭── should fail: ERROR+│ Got exception of type `IOException`:+│ unknown-file.txt: openFile: does not exist (No such file or directory)+╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘+```+ ## shows source code when running from different directory  ```@@ -163,14 +213,8 @@ │  │ failure ╰───────────────────────────────────────────────────────────────────────────────-``` -## shows unrecognized exceptions--```-./ExampleSpec.hs-╭── should fail: ERROR-│ Got exception of type `IOException`:-│ unknown-file.txt: openFile: does not exist (No such file or directory)-╰───────────────────────────────────────────────────────────────────────────────+═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘ ```

@@ -7,7 +7,8 @@ Could not find Skeletest.Main import in Main module  Main.hs:1:1: error:-    `skeletest-preprocessor' failed in phase `Haskell pre-processor'. (Exit code: 1)+    `skeletest-preprocessor' failed in phase `Haskell pre-processor'. (Exit code+: 10) ```  ## errors if main function defined

@@ -1,17 +1,26 @@ # test/Skeletest/PluginSpec.hs -## modifySpecRegistry / allows modifying specs+## runTest ≫ allows hooking into test execution  ``` ./ExampleSpec.hs-    should run: OK+    should run: before test+after test+OK++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test passed ✔ ``` -## runTest / allows hooking into test execution+## modifySpecRegistry ≫ allows modifying specs  ``` ./ExampleSpec.hs-    should run: before test-after test-OK+    should run: OK++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test passed ✔+  • 1 test deselected ```

@@ -1,33 +1,146 @@ # test/Skeletest/PredicateSpec.hs -## Combinators / && / shows helpful failure messages+## Ord ≫ eq ≫ shows helpful failure messages  ```-1 ≠ 2+2 ≠ 1+``` +```+1 = 1+ Expected:-  (= 2)-  and (> 0)+  ≠ 1  Got:   1 ``` +## Data types ≫ list ≫ shows helpful failure messages+ ```-All predicates passed+10 ≠ 1  Expected:-  At least one failure:-  (= 1)-  and (> 0)+  [= 0, = 1]  Got:-  1+  [0,10] ``` -## Combinators / <<< / shows a helpful failure message+```+Got different number of elements +Expected:+  [= 0, = 1]++Got:+  [0] ```++## Data types ≫ tup ≫ shows helpful failure messages++```+1 ≠ 0++Expected:+  (= 0, = [])++Got:+  (1,[])+```++```+(1 = 1, [] = [])++Expected:+  not (= 1, = [])++Got:+  (1,[])+```++## Data types ≫ con ≫ shows a helpful failure message++```+./ExampleSpec.hs+╭── should error: FAIL+│ ./ExampleSpec.hs:9:+│ │+│ │   User "alice" `shouldSatisfy` P.con User{name = P.eq ""}+│ │                ^^^^^^^^^^^^^^^+│ +│ "alice" ≠ []+│ +│ Expected:+│   matches User{name = (= [])}+│ +│ Got:+│   User "alice"+╰───────────────────────────────────────────────────────────────────────────────++═════ Test report ═════+➤ 1 test ran in 0.00s+  • 1 test failed ✘+```++## Data types ≫ con ≫ fails to compile with unknown record field++```+ExampleSpec.hs:9:43: error: [GHC-76037] Not in scope: ‘foo’+  |+9 |   User "alice" `shouldSatisfy` P.con User{foo = P.eq ""}+  |                                           ^^^+```++## Data types ≫ con ≫ fails to compile with omitted positional fields++```+ExampleSpec.hs:9:3: error: [GHC-27346]+    • The data constructor ‘User’ should have 2 arguments, but has been given 1+    • In the pattern: User x0+      In the pattern: Just (User x0)+      In a case alternative:+          Just (User x0)+            -> Just+                 (Skeletest.Internal.Utils.HList.HCons+                    (pure x0) Skeletest.Internal.Utils.HList.HNil)+  |+9 |   User "alice" (Just 1) `shouldSatisfy` P.con (User (P.eq ""))+  |   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^+```++## Data types ≫ con ≫ fails to compile with non-constructor++```+ExampleSpec.hs:7:22: error: P.con must be applied to a constructor+  |+7 |   "" `shouldSatisfy` P.con ""+  |                      ^^^^^^^^+```++## Data types ≫ con ≫ fails to compile when not applied to anything++```+ExampleSpec.hs:7:22: error: P.con must be applied to a constructor+  |+7 |   "" `shouldSatisfy` P.con+  |                      ^^^^^+```++## Data types ≫ con ≫ fails to compile when applied to multiple arguments++```+ExampleSpec.hs:7:22: error:+    P.con must be applied to exactly one argument+  |+7 |   "" `shouldSatisfy` P.con 1 2+  |                      ^^^^^^^^^+```++## Combinators ≫ <<< ≫ shows a helpful failure message++``` 2 ≯ 10  Expected:@@ -37,7 +150,7 @@   1 ``` -## Combinators / >>> / shows a helpful failure message+## Combinators ≫ >>> ≫ shows a helpful failure message  ``` "1" ≠ "2"@@ -49,7 +162,7 @@   1 ``` -## Combinators / and / shows helpful failure messages+## Combinators ≫ && ≫ shows helpful failure messages  ``` 1 ≠ 2@@ -57,7 +170,6 @@ Expected:   (= 2)   and (> 0)-  and (< 10)  Got:   1@@ -70,13 +182,12 @@   At least one failure:   (= 1)   and (> 0)-  and (< 10)  Got:   1 ``` -## Combinators / or / shows helpful failure messages+## Combinators ≫ || ≫ shows helpful failure messages  ``` No predicates passed@@ -84,7 +195,6 @@ Expected:   (= 2)   or (> 1)-  or (< 0)  Got:   1@@ -97,60 +207,66 @@   All failures:   (= 2)   or (> 0)-  or (< 0)  Got:   1 ``` -## Combinators / || / shows helpful failure messages+## Combinators ≫ and ≫ shows helpful failure messages  ```-No predicates passed+1 ≠ 2  Expected:   (= 2)-  or (> 1)+  and (> 0)+  and (< 10)  Got:   1 ```  ```-1 > 0+All predicates passed  Expected:-  All failures:-  (= 2)-  or (> 0)+  At least one failure:+  (= 1)+  and (> 0)+  and (< 10)  Got:   1 ``` -## Containers / all / shows helpful failure messages+## Combinators ≫ or ≫ shows helpful failure messages  ```-1 ≯ 10+No predicates passed  Expected:-  all elements matching (> 10)+  (= 2)+  or (> 1)+  or (< 0)  Got:-  [1,2]+  1 ```  ```-All values matched+1 > 0  Expected:-  some elements not matching (> 0)+  All failures:+  (= 2)+  or (> 0)+  or (< 0)  Got:-  [1,2,3]+  1 ``` -## Containers / any / shows helpful failure messages+## Containers ≫ any ≫ shows helpful failure messages  ``` No values matched@@ -172,147 +288,51 @@   [1,2,3] ``` -## Containers / elem / shows helpful failure messages--```-No values matched--Expected:-  at least one element matching (= 1)--Got:-  []-```--```-1 = 1--Expected:-  no elements matching (= 1)--Got:-  [1]-```--## Data types / con / fails to compile when applied to multiple arguments--```-ExampleSpec.hs:7:22: error:-    P.con must be applied to exactly one argument-  |-7 |   "" `shouldSatisfy` P.con 1 2-  |                      ^^^^^^^^^-```--## Data types / con / fails to compile when not applied to anything--```-ExampleSpec.hs:7:22: error: P.con must be applied to a constructor-  |-7 |   "" `shouldSatisfy` P.con-  |                      ^^^^^-```--## Data types / con / fails to compile with non-constructor--```-ExampleSpec.hs:7:22: error: P.con must be applied to a constructor-  |-7 |   "" `shouldSatisfy` P.con ""-  |                      ^^^^^^^^-```--## Data types / con / fails to compile with omitted positional fields--```-ExampleSpec.hs:9:3: error: [GHC-27346]-    • The data constructor ‘User’ should have 2 arguments, but has been given 1-    • In the pattern: User x0-      In the pattern: Just (User x0)-      In a case alternative:-          Just (User x0)-            -> Just-                 (Skeletest.Internal.Utils.HList.HCons-                    (pure x0) Skeletest.Internal.Utils.HList.HNil)-  |-9 |   User "alice" (Just 1) `shouldSatisfy` P.con (User (P.eq ""))-  |   ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^-```--## Data types / con / fails to compile with unknown record field--```-ExampleSpec.hs:9:43: error: [GHC-76037] Not in scope: ‘foo’-  |-9 |   User "alice" `shouldSatisfy` P.con User{foo = P.eq ""}-  |                                           ^^^-```--## Data types / con / shows a helpful failure message--```-./ExampleSpec.hs-╭── should error: FAIL-│ ./ExampleSpec.hs:9:-│ │-│ │   User "alice" `shouldSatisfy` P.con User{name = P.eq ""}-│ │                ^^^^^^^^^^^^^^^-│ -│ "alice" ≠ []-│ -│ Expected:-│   matches User{name = (= [])}-│ -│ Got:-│   User "alice"-╰───────────────────────────────────────────────────────────────────────────────-```--## Data types / list / shows helpful failure messages+## Containers ≫ all ≫ shows helpful failure messages  ```-10 ≠ 1+1 ≯ 10  Expected:-  [= 0, = 1]+  all elements matching (> 10)  Got:-  [0,10]+  [1,2] ```  ```-Got different number of elements+All values matched  Expected:-  [= 0, = 1]+  some elements not matching (> 0)  Got:-  [0]+  [1,2,3] ``` -## Data types / tup / shows helpful failure messages+## Containers ≫ elem ≫ shows helpful failure messages  ```-1 ≠ 0+No values matched  Expected:-  (= 0, = [])+  at least one element matching (= 1)  Got:-  (1,[])+  [] ```  ```-(1 = 1, [] = [])+1 = 1  Expected:-  not (= 1, = [])+  no elements matching (= 1)  Got:-  (1,[])+  [1] ``` -## IO / returns / shows helpful failure messages+## IO ≫ returns ≫ shows helpful failure messages  ``` 1 ≠ 0@@ -328,7 +348,7 @@ Left (0 = 0) ``` -## IO / throws / shows helpful failure messages+## IO ≫ throws ≫ shows helpful failure messages  ``` 404 ≠ 500@@ -350,20 +370,4 @@  ``` HttpException (404 = 404)-```--## Ord / eq / shows helpful failure messages--```-2 ≠ 1-```--```-1 = 1--Expected:-  ≠ 1--Got:-  1 ```