skeletest 0.2.1 → 0.3.0

raw patch · 51 files changed

+2282/−1491 lines, 51 filesdep +exceptionsdep +terminal-sizedep ~ghcdep ~hedgehogPVP ok

version bump matches the API change (PVP)

Dependencies added: exceptions, terminal-size

Dependency ranges changed: ghc, hedgehog

API changes (from Hackage documentation)

Files

• CHANGELOG.md +17/−0
• README.md +7/−3
• skeletest.cabal +12/−3
• src/Skeletest.hs +2/−1
• src/Skeletest/Assertions.hs +3/−4
• src/Skeletest/Internal/CLI.hs +151/−152
• src/Skeletest/Internal/Capture.hs +191/−0
• src/Skeletest/Internal/Error.hs +5/−7
• src/Skeletest/Internal/Fixtures.hs +48/−28
• src/Skeletest/Internal/GHC.hs +230/−203
• src/Skeletest/Internal/GHC/Compat.hs +2/−0
• src/Skeletest/Internal/GHC/Compat_9_10.hs +16/−1
• src/Skeletest/Internal/GHC/Compat_9_12.hs +18/−3
• src/Skeletest/Internal/GHC/Compat_9_14.hs +93/−0
• src/Skeletest/Internal/GHC/Compat_9_8.hs +16/−1
• src/Skeletest/Internal/Plugin.hs +103/−104
• src/Skeletest/Internal/Predicate.hs +112/−108
• src/Skeletest/Internal/Preprocessor.hs +55/−56
• src/Skeletest/Internal/Snapshot.hs +143/−144
• src/Skeletest/Internal/Spec.hs +129/−128
• src/Skeletest/Internal/TestInfo.hs +6/−8
• src/Skeletest/Internal/TestRunner.hs +129/−55
• src/Skeletest/Internal/TestTargets.hs +31/−31
• src/Skeletest/Internal/Utils/BoxDrawing.hs +49/−0
• src/Skeletest/Internal/Utils/Diff.hs +2/−2
• src/Skeletest/Internal/Utils/HList.hs +4/−4
• src/Skeletest/Main.hs +16/−21
• src/Skeletest/Prop/Internal.hs +106/−107
• src/bin/skeletest-preprocessor.hs +4/−4
• test/ExampleSpec.hs +0/−1
• test/Skeletest/AssertionsSpec.hs +54/−1
• test/Skeletest/Internal/CLISpec.hs +1/−2
• test/Skeletest/Internal/CaptureSpec.hs +182/−0
• test/Skeletest/Internal/FixturesSpec.hs +0/−1
• test/Skeletest/Internal/SnapshotSpec.hs +23/−18
• test/Skeletest/Internal/SpecSpec.hs +0/−1
• test/Skeletest/Internal/TestTargetsSpec.hs +1/−2
• test/Skeletest/Internal/__snapshots__/CLISpec.snap.md +6/−3
• test/Skeletest/Internal/__snapshots__/FixturesSpec.snap.md +6/−3
• test/Skeletest/Internal/__snapshots__/SnapshotSpec.snap.md +24/−22
• test/Skeletest/Internal/__snapshots__/SpecSpec.snap.md +4/−4
• test/Skeletest/Internal/__snapshots__/TestTargetsSpec.snap.md +1/−1
• test/Skeletest/MainSpec.hs +10/−11
• test/Skeletest/PredicateSpec.hs +63/−64
• test/Skeletest/PropSpec.hs +0/−1
• test/Skeletest/TestUtils/Integration.hs +23/−23
• test/Skeletest/__snapshots__/AssertionsSpec.snap.md +112/−86
• test/Skeletest/__snapshots__/MainSpec.snap.md +1/−1
• test/Skeletest/__snapshots__/PredicateSpec.snap.md +29/−28
• test/Skeletest/__snapshots__/PropSpec.snap.md +41/−39
• test/__snapshots__/ExampleSpec.snap.md +1/−1

@@ -1,3 +1,20 @@+## v0.3.0++GHC support:+* Support GHC 9.14++New features:+* Automatically capture stdout/stderr ([#1](https://github.com/brandonchinn178/skeletest/issues/1))++API changes:+* Specify order of type variables for `P.anything` so that `P.anything @Int` works++Runtime changes:+* Add location to error messages+* Render test failures/errors in more visible box+* Display the path of the test file instead of guessing a module name ([#40](https://github.com/brandonchinn178/skeletest/issues/40))+* Flush stdout so test name is displayed while test is still running+ ## v0.2.1  * Add `P.list`

@@ -286,7 +286,7 @@  ```haskell prop "reverse does not change the length" $ do-  xs <- forAll $ Gen.list (Gen.range 0 10) Gen.int+  xs <- forAll $ Gen.list (Range.linear 0 10) $ Gen.int (Range.linear 1 100)   length (reverse xs) `shouldBe` length xs ``` @@ -294,7 +294,7 @@  ```haskell prop "decodeUser . encodeUser === pure" $ do-  let genUser = User <$> Gen.text (Gen.range 0 10) Gen.unicode+  let genUser = User <$> Gen.text (Range.linear 0 10) Gen.unicode   (decodeUser . encodeUser) P.=== pure `shouldSatisfy` P.isoWith genUser ``` @@ -303,7 +303,7 @@ To ignore certain values, use `discard`:  ```haskell-x <- Gen.int (Gen.range (-10) 10)+x <- Gen.int (Range.linear (-10) 10) when (x == 0) discard ... ```@@ -401,6 +401,10 @@     ```      All tests in the given section will be marked with the given marker, which can be selected with `@my-marker`. You can see if a test has a marker with `findMarkers` (see the "Hooks" section).++### Output capturing++By default, Skeletest will capture all output to stdout/stderr that occurs during a test and will only display it if the test fails. To disable this, pass `--capture-output=off`.  ### Custom CLI flags 

@@ -1,7 +1,7 @@ cabal-version: 3.0  name: skeletest-version: 0.2.1+version: 0.3.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@@ -36,6 +36,7 @@     Skeletest     Skeletest.Assertions     Skeletest.Internal.CLI+    Skeletest.Internal.Capture     Skeletest.Internal.Constants     Skeletest.Internal.Error     Skeletest.Internal.Fixtures@@ -50,6 +51,7 @@     Skeletest.Internal.TestInfo     Skeletest.Internal.TestRunner     Skeletest.Internal.TestTargets+    Skeletest.Internal.Utils.BoxDrawing     Skeletest.Internal.Utils.Color     Skeletest.Internal.Utils.Diff     Skeletest.Internal.Utils.HList@@ -70,6 +72,9 @@   if impl(ghc >= 9.12) && impl(ghc < 9.14)     other-modules:         Skeletest.Internal.GHC.Compat_9_12+  if impl(ghc >= 9.14) && impl(ghc < 9.16)+    other-modules:+        Skeletest.Internal.GHC.Compat_9_14   build-depends:       base < 5     , aeson@@ -79,15 +84,18 @@     , containers     , Diff >= 1.0     , directory+    , exceptions     , filepath-    , ghc ^>= 9.8 || ^>= 9.10 || ^>= 9.12-    , hedgehog+    , ghc ^>= 9.8 || ^>= 9.10 || ^>= 9.12 || ^>= 9.14+    , hedgehog >= 1.5     , megaparsec     , ordered-containers >= 0.2.4     , parser-combinators     , pretty+    , process     , recover-rtti     , template-haskell+    , terminal-size >= 0.2.0     , text     , transformers     , unliftio >= 0.2.17@@ -114,6 +122,7 @@     ExampleSpec     Skeletest.AssertionsSpec     Skeletest.Internal.CLISpec+    Skeletest.Internal.CaptureSpec     Skeletest.Internal.FixturesSpec     Skeletest.Internal.SnapshotSpec     Skeletest.Internal.SpecSpec

@@ -43,6 +43,7 @@    -- ** Built-in fixtures   FixtureTmpDir (..),+  FixtureCapturedOutput (..),    -- * CLI flags   Flag (..),@@ -52,9 +53,9 @@ ) where  import GHC.Stack (HasCallStack)- import Skeletest.Assertions import Skeletest.Internal.CLI+import Skeletest.Internal.Capture import Skeletest.Internal.Fixtures import Skeletest.Internal.Spec import Skeletest.Predicate

@@ -20,10 +20,6 @@ import Data.Text qualified as Text import GHC.Stack (HasCallStack) import GHC.Stack qualified as GHC-import System.IO.Unsafe (unsafePerformIO)-import UnliftIO.Exception (bracket_, throwIO)-import UnliftIO.IORef (IORef, modifyIORef, newIORef, readIORef)- import Skeletest.Internal.Predicate (   Predicate,   PredicateResult (..),@@ -37,6 +33,9 @@   Testable (..),   testResultPass,  )+import System.IO.Unsafe (unsafePerformIO)+import UnliftIO.Exception (bracket_, throwIO)+import UnliftIO.IORef (IORef, modifyIORef, newIORef, readIORef)  instance Testable IO where   runTestable m = m >> pure testResultPass

@@ -35,15 +35,14 @@ 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.TestTargets (TestTargets, parseTestTargets) import System.Environment (getArgs) import System.Exit (exitFailure, exitSuccess) import System.IO (stderr) import System.IO.Unsafe (unsafePerformIO) import UnliftIO.Exception (throwIO) -import Skeletest.Internal.Error (SkeletestError (..), invariantViolation)-import Skeletest.Internal.TestTargets (TestTargets, parseTestTargets)- -- | Register a CLI flag. -- -- Usage:@@ -122,8 +121,8 @@               , "Got: " <> show dyn               ]       Nothing -> throwIO $ CliFlagNotFound (Text.pack $ flagName @a)-  where-    rep = typeRep (Proxy @a)+ where+  rep = typeRep (Proxy @a)  {----- Load CLI arguments -----} @@ -146,84 +145,84 @@     CLIParseSuccess{testTargets, flagStore} -> do       setCliFlagStore flagStore       pure testTargets-  where-    helpText = getHelpText builtinFlags flags+ where+  helpText = getHelpText builtinFlags flags  getHelpText :: [Flag] -> [Flag] -> Text getHelpText builtinFlags customFlags =   Text.intercalate "\n\n" $     "Usage: skeletest [OPTIONS] [--] [TARGETS]" : map (uncurry renderSection) helpSections-  where-    helpSections =-      filter (not . Text.null . snd) $-        [ ("TEST SELECTION", testSelectionDocs)-        , ("BUILTIN OPTIONS", renderFlagList builtinFlagDocs)-        , ("CUSTOM OPTIONS", renderFlagList customFlagDocs)-        ]--    testSelectionDocs =-      Text.intercalate "\n" $-        [ "Test targets may be specified as plain positional arguments, with the following syntax:"-        , "    * Tests including substring:      '[myFooFunc]'"-        , "    * Tests tagged with marker:       '@fast'"-        , "    * Tests in file, relative to CWD: 'test/MyLib/FooSpec.hs'"-        , "    * Tests matching pattern in file: 'test/MyLib/FooSpec.hs[myFooFunc]'"-        , "        * Syntax sugar for '(test/MyLib/FooSpec.hs and [myFooFunc])'"-        , "    * Tests matching both targets:    '[func1] and [func2]'"-        , "    * Tests matching either target:   '[func1] or [func2]'"-        , "    * Tests not matching target:      'not [func1]'"-        , ""-        , "More examples:"-        , "    * 'test/MySpec.hs and ([myFooFunc] or [myBarFunc]) and @fast'"-        , "    * '[myFooFunc] or test/MySpec.hs[myBarFunc]'"-        , ""-        , "When multiple targets are specified, they are joined with 'or'."-        ]+ where+  helpSections =+    filter (not . Text.null . snd) $+      [ ("TEST SELECTION", testSelectionDocs)+      , ("BUILTIN OPTIONS", renderFlagList builtinFlagDocs)+      , ("CUSTOM OPTIONS", renderFlagList customFlagDocs)+      ] -    builtinFlagDocs = ("help", Just 'h', Nothing, "Display this help text") : fromFlags builtinFlags-    customFlagDocs = fromFlags customFlags-    fromFlags flags =-      [ (Text.pack (flagName @a), flagShort @a, mMetaVar, Text.pack (flagHelp @a))-      | Flag (Proxy :: Proxy a) <- flags-      , let mMetaVar =-              case flagSpec @a of-                SwitchFlag{} -> Nothing-                RequiredFlag{} -> Just $ Text.pack (flagMetaVar @a)-                OptionalFlag{} -> Just $ Text.pack (flagMetaVar @a)+  testSelectionDocs =+    Text.intercalate "\n" $+      [ "Test targets may be specified as plain positional arguments, with the following syntax:"+      , "    * Tests including substring:      '[myFooFunc]'"+      , "    * Tests tagged with marker:       '@fast'"+      , "    * Tests in file, relative to CWD: 'test/MyLib/FooSpec.hs'"+      , "    * Tests matching pattern in file: 'test/MyLib/FooSpec.hs[myFooFunc]'"+      , "        * Syntax sugar for '(test/MyLib/FooSpec.hs and [myFooFunc])'"+      , "    * Tests matching both targets:    '[func1] and [func2]'"+      , "    * Tests matching either target:   '[func1] or [func2]'"+      , "    * Tests not matching target:      'not [func1]'"+      , ""+      , "More examples:"+      , "    * 'test/MySpec.hs and ([myFooFunc] or [myBarFunc]) and @fast'"+      , "    * '[myFooFunc] or test/MySpec.hs[myBarFunc]'"+      , ""+      , "When multiple targets are specified, they are joined with 'or'."       ] -    renderSection title body =-      Text.intercalate "\n" $-        [ "===== " <> title-        , ""-        , body-        ]+  builtinFlagDocs = ("help", Just 'h', Nothing, "Display this help text") : fromFlags builtinFlags+  customFlagDocs = fromFlags customFlags+  fromFlags flags =+    [ (Text.pack (flagName @a), flagShort @a, mMetaVar, Text.pack (flagHelp @a))+    | Flag (Proxy :: Proxy a) <- flags+    , let mMetaVar =+            case flagSpec @a of+              SwitchFlag{} -> Nothing+              RequiredFlag{} -> Just $ Text.pack (flagMetaVar @a)+              OptionalFlag{} -> Just $ Text.pack (flagMetaVar @a)+    ] -    renderFlagList flagList =-      Text.intercalate "\n" . mkTabular $-        [ (shortName <> renderLongFlag longName <> metaVar, help)-        | (longName, mShortName, mMetaVar, help) <- flagList-        , let-            shortName =-              case mShortName of-                Just short -> renderShortFlag short <> ", "-                Nothing -> ""-            metaVar =-              case mMetaVar of-                Just meta -> " <" <> meta <> ">"-                Nothing -> ""-        ]+  renderSection title body =+    Text.intercalate "\n" $+      [ "===== " <> title+      , ""+      , body+      ] -    mkTabular rows0 =-      case NonEmpty.nonEmpty rows0 of-        Nothing -> []-        Just rows ->-          let fstColWidth = Foldable1.maximum $ NonEmpty.map (Text.length . fst) rows-              margin = 2 -- space between columns-           in [ a <> Text.replicate (fstColWidth - Text.length a + margin) " " <> b-              | (a, b) <- NonEmpty.toList rows-              ]+  renderFlagList flagList =+    Text.intercalate "\n" . mkTabular $+      [ (shortName <> renderLongFlag longName <> metaVar, help)+      | (longName, mShortName, mMetaVar, help) <- flagList+      , let+          shortName =+            case mShortName of+              Just short -> renderShortFlag short <> ", "+              Nothing -> ""+          metaVar =+            case mMetaVar of+              Just meta -> " <" <> meta <> ">"+              Nothing -> ""+      ] +  mkTabular rows0 =+    case NonEmpty.nonEmpty rows0 of+      Nothing -> []+      Just rows ->+        let fstColWidth = Foldable1.maximum $ NonEmpty.map (Text.length . fst) rows+            margin = 2 -- space between columns+         in [ a <> Text.replicate (fstColWidth - Text.length a + margin) " " <> b+            | (a, b) <- NonEmpty.toList rows+            ]+ {----- Parse args -----}  data CLIParseResult@@ -247,103 +246,103 @@   testTargets <- first CLIParseFailure $ parseTestTargets args'   flagStore' <- first CLIParseFailure $ resolveFlags flags flagStore   pure CLIParseSuccess{testTargets, flagStore = flagStore'}-  where-    extractLongFlags =-      toFlagMap renderLongFlag $-        [ (Text.pack $ flagName @a, f)-        | f@(Flag (Proxy :: Proxy a)) <- flags-        ]+ where+  extractLongFlags =+    toFlagMap renderLongFlag $+      [ (Text.pack $ flagName @a, f)+      | f@(Flag (Proxy :: Proxy a)) <- flags+      ] -    extractShortFlags =-      toFlagMap renderShortFlag $-        [ (shortFlag, f)-        | f@(Flag (Proxy :: Proxy a)) <- flags-        , Just shortFlag <- pure $ flagShort @a-        ]+  extractShortFlags =+    toFlagMap renderShortFlag $+      [ (shortFlag, f)+      | f@(Flag (Proxy :: Proxy a)) <- flags+      , Just shortFlag <- pure $ flagShort @a+      ] -    toFlagMap :: (Ord name) => (name -> Text) -> [(name, a)] -> Either CLIParseResult (Map name a)-    toFlagMap renderFlag vals =-      let go seen = \case-            [] -> Right $ Map.fromList vals-            (name, _) : xs-              | name `Set.member` seen -> Left . CLISetupFailure $ "Flag registered multiple times: " <> renderFlag name-              | otherwise -> go (Set.insert name seen) xs-       in go Set.empty vals+  toFlagMap :: (Ord name) => (name -> Text) -> [(name, a)] -> Either CLIParseResult (Map name a)+  toFlagMap renderFlag vals =+    let go seen = \case+          [] -> Right $ Map.fromList vals+          (name, _) : xs+            | name `Set.member` seen -> Left . CLISetupFailure $ "Flag registered multiple times: " <> renderFlag name+            | otherwise -> go (Set.insert name seen) xs+     in go Set.empty vals  type ArgParserM = Trans.StateT ([Text], CLIFlagStore) (Trans.Except Text)  parseCliArgsWith :: Map Text Flag -> Map Char Flag -> [String] -> Either Text ([Text], CLIFlagStore) parseCliArgsWith longFlags shortFlags = Trans.runExcept . flip Trans.execStateT ([], Map.empty) . parseArgs-  where-    parseArgs = \case-      [] -> pure ()-      "--" : rest -> addArgs rest-      curr : rest-        | Just longFlag <- Text.stripPrefix "--" (Text.pack curr) -> parseLongFlag longFlag rest-        | Just chars <- Text.stripPrefix "-" (Text.pack curr) ->-            case Text.unpack chars of-              [] -> argError "Invalid flag: -"-              [shortFlag] -> parseShortFlag shortFlag rest-              _ -> argError $ "Invalid flag: -" <> chars-        | otherwise -> addArgs [curr] >> parseArgs rest+ where+  parseArgs = \case+    [] -> pure ()+    "--" : rest -> addArgs rest+    curr : rest+      | Just longFlag <- Text.stripPrefix "--" (Text.pack curr) -> parseLongFlag longFlag rest+      | Just chars <- Text.stripPrefix "-" (Text.pack curr) ->+          case Text.unpack chars of+            [] -> argError "Invalid flag: -"+            [shortFlag] -> parseShortFlag shortFlag rest+            _ -> argError $ "Invalid flag: -" <> chars+      | otherwise -> addArgs [curr] >> parseArgs rest -    parseLongFlag name args =-      let (name', args') =-            case Text.breakOn "=" name of-              (_, "") -> (name, args)-              (n, post) -> (n, (drop 1 . Text.unpack) post : args)-       in parseFlag renderLongFlag longFlags name' args'-    parseShortFlag = parseFlag renderShortFlag shortFlags+  parseLongFlag name args =+    let (name', args') =+          case Text.breakOn "=" name of+            (_, "") -> (name, args)+            (n, post) -> (n, (drop 1 . Text.unpack) post : args)+     in parseFlag renderLongFlag longFlags name' args'+  parseShortFlag = parseFlag renderShortFlag shortFlags -    parseFlag :: (Ord name) => (name -> Text) -> Map name Flag -> name -> [String] -> ArgParserM ()-    parseFlag renderFlag flagMap name args = do-      Flag (Proxy :: Proxy a) <--        case Map.lookup name flagMap of-          Nothing -> argError $ "Unknown flag: " <> renderFlag name-          Just f -> pure f-      let parseFlagArg parseArg =-            case args of-              [] -> argError $ "Flag requires argument: " <> renderFlag name-              curr : rest -> parseArg curr >>= addFlagStore >> parseArgs rest-      case flagSpec @a of-        SwitchFlag{flagFromBool} -> addFlagStore (flagFromBool True) >> parseArgs args-        RequiredFlag{flagParse} -> parseFlagArg (Trans.lift . Trans.except . first Text.pack . flagParse)-        OptionalFlag{flagParse} -> parseFlagArg (Trans.lift . Trans.except . first Text.pack . flagParse)+  parseFlag :: (Ord name) => (name -> Text) -> Map name Flag -> name -> [String] -> ArgParserM ()+  parseFlag renderFlag flagMap name args = do+    Flag (Proxy :: Proxy a) <-+      case Map.lookup name flagMap of+        Nothing -> argError $ "Unknown flag: " <> renderFlag name+        Just f -> pure f+    let parseFlagArg parseArg =+          case args of+            [] -> argError $ "Flag requires argument: " <> renderFlag name+            curr : rest -> parseArg curr >>= addFlagStore >> parseArgs rest+    case flagSpec @a of+      SwitchFlag{flagFromBool} -> addFlagStore (flagFromBool True) >> parseArgs args+      RequiredFlag{flagParse} -> parseFlagArg (Trans.lift . Trans.except . first Text.pack . flagParse)+      OptionalFlag{flagParse} -> parseFlagArg (Trans.lift . Trans.except . first Text.pack . flagParse) -    argError = Trans.lift . Trans.throwE+  argError = Trans.lift . Trans.throwE -    addArgs :: [String] -> ArgParserM ()-    addArgs args = Trans.modify (first (<> map Text.pack args))+  addArgs :: [String] -> ArgParserM ()+  addArgs args = Trans.modify (first (<> map Text.pack args)) -    addFlagStore :: (Typeable a) => a -> ArgParserM ()-    addFlagStore x = Trans.modify (second (insertFlagStore x))+  addFlagStore :: (Typeable a) => a -> ArgParserM ()+  addFlagStore x = Trans.modify (second (insertFlagStore x))  resolveFlags :: [Flag] -> CLIFlagStore -> Either Text CLIFlagStore resolveFlags = flip (foldlM go)-  where-    go flagStore (Flag (Proxy :: Proxy a)) = do-      let rep = typeRep (Proxy @a)-      case flagSpec @a of-        SwitchFlag{flagFromBool} ->-          pure $-            if rep `Map.member` flagStore-              then flagStore-              else insertFlagStore (flagFromBool False) flagStore-        RequiredFlag{} ->+ where+  go flagStore (Flag (Proxy :: Proxy a)) = do+    let rep = typeRep (Proxy @a)+    case flagSpec @a of+      SwitchFlag{flagFromBool} ->+        pure $           if rep `Map.member` flagStore-            then pure flagStore-            else Left $ "Required flag not set: " <> renderLongFlag (Text.pack $ flagName @a)-        OptionalFlag{flagDefault} ->-          pure $-            if rep `Map.member` flagStore-              then flagStore-              else insertFlagStore flagDefault flagStore+            then flagStore+            else insertFlagStore (flagFromBool False) flagStore+      RequiredFlag{} ->+        if rep `Map.member` flagStore+          then pure flagStore+          else Left $ "Required flag not set: " <> renderLongFlag (Text.pack $ flagName @a)+      OptionalFlag{flagDefault} ->+        pure $+          if rep `Map.member` flagStore+            then flagStore+            else insertFlagStore flagDefault flagStore -    foldlM f z = \case-      [] -> pure z-      x : xs -> do-        z' <- f z x-        foldlM f z' xs+  foldlM f z = \case+    [] -> pure z+    x : xs -> do+      z' <- f z x+      foldlM f z' xs  renderLongFlag :: Text -> Text renderLongFlag = ("--" <>)

@@ -0,0 +1,191 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoFieldSelectors #-}++module Skeletest.Internal.Capture (+  CaptureOutputFlag,+  withCaptureOutput,+  addCapturedOutput,+  FixtureCapturedOutput (..),+) where++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 Skeletest.Internal.CLI (+  FlagSpec (..),+  IsFlag (..),+  getFlag,+ )+import Skeletest.Internal.Fixtures (+  Fixture (..),+  FixtureSkeletestTmpDir (..),+  getFixture,+  noCleanup,+  withCleanup,+ )+import Skeletest.Internal.TestRunner (+  TestResult (..),+  TestResultMessage (..),+ )+import Skeletest.Internal.Utils.BoxDrawing (BoxSpecContent (..))+import System.Directory (removePathForcibly)+import System.IO qualified as IO+import UnliftIO.Exception (finally)++newtype CaptureOutputFlag = CaptureOutputFlag Bool++instance IsFlag CaptureOutputFlag where+  flagName = "capture-output"+  flagHelp = "Whether to capture stdout/stderr: on (default), off"+  flagSpec =+    OptionalFlag+      { flagDefault = CaptureOutputFlag True+      , flagParse = \case+          "off" -> Right $ CaptureOutputFlag False+          "on" -> Right $ CaptureOutputFlag True+          s -> Left $ "invalid value: " <> s+      }++type CapturedOutput = Maybe (Text, Text)++withCaptureOutput :: IO a -> IO (CapturedOutput, a)+withCaptureOutput action = do+  CaptureOutputFlag output <- getFlag+  if output+    then do+      handles <- getFixture @FixtureCapturedOutputHandles+      (stdout, (stderr, a)) <- capture handles.stdout . capture handles.stderr $ action+      pure (Just (stdout, stderr), a)+    else (Nothing,) <$> action+ where+  capture handle m =+    withRestore handle.real $ do+      IO.hFlush handle.real+      IO.hDuplicateTo handle.log handle.real+      a <- m+      out <- getOutput handle+      pure (out, a)++  withRestore h m = do+    buf <- IO.hGetBuffering h+    orig <- IO.hDuplicate h+    m `finally` do+      IO.hDuplicateTo orig h+      IO.hSetBuffering h buf+      IO.hClose orig++addCapturedOutput :: CapturedOutput -> TestResult -> TestResult+addCapturedOutput = maybe id updateResult+ where+  updateResult output result =+    result+      { testResultMessage =+          TestResultMessageSection . concat $+            [ toBoxContents (testResultMessage result)+            , renderOutput output+            ]+      }+  toBoxContents = \case+    TestResultMessageNone -> []+    TestResultMessageInline msg -> [BoxText msg]+    TestResultMessageSection 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+  , stderr :: LogHandle+  }++data LogHandle = LogHandle+  { log :: IO.Handle+  , real :: IO.Handle+  }++initHandle ::+  IO.Handle ->+  FilePath ->+  FilePath ->+  IO (LogHandle, IO ())+initHandle real tmpdir file = do+  (fp, h) <- IO.openTempFile tmpdir file+  IO.hSetBuffering h IO.LineBuffering+  let handle = LogHandle{log = h, real = real}+      cleanup = IO.hClose h >> removePathForcibly fp+  pure (handle, cleanup)++instance Fixture FixtureCapturedOutputHandles where+  fixtureAction = do+    FixtureSkeletestTmpDir tmpdir <- getFixture+    (stdout, cleanupStdout) <- initHandle IO.stdout tmpdir "stdout"+    (stderr, cleanupStderr) <- initHandle IO.stderr tmpdir "stderr"+    pure . withCleanup FixtureCapturedOutputHandles{..} $ do+      cleanupStdout+      cleanupStderr++getOutput :: LogHandle -> IO Text+getOutput = readOutputFrom 0++readOutput :: LogHandle -> IO Text+readOutput handle = do+  pos <- IO.hTell handle.log+  readOutputFrom pos handle++readOutputFrom :: Integer -> LogHandle -> IO Text+readOutputFrom n handle = do+  -- Flush buffers+  IO.hFlush handle.real+  IO.hFlush handle.log++  -- Force handle to end of file, to refresh from real handle+  IO.hSeek handle.log IO.SeekFromEnd 0++  IO.hSeek handle.log IO.AbsoluteSeek n+  go ""+ where+  go acc = do+    out <- Text.hGetChunk handle.log+    if Text.null out+      then pure acc+      else go $! acc <> out++-- | Fixture for inspecting the captured output.+--+-- Intended to be used with @OverloadedRecordDot@:+--+-- @+-- output <- getFixture @FixtureCapturedOutput+--+-- -- Read all of stdout/stderr so far+-- stdout <- output.getStdout+-- stderr <- output.getStderr+--+-- -- Read everything in stdout/stderr since the last read+-- stdout_chunk <- output.readStdout+-- stderr_chunk <- output.readStderr+-- @+data FixtureCapturedOutput = FixtureCapturedOutput+  { getStdout :: IO Text+  , getStderr :: IO Text+  , readStdout :: IO Text+  , readStderr :: IO Text+  }++instance Fixture FixtureCapturedOutput where+  fixtureAction = do+    handles <- getFixture @FixtureCapturedOutputHandles+    pure . noCleanup $+      FixtureCapturedOutput+        { getStdout = getOutput handles.stdout+        , getStderr = getOutput handles.stderr+        , readStdout = readOutput handles.stdout+        , readStderr = readOutput handles.stderr+        }

@@ -9,12 +9,12 @@  import Data.Text (Text) import Data.Text qualified as Text-import GHC.Utils.Panic (pgmError)+import GHC qualified import UnliftIO.Exception (Exception (..), impureThrow)  data SkeletestError   = -- | A user error during compilation, e.g. during the preprocessor or plugin phases.-    CompilationError Text+    CompilationError (Maybe GHC.SrcSpan) Text   | -- | An error in a situation that should never happen, and indicates a bug.     InvariantViolation Text   | TestInfoNotFound@@ -26,7 +26,7 @@ instance Exception SkeletestError where   displayException =     Text.unpack . \case-      CompilationError msg ->+      CompilationError _ msg ->         Text.unlines           [ ""           , "******************** skeletest failure ********************"@@ -46,10 +46,8 @@       SnapshotFileCorrupted fp ->         "Snapshot file was corrupted: " <> Text.pack fp -skeletestPluginError :: String -> a-skeletestPluginError = pgmError . stripEnd . displayException . CompilationError . Text.pack-  where-    stripEnd = Text.unpack . Text.stripEnd . Text.pack+skeletestPluginError :: Maybe GHC.SrcSpan -> String -> a+skeletestPluginError mloc = impureThrow . CompilationError mloc . Text.pack  invariantViolation :: String -> a invariantViolation = impureThrow . InvariantViolation . Text.pack

@@ -15,6 +15,7 @@   cleanupFixtures,    -- * Built-in fixtures+  FixtureSkeletestTmpDir (..),   FixtureTmpDir (..), ) where @@ -30,17 +31,22 @@ import Data.Proxy (Proxy (..)) import Data.Text qualified as Text import Data.Typeable (TypeRep, Typeable, eqT, typeOf, typeRep, (:~:) (Refl))-import System.Directory (createDirectory, getTemporaryDirectory, removePathForcibly)-import System.FilePath ((</>))-import System.IO.Unsafe (unsafePerformIO)-import UnliftIO.Exception (throwIO, tryAny)- import Skeletest.Internal.Error (SkeletestError (..), invariantViolation) import Skeletest.Internal.TestInfo (   TestInfo (testFile),   getTestInfo,  ) import Skeletest.Internal.Utils.Map qualified as Map.Utils+import System.Directory (+  createDirectory,+  createDirectoryIfMissing,+  getTemporaryDirectory,+  removePathForcibly,+ )+import System.FilePath ((</>))+import System.IO.Unsafe (unsafePerformIO)+import System.Process (getCurrentPid)+import UnliftIO.Exception (throwIO, tryAny)  class (Typeable a) => Fixture a where   -- | The scope of the fixture, defaults to per-test@@ -115,11 +121,11 @@       result@(fixture, _) <- fixtureAction @a       modifyFixtureRegistry $ \registry -> (insertFixture (FixtureLoaded result) registry, ())       pure fixture-  where-    rep = typeRep (Proxy @a)-    isInProgress = \case-      FixtureInProgress -> True-      _ -> False+ where+  rep = typeRep (Proxy @a)+  isInProgress = \case+    FixtureInProgress -> True+    _ -> False  -- | Clean up fixtures in the given scope. --@@ -144,11 +150,11 @@   case catMaybes errors of     e : _ -> throwIO e     [] -> pure ()-  where-    (getScopedFixtures, updateScopedFixtures) = getScopedAccessors scopeKey-    fromLeft = \case-      Left x -> Just x-      Right _ -> Nothing+ where+  (getScopedFixtures, updateScopedFixtures) = getScopedAccessors scopeKey+  fromLeft = \case+    Left x -> Just x+    Right _ -> Nothing  {----- Fixtures registry -----} @@ -167,23 +173,23 @@  fixtureRegistryRef :: IORef FixtureRegistry fixtureRegistryRef = unsafePerformIO $ newIORef emptyFixtureRegistry-  where-    emptyFixtureRegistry =-      FixtureRegistry-        { sessionFixtures = OMap.empty-        , fileFixtures = Map.empty-        , testFixtures = Map.empty-        }+ where+  emptyFixtureRegistry =+    FixtureRegistry+      { sessionFixtures = OMap.empty+      , fileFixtures = Map.empty+      , testFixtures = Map.empty+      } {-# NOINLINE fixtureRegistryRef #-}  modifyFixtureRegistry :: (FixtureRegistry -> (FixtureRegistry, a)) -> IO a modifyFixtureRegistry = atomicModifyIORef fixtureRegistryRef  getScopedAccessors ::-  FixtureScopeKey-  -> ( FixtureRegistry -> FixtureMap-     , (FixtureMap -> FixtureMap) -> FixtureRegistry -> FixtureRegistry-     )+  FixtureScopeKey ->+  ( FixtureRegistry -> FixtureMap+  , (FixtureMap -> FixtureMap) -> FixtureRegistry -> FixtureRegistry+  ) getScopedAccessors scopeKey =   case scopeKey of     PerTestFixtureKey tid ->@@ -201,13 +207,27 @@  {----- Built-in fixtures -----} +-- | A fixture that provides a global temporary directory for internal Skeletest use.+newtype FixtureSkeletestTmpDir = FixtureSkeletestTmpDir FilePath++instance Fixture FixtureSkeletestTmpDir where+  fixtureScope = PerSessionFixture+  fixtureAction = do+    tmpdir <- getTemporaryDirectory+    pid <- getCurrentPid+    let dir = tmpdir </> ("skeletest-tmp-dir." <> show pid)+    removePathForcibly dir+    createDirectoryIfMissing True dir+    pure . withCleanup (FixtureSkeletestTmpDir dir) $+      removePathForcibly dir+ -- | A fixture that provides a temporary directory that can be used in a test. newtype FixtureTmpDir = FixtureTmpDir FilePath  instance Fixture FixtureTmpDir where   fixtureAction = do-    tmpdir <- getTemporaryDirectory-    let dir = tmpdir </> "skeletest-tmp-dir"+    FixtureSkeletestTmpDir tmpdir <- getFixture+    let dir = tmpdir </> "test-tmp-dir"     removePathForcibly dir     createDirectory dir     pure . withCleanup (FixtureTmpDir dir) $

@@ -36,6 +36,7 @@   hsExprLam,   hsExprCase,   getExpr,+  getLoc,   renderHsExpr,    -- ** Types@@ -51,11 +52,13 @@   getHsName, ) where +import Control.Monad.Catch (handleJust) import Control.Monad.Trans.Class qualified as Trans import Control.Monad.Trans.State (StateT, evalStateT) import Control.Monad.Trans.State qualified as State import Data.Data (Data) import Data.Data qualified as Data+import Data.List.NonEmpty qualified as NonEmpty import Data.Map (Map) import Data.Map qualified as Map import Data.Maybe (fromMaybe)@@ -70,13 +73,15 @@   IsPass,   unLoc,  )-import GHC qualified as GHC+import GHC qualified import GHC.Driver.Main qualified as GHC import GHC.Plugins qualified as GHC hiding (getHscEnv)+import GHC.Tc.Errors.Types qualified as GHC import GHC.Tc.Utils.Monad qualified as GHC import GHC.Types.Name qualified as GHC.Name import GHC.Types.Name.Cache qualified as GHC (NameCache) import GHC.Types.SourceText qualified as GHC.SourceText+import GHC.Utils.Error qualified as GHC import Language.Haskell.TH.Syntax qualified as TH import System.IO.Unsafe (unsafePerformIO) @@ -84,7 +89,10 @@ import Data.Foldable (foldl') #endif -import Skeletest.Internal.Error (invariantViolation, skeletestPluginError)+import Skeletest.Internal.Error (+  SkeletestError (CompilationError),+  invariantViolation,+ ) import Skeletest.Internal.GHC.Compat (genLoc) import Skeletest.Internal.GHC.Compat qualified as GHC.Compat @@ -132,12 +140,12 @@         group' <- runCompileRn $ modifyModuleExprs (onRename ctx moduleName) group         pure (gblEnv, group')     }-  where-    getModuleName GHC.Module{moduleName} = Text.pack $ GHC.moduleNameString moduleName+ where+  getModuleName GHC.Module{moduleName} = Text.pack $ GHC.moduleNameString moduleName -    modifyParsedResultModule f x = x{GHC.parsedResultModule = f $ GHC.parsedResultModule x}-    modifyHpmModule f x = x{GHC.hpm_module = f $ GHC.hpm_module x}-    modifyModDecls f x = x{GHC.hsmodDecls = f $ GHC.hsmodDecls x}+  modifyParsedResultModule f x = x{GHC.parsedResultModule = f $ GHC.parsedResultModule x}+  modifyHpmModule f x = x{GHC.hpm_module = f $ GHC.hpm_module x}+  modifyModDecls f x = x{GHC.hsmodDecls = f $ GHC.hsmodDecls x}  {----- ParsedModule -----} @@ -159,29 +167,29 @@         | Just funName <- map (getValName . unLoc) hsmodDecls         ]     }-  where-    getValName = \case-      GHC.ValD _ GHC.FunBind{fun_id} -> Just . hsGhcName . unLoc $ fun_id-      _ -> Nothing+ where+  getValName = \case+    GHC.ValD _ GHC.FunBind{fun_id} -> Just . hsGhcName . unLoc $ fun_id+    _ -> Nothing  {----- modifyModuleExprs -----}  modifyModuleExprs ::   forall m.   (MonadCompile m GhcRn) =>-  (HsExpr GhcRn -> HsExpr GhcRn)-  -> GHC.HsGroup GhcRn-  -> m (GHC.HsGroup GhcRn)+  (HsExpr GhcRn -> HsExpr GhcRn) ->+  GHC.HsGroup GhcRn ->+  m (GHC.HsGroup GhcRn) modifyModuleExprs f = go-  where-    go :: (Data a) => a -> m a-    go = Data.gmapM $ \x -> updateExpr x >>= go+ where+  go :: (Data a) => a -> m a+  go = Data.gmapM $ \x -> updateExpr x >>= go -    updateExpr :: (Data a) => a -> m a-    updateExpr (x :: a) =-      case Typeable.eqT @(GHC.LHsExpr GhcRn) @a of-        Just Typeable.Refl -> compileHsExpr . f . parseHsExpr $ x-        Nothing -> pure x+  updateExpr :: (Data a) => a -> m a+  updateExpr (x :: a) =+    case Typeable.eqT @(GHC.LHsExpr GhcRn) @a of+      Just Typeable.Refl -> compileHsExpr . f . parseHsExpr $ x+      Nothing -> pure x  {----- HsExpr -----} @@ -219,6 +227,14 @@ getExpr :: HsExpr p -> HsExprData p getExpr HsExprUnsafe{hsExpr} = hsExpr +getLoc :: HsExpr p -> Maybe GHC.SrcSpan+getLoc HsExprUnsafe{ghcExpr} = getLoc' <$> ghcExpr+ where+  getLoc' :: GhcLHsExpr p -> GHC.SrcSpan+  getLoc' = \case+    GhcLHsExprPs e -> GHC.getLocA e+    GhcLHsExprRn e -> GHC.getLocA e+ renderHsExpr :: HsExpr GhcRn -> Text renderHsExpr = \case   HsExprUnsafe{ghcExpr = Just e} -> Text.pack $ show e@@ -257,35 +273,35 @@  parseHsExpr :: GHC.LHsExpr GhcRn -> HsExpr GhcRn parseHsExpr = goExpr-  where-    goExpr e =-      HsExprUnsafe-        { ghcExpr = Just $ GhcLHsExprRn e-        , hsExpr = goData e-        }+ where+  goExpr e =+    HsExprUnsafe+      { ghcExpr = Just $ GhcLHsExprRn e+      , hsExpr = goData e+      } -    goData = \case-      L _ (GHC.HsVar _ (L _ name)) ->-        if (GHC.occNameSpace . GHC.occName) name == GHC.Name.dataName-          then HsExprCon (hsGhcName name)-          else HsExprVar (hsGhcName name)-      e@(L _ GHC.HsApp{}) ->-        let (f, xs) = collectApps e-         in HsExprApps (goExpr f) (map goExpr xs)-      L _ (GHC.OpApp _ lhs op rhs) ->-        HsExprOp (goExpr lhs) (goExpr op) (goExpr rhs)-      L _ (GHC.RecordCon _ conName GHC.HsRecFields{rec_flds}) ->-        HsExprRecordCon (hsGhcName $ unLoc conName) $ map (getRecField . unLoc) rec_flds-      L _ par@GHC.HsPar{} -> goData $ GHC.Compat.unHsPar par-      _ -> HsExprOther+  goData = \case+    L _ (GHC.HsVar _ name) ->+      if (GHC.occNameSpace . GHC.getOccName) (unLoc name) == GHC.Name.dataName+        then HsExprCon (hsGhcName . GHC.Compat.unLocWithUserRdr $ name)+        else HsExprVar (hsGhcName . GHC.Compat.unLocWithUserRdr $ name)+    e@(L _ GHC.HsApp{}) ->+      let (f, xs) = collectApps e+       in HsExprApps (goExpr f) (map goExpr xs)+    L _ (GHC.OpApp _ lhs op rhs) ->+      HsExprOp (goExpr lhs) (goExpr op) (goExpr rhs)+    L _ (GHC.RecordCon _ conName GHC.HsRecFields{rec_flds}) ->+      HsExprRecordCon (hsGhcName . GHC.Compat.unLocWithUserRdr $ conName) $ map (getRecField . unLoc) rec_flds+    L _ par@GHC.HsPar{} -> goData $ GHC.Compat.unHsPar par+    _ -> HsExprOther -    getRecField GHC.HsFieldBind{hfbLHS = field, hfbRHS = expr} =-      (hsGhcName . unLoc . GHC.Compat.foLabel . unLoc $ field, goExpr expr)+  getRecField GHC.HsFieldBind{hfbLHS = field, hfbRHS = expr} =+    (hsGhcName . unLoc . GHC.Compat.foLabel . unLoc $ field, goExpr expr) -    -- Collect an application of the form `((f a) b) c` and return `f [a, b, c]`-    collectApps = \case-      L _ (GHC.HsApp _ l r) -> let (f, xs) = collectApps l in (f, xs <> [r])-      e -> (e, [])+  -- Collect an application of the form `((f a) b) c` and return `f [a, b, c]`+  collectApps = \case+    L _ (GHC.HsApp _ l r) -> let (f, xs) = collectApps l in (f, xs <> [r])+    e -> (e, [])  {----- HsType -----} @@ -324,15 +340,15 @@ fromTHName nameCache name =   case unsafePerformIO $ GHC.thNameToGhcNameIO nameCache name of     Just n -> n-    Nothing -> skeletestPluginError $ "Could not get Name for `" <> show name <> "`"+    Nothing -> invariantViolation $ "Could not get Name for `" <> show name <> "`"  matchesNameImpl :: GHC.NameCache -> HsName GhcRn -> HsName GhcRn -> Bool matchesNameImpl nameCache n1 n2 = fromMaybe False $ (==) <$> go n1 <*> go n2-  where-    go = \case-      HsName name -> Just $ fromTHName nameCache name-      HsVarName _ -> Nothing -- new names will never match-      HsGhcName name -> Just $ unGhcIdP name+ where+  go = \case+    HsName name -> Just $ fromTHName nameCache name+    HsVarName _ -> Nothing -- new names will never match+    HsGhcName name -> Just $ unGhcIdP name  getHsName :: HsName p -> Text getHsName = \case@@ -365,8 +381,19 @@   deriving (Functor, Applicative, Monad)  runCompileRn :: CompileRn a -> GHC.TcM a-runCompileRn (CompileRn m) = evalStateT m Map.empty+runCompileRn (CompileRn m) = handleCompilationError $ evalStateT m Map.empty+ where+  handleCompilationError =+    handleJust+      ( \case+          CompilationError mloc msg -> Just $ do+            GHC.failAt (fromMaybe GHC.noSrcSpan mloc) $ mkTcError msg+          _ -> Nothing+      )+      id +  mkTcError = GHC.mkTcRnUnknownMessage . GHC.mkPlainError GHC.noHints . GHC.text . Text.unpack+ instance MonadHasNameCache CompileRn where   getNameCache = GHC.hsc_NC . GHC.env_top <$> (CompileRn . Trans.lift) GHC.getEnv instance MonadCompileName CompileRn GhcRn where@@ -383,8 +410,8 @@ compileHsName ::   forall p m.   (GHC.IsPass p, MonadCompile m (GhcPass p)) =>-  HsName (GhcPass p)-  -> m (GHC.IdP (GhcPass p))+  HsName (GhcPass p) ->+  m (GHC.IdP (GhcPass p)) compileHsName = \case   HsName name -> do     nameCache <- getNameCache@@ -410,163 +437,163 @@                 , m_grhss =                     GHC.GRHSs                       { grhssExt = GHC.emptyComments-                      , grhssGRHSs = [genLoc $ GHC.GRHS GHC.noAnn [] body]+                      , grhssGRHSs = GHC.Compat.toGrhssGRHSs $ genLoc (GHC.GRHS GHC.noAnn [] body) NonEmpty.:| []                       , grhssLocalBinds = GHC.EmptyLocalBinds GHC.noExtField                       }                 }           ]     ]-  where-    mkSigD name ty =-      genLoc-        . GHC.SigD GHC.noExtField-        . GHC.TypeSig GHC.noAnn [genLoc name]-        . GHC.HsWC GHC.noExtField-        . genLoc-        $ GHC.HsSig GHC.noExtField (GHC.HsOuterImplicit GHC.noExtField) ty+ where+  mkSigD name ty =+    genLoc+      . GHC.SigD GHC.noExtField+      . GHC.TypeSig GHC.noAnn [genLoc name]+      . GHC.HsWC GHC.noExtField+      . genLoc+      $ GHC.HsSig GHC.noExtField (GHC.HsOuterImplicit GHC.noExtField) ty  compileHsType :: (MonadCompile m GhcPs) => HsType GhcPs -> m (GHC.LHsType GhcPs) compileHsType = go-  where-    go = \case-      HsTypeCon name -> do-        genLoc . GHC.HsTyVar GHC.noAnn GHC.NotPromoted . genLoc <$> compileHsName name-      HsTypeApps ty0 tys -> do-        ty0' <- go ty0-        tys' <- mapM go tys-        pure $ foldl' (\l r -> genLoc $ GHC.HsAppTy GHC.noExtField l r) ty0' tys'-      HsTypeTuple tys -> do-        tys' <- mapM go tys-        pure . genLoc $ GHC.HsTupleTy GHC.noAnn GHC.HsBoxedOrConstraintTuple tys'+ where+  go = \case+    HsTypeCon name -> do+      genLoc . GHC.HsTyVar GHC.noAnn GHC.NotPromoted . genLoc <$> compileHsName name+    HsTypeApps ty0 tys -> do+      ty0' <- go ty0+      tys' <- mapM go tys+      pure $ foldl' (\l r -> genLoc $ GHC.HsAppTy GHC.noExtField l r) ty0' tys'+    HsTypeTuple tys -> do+      tys' <- mapM go tys+      pure . genLoc $ GHC.HsTupleTy GHC.noAnn GHC.HsBoxedOrConstraintTuple tys'  compileHsPat ::   forall p m.   (IsPass p, MonadCompile m (GhcPass p)) =>-  HsPat (GhcPass p)-  -> m (GHC.LPat (GhcPass p))+  HsPat (GhcPass p) ->+  m (GHC.LPat (GhcPass p)) compileHsPat = go-  where-    go = \case-      HsPatCon conName args -> do-        conName' <- fromConName conName-        con <- GHC.PrefixCon [] <$> mapM go args-        pure . genLoc $-          GHC.ConPat-            (onPsOrRn @p GHC.noAnn GHC.noExtField)-            conName'-            con-      HsPatVar name -> do-        name' <- onPsOrRn @p genLoc genLoc <$> compileHsName name-        pure . genLoc $ GHC.VarPat GHC.noExtField name'-      HsPatRecord conName fields -> do-        conName' <- fromConName conName-        con <- GHC.RecCon <$> compileRecFields go fields-        pure . genLoc $-          GHC.ConPat-            (onPsOrRn @p GHC.noAnn GHC.noExtField)-            conName'-            con-      HsPatWild -> do-        pure . genLoc $ GHC.WildPat $ onPsOrRn @p GHC.noExtField GHC.noExtField+ where+  go = \case+    HsPatCon conName args -> do+      conName' <- fromConName conName+      con <- GHC.Compat.mkPrefixCon <$> mapM go args+      pure . genLoc $+        GHC.ConPat+          (onPsOrRn @p GHC.noAnn GHC.noExtField)+          conName'+          con+    HsPatVar name -> do+      name' <- onPsOrRn @p genLoc genLoc <$> compileHsName name+      pure . genLoc $ GHC.VarPat GHC.noExtField name'+    HsPatRecord conName fields -> do+      conName' <- fromConName conName+      con <- GHC.RecCon <$> compileRecFields go fields+      pure . genLoc $+        GHC.ConPat+          (onPsOrRn @p GHC.noAnn GHC.noExtField)+          conName'+          con+    HsPatWild -> do+      pure . genLoc $ GHC.WildPat $ onPsOrRn @p GHC.noExtField GHC.noExtField -    fromConName = fmap (onPsOrRn @p genLoc genLoc) . compileHsName+  fromConName = fmap (genLocConLikeP @p) . compileHsName  compileHsExpr ::   forall p m.   (IsPass p, MonadCompile m (GhcPass p)) =>-  HsExpr (GhcPass p)-  -> m (GHC.LHsExpr (GhcPass p))+  HsExpr (GhcPass p) ->+  m (GHC.LHsExpr (GhcPass p)) compileHsExpr = goExpr-  where-    goExpr :: HsExpr (GhcPass p) -> m (GHC.LHsExpr (GhcPass p))-    goExpr = \case-      HsExprUnsafe{ghcExpr = Just e} -> pure $ unGhcLHsExpr e-      HsExprUnsafe{hsExpr = e} -> goData e+ where+  goExpr :: HsExpr (GhcPass p) -> m (GHC.LHsExpr (GhcPass p))+  goExpr = \case+    HsExprUnsafe{ghcExpr = Just e} -> pure $ unGhcLHsExpr e+    HsExprUnsafe{hsExpr = e} -> goData e -    goData :: HsExprData (GhcPass p) -> m (GHC.LHsExpr (GhcPass p))-    goData = \case-      HsExprCon name -> do-        genLoc . GHC.HsVar GHC.noExtField . genLocIdP @p <$> compileHsName name-      HsExprVar name -> do-        genLoc . GHC.HsVar GHC.noExtField . genLocIdP @p <$> compileHsName name-      HsExprApps f xs -> do-        f' <- goExpr f-        xs' <- mapM goExpr xs-        pure $ foldl' (\l r -> genLoc $ GHC.Compat.hsApp l r) (parens f') (map parens xs')-      HsExprOp _ _ _ ->-        invariantViolation "Compiling HsExprOp not yet supported"-      HsExprList exprs -> do-        exprs' <- mapM goExpr exprs-        pure . genLoc $-          GHC.ExplicitList-            (onPsOrRn @p GHC.noAnn GHC.noExtField)-            exprs'-      HsExprRecordCon con fields -> do-        con' <- genLocConLikeP @p <$> compileHsName con-        fields' <- compileRecFields goExpr fields-        pure . genLoc $-          GHC.RecordCon-            (onPsOrRn @p GHC.noAnn GHC.noExtField)-            con'-            fields'-      HsExprLitString s -> do-        pure . genLoc . GHC.Compat.hsLit $-          GHC.HsString GHC.SourceText.NoSourceText (fsText s)-      HsExprLam pats expr -> do-        pats' <- mapM compileHsPat pats-        expr' <- goExpr expr-        pure . genLoc . GHC.Compat.hsLamSingle $-          GHC.MG origin . genLoc $-            [ genLoc $+  goData :: HsExprData (GhcPass p) -> m (GHC.LHsExpr (GhcPass p))+  goData = \case+    HsExprCon name -> do+      genLoc . GHC.HsVar GHC.noExtField . genLocIdP @p <$> compileHsName name+    HsExprVar name -> do+      genLoc . GHC.HsVar GHC.noExtField . genLocIdP @p <$> compileHsName name+    HsExprApps f xs -> do+      f' <- goExpr f+      xs' <- mapM goExpr xs+      pure $ foldl' (\l r -> genLoc $ GHC.Compat.hsApp l r) (parens f') (map parens xs')+    HsExprOp _ _ _ ->+      invariantViolation "Compiling HsExprOp not yet supported"+    HsExprList exprs -> do+      exprs' <- mapM goExpr exprs+      pure . genLoc $+        GHC.ExplicitList+          (onPsOrRn @p GHC.noAnn GHC.noExtField)+          exprs'+    HsExprRecordCon con fields -> do+      con' <- genLocConLikeP @p <$> compileHsName con+      fields' <- compileRecFields goExpr fields+      pure . genLoc $+        GHC.RecordCon+          (onPsOrRn @p GHC.noAnn GHC.noExtField)+          con'+          fields'+    HsExprLitString s -> do+      pure . genLoc . GHC.Compat.hsLit $+        GHC.HsString GHC.SourceText.NoSourceText (fsText s)+    HsExprLam pats expr -> do+      pats' <- mapM compileHsPat pats+      expr' <- goExpr expr+      pure . genLoc . GHC.Compat.hsLamSingle $+        GHC.MG origin . genLoc $+          [ genLoc $+              GHC.Match+                { m_ext = GHC.Compat.xMatch+                , m_ctxt = GHC.Compat.lamAltSingle+                , m_pats = GHC.Compat.toMatchArgs pats'+                , m_grhss =+                    GHC.GRHSs+                      { grhssExt = GHC.emptyComments+                      , grhssGRHSs = GHC.Compat.toGrhssGRHSs $ genLoc (GHC.GRHS GHC.noAnn [] expr') NonEmpty.:| []+                      , grhssLocalBinds = GHC.EmptyLocalBinds GHC.noExtField+                      }+                }+          ]+    HsExprCase expr matches -> do+      expr' <- goExpr expr+      matches' <-+        sequence+          [ do+              pat' <- compileHsPat pat+              body' <- goExpr body+              pure . genLoc $                 GHC.Match                   { m_ext = GHC.Compat.xMatch-                  , m_ctxt = GHC.Compat.lamAltSingle-                  , m_pats = GHC.Compat.toMatchArgs pats'+                  , m_ctxt = GHC.CaseAlt+                  , m_pats = GHC.Compat.toMatchArgs [pat']                   , m_grhss =                       GHC.GRHSs                         { grhssExt = GHC.emptyComments-                        , grhssGRHSs = [genLoc $ GHC.GRHS GHC.noAnn [] expr']+                        , grhssGRHSs = GHC.Compat.toGrhssGRHSs $ genLoc (GHC.GRHS GHC.noAnn [] body') NonEmpty.:| []                         , grhssLocalBinds = GHC.EmptyLocalBinds GHC.noExtField                         }                   }-            ]-      HsExprCase expr matches -> do-        expr' <- goExpr expr-        matches' <--          sequence-            [ do-                pat' <- compileHsPat pat-                body' <- goExpr body-                pure . genLoc $-                  GHC.Match-                    { m_ext = GHC.Compat.xMatch-                    , m_ctxt = GHC.CaseAlt-                    , m_pats = GHC.Compat.toMatchArgs [pat']-                    , m_grhss =-                        GHC.GRHSs-                          { grhssExt = GHC.emptyComments-                          , grhssGRHSs = [genLoc $ GHC.GRHS GHC.noAnn [] body']-                          , grhssLocalBinds = GHC.EmptyLocalBinds GHC.noExtField-                          }-                    }-            | (pat, body) <- matches-            ]-        pure-          . genLoc-          . GHC.HsCase (onPsOrRn @p GHC.noAnn GHC.CaseAlt) expr'-          $ GHC.MG origin (genLoc matches')-      HsExprOther ->-        invariantViolation "Compiling HsExprOther not supported"+          | (pat, body) <- matches+          ]+      pure+        . genLoc+        . GHC.HsCase (onPsOrRn @p GHC.noAnn GHC.CaseAlt) expr'+        $ GHC.MG origin (genLoc matches')+    HsExprOther ->+      invariantViolation "Compiling HsExprOther not supported" -    origin = onPsOrRn @p GHC.FromSource GHC.FromSource+  origin = onPsOrRn @p GHC.FromSource GHC.FromSource -    parens :: (IsPass p) => GHC.LHsExpr (GhcPass p) -> GHC.LHsExpr (GhcPass p)-    parens = \case-      e@(L _ GHC.HsPar{}) -> e-      e@(L _ GHC.HsApp{}) -> genLoc $ GHC.Compat.hsPar e-      e@(L _ GHC.SectionL{}) -> genLoc $ GHC.Compat.hsPar e-      e@(L _ GHC.SectionR{}) -> genLoc $ GHC.Compat.hsPar e-      e -> e+  parens :: (IsPass p) => GHC.LHsExpr (GhcPass p) -> GHC.LHsExpr (GhcPass p)+  parens = \case+    e@(L _ GHC.HsPar{}) -> e+    e@(L _ GHC.HsApp{}) -> genLoc $ GHC.Compat.hsPar e+    e@(L _ GHC.SectionL{}) -> genLoc $ GHC.Compat.hsPar e+    e@(L _ GHC.SectionR{}) -> genLoc $ GHC.Compat.hsPar e+    e -> e  {----- FastString -----} @@ -625,9 +652,9 @@ compileRecFields ::   forall p m arg x.   (IsPass p, MonadCompile m (GhcPass p)) =>-  (x -> m arg)-  -> [(HsName (GhcPass p), x)]-  -> m (GHC.HsRecFields (GhcPass p) arg)+  (x -> m arg) ->+  [(HsName (GhcPass p), x)] ->+  m (GHC.HsRecFields (GhcPass p) arg) compileRecFields f fields = do   fields' <-     sequence@@ -644,27 +671,27 @@       | (field, x) <- fields       ]   pure $ GHC.Compat.mkHsRecFields fields'-  where-    compileFieldOcc field = do-      name <- compileHsName field-      pure $-        onPsOrRn @p-          GHC.FieldOcc-            { foExt = GHC.noExtField-            , foLabel = genLoc name-            }-          (GHC.Compat.fieldOccRn name)+ where+  compileFieldOcc field = do+    name <- compileHsName field+    pure $+      onPsOrRn @p+        GHC.FieldOcc+          { foExt = GHC.noExtField+          , foLabel = genLoc name+          }+        (GHC.Compat.fieldOccRn name)  genLocConLikeP ::   forall p.   (IsPass p) =>-  GHC.IdP (GhcPass p)-  -> GHC.XRec (GhcPass p) (GHC.ConLikeP (GhcPass p))-genLocConLikeP idp = onPsOrRn @p (genLoc idp) (genLoc idp)+  GHC.IdP (GhcPass p) ->+  GHC.XRec (GhcPass p) (GHC.ConLikeP (GhcPass p))+genLocConLikeP = onPsOrRn @p genLoc (genLoc . GHC.Compat.noUserRdr)  genLocIdP ::   forall p.   (IsPass p) =>-  GHC.IdP (GhcPass p)-  -> GHC.LIdP (GhcPass p)-genLocIdP idp = onPsOrRn @p (genLoc idp) (genLoc idp)+  GHC.IdP (GhcPass p) ->+  GHC.Compat.LIdOccP (GhcPass p)+genLocIdP = onPsOrRn @p genLoc (genLoc . GHC.Compat.noUserRdr)

@@ -8,4 +8,6 @@ import Skeletest.Internal.GHC.Compat_9_10 as X #elif __GLASGOW_HASKELL__ == 912 import Skeletest.Internal.GHC.Compat_9_12 as X+#elif __GLASGOW_HASKELL__ == 914+import Skeletest.Internal.GHC.Compat_9_14 as X #endif

@@ -6,10 +6,11 @@ ) where  import Data.Data (toConstr)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty import GHC hiding (FieldOcc (..), mkPrefixFunRhs) import GHC qualified import GHC.Types.Name.Reader (getRdrName)- import Skeletest.Internal.Error (invariantViolation)  hsLamSingle :: MatchGroup (GhcPass p) (LHsExpr (GhcPass p)) -> HsExpr (GhcPass p)@@ -57,6 +58,14 @@     , GHC.foLabel = genLoc $ getRdrName name     } +type LIdOccP a = GHC.LIdP a++noUserRdr :: Name -> Name+noUserRdr = id++unLocWithUserRdr :: GenLocated l Name -> Name+unLocWithUserRdr = unLoc+ hsApp :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p) hsApp = HsApp noExtField @@ -68,3 +77,9 @@  toMatchArgs :: [LPat p] -> [LPat p] toMatchArgs = id++toGrhssGRHSs :: NonEmpty (LGRHS p body) -> [LGRHS p body]+toGrhssGRHSs = NonEmpty.toList++mkPrefixCon :: [arg] -> HsConDetails tyargs arg rec+mkPrefixCon = PrefixCon []

@@ -7,10 +7,11 @@ ) where  import Data.Data (toConstr)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty import GHC hiding (FieldOcc (..)) import GHC qualified import GHC.Types.Name.Reader (getRdrName)- import Skeletest.Internal.Error (invariantViolation)  hsLamSingle :: MatchGroup (GhcPass p) (LHsExpr (GhcPass p)) -> HsExpr (GhcPass p)@@ -44,8 +45,8 @@ mkHsRecFields ::   forall p arg.   (IsPass p) =>-  [LHsRecField (GhcPass p) arg]-  -> HsRecFields (GhcPass p) arg+  [LHsRecField (GhcPass p) arg] ->+  HsRecFields (GhcPass p) arg mkHsRecFields fields =   GHC.HsRecFields     { rec_ext =@@ -67,6 +68,14 @@     , GHC.foLabel = genLoc name     } +type LIdOccP a = GHC.LIdP a++noUserRdr :: Name -> Name+noUserRdr = id++unLocWithUserRdr :: GenLocated l Name -> Name+unLocWithUserRdr = unLoc+ hsApp :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p) hsApp = HsApp noExtField @@ -75,3 +84,9 @@  toMatchArgs :: [LPat p] -> LocatedE [LPat p] toMatchArgs = genLoc++toGrhssGRHSs :: NonEmpty (LGRHS p body) -> [LGRHS p body]+toGrhssGRHSs = NonEmpty.toList++mkPrefixCon :: [arg] -> HsConDetails tyargs arg rec+mkPrefixCon = PrefixCon []

@@ -0,0 +1,93 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}++module Skeletest.Internal.GHC.Compat_9_14 (+  module Skeletest.Internal.GHC.Compat_9_14,+  mkPrefixFunRhs,+) where++import Data.Data (toConstr)+import Data.List.NonEmpty (NonEmpty)+import GHC hiding (FieldOcc (..))+import GHC qualified+import GHC.Types.Name.Reader (getRdrName)+import GHC.Types.Name.Reader qualified as GHC++import Skeletest.Internal.Error (invariantViolation)++hsLamSingle :: MatchGroup (GhcPass p) (LHsExpr (GhcPass p)) -> HsExpr (GhcPass p)+hsLamSingle = HsLam noAnn LamSingle++lamAltSingle :: HsMatchContext fn+lamAltSingle = LamAlt LamSingle++hsLit :: HsLit (GhcPass p) -> HsExpr (GhcPass p)+hsLit = HsLit noExtField++hsPar :: forall p. (IsPass p) => LHsExpr (GhcPass p) -> HsExpr (GhcPass p)+hsPar =+  HsPar $+    case ghcPass @p of+      GhcPs -> noAnn+      GhcRn -> noExtField+      GhcTc -> invariantViolation "hsPar called in GhcTc"++unHsPar :: HsExpr GhcRn -> LHsExpr GhcRn+unHsPar = \case+  HsPar _ e -> e+  e -> invariantViolation $ "unHsPar called on " <> (show . toConstr) e++hsTupPresent :: LHsExpr (GhcPass p) -> HsTupArg (GhcPass p)+hsTupPresent = Present noExtField++xMatch :: XCMatch (GhcPass p) b+xMatch = noExtField++mkHsRecFields ::+  forall p arg.+  (IsPass p) =>+  [LHsRecField (GhcPass p) arg] ->+  HsRecFields (GhcPass p) arg+mkHsRecFields fields =+  GHC.HsRecFields+    { rec_ext =+        case ghcPass @p of+          GhcPs -> noExtField+          GhcRn -> noExtField+          GhcTc -> invariantViolation "mkHsRecFields called in GhcTc"+    , rec_flds = fields+    , rec_dotdot = Nothing+    }++foLabel :: GHC.FieldOcc GhcRn -> LIdP GhcRn+foLabel = GHC.foLabel++fieldOccRn :: Name -> GHC.FieldOcc GhcRn+fieldOccRn name =+  GHC.FieldOcc+    { GHC.foExt = getRdrName name+    , GHC.foLabel = genLoc name+    }++type LIdOccP a = GHC.LIdOccP a++noUserRdr :: Name -> GHC.WithUserRdr Name+noUserRdr = GHC.noUserRdr++unLocWithUserRdr :: GenLocated l (GHC.WithUserRdr a) -> a+unLocWithUserRdr = GHC.unLocWithUserRdr++hsApp :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p)+hsApp = HsApp noExtField++genLoc :: (NoAnn ann) => e -> GenLocated ann e+genLoc = L noAnn++toMatchArgs :: [LPat p] -> LocatedE [LPat p]+toMatchArgs = genLoc++toGrhssGRHSs :: NonEmpty (LGRHS p body) -> NonEmpty (LGRHS p body)+toGrhssGRHSs = id++mkPrefixCon :: [arg] -> HsConDetails arg rec+mkPrefixCon = PrefixCon

@@ -5,11 +5,12 @@ ) where  import Data.Data (toConstr)+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NonEmpty import GHC hiding (FieldOcc (..), mkPrefixFunRhs) import GHC qualified import GHC.Types.Name.Reader (getRdrName) import GHC.Types.SrcLoc- import Skeletest.Internal.Error (invariantViolation)  hsLamSingle :: MatchGroup (GhcPass p) (LHsExpr (GhcPass p)) -> HsExpr (GhcPass p)@@ -52,6 +53,14 @@     , GHC.foLabel = genLoc $ getRdrName name     } +type LIdOccP a = GHC.LIdP a++noUserRdr :: Name -> Name+noUserRdr = id++unLocWithUserRdr :: GenLocated l Name -> Name+unLocWithUserRdr = unLoc+ hsApp :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p) hsApp = HsApp noAnn @@ -63,3 +72,9 @@  toMatchArgs :: [LPat p] -> [LPat p] toMatchArgs = id++toGrhssGRHSs :: NonEmpty (LGRHS p body) -> [LGRHS p body]+toGrhssGRHSs = NonEmpty.toList++mkPrefixCon :: [arg] -> HsConDetails tyargs arg rec+mkPrefixCon = PrefixCon []

@@ -11,11 +11,6 @@ import Data.Functor.Const (Const (..)) import Data.Maybe (fromMaybe, listToMaybe) import Data.Text qualified as Text--#if !MIN_VERSION_base(4, 20, 0)-import Data.Foldable (foldl')-#endif- import Skeletest.Internal.Constants (mainFileSpecsListIdentifier) import Skeletest.Internal.Error (skeletestPluginError) import Skeletest.Internal.GHC@@ -24,6 +19,10 @@ 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@@ -44,38 +43,38 @@ -- | Add 'main' function. transformMainModule :: ParsedModule -> ParsedModule transformMainModule modl = modl{moduleFuncs = (hsVarName "main", Just mainFun) : moduleFuncs modl}-  where-    findVar name =-      fmap hsExprVar . listToMaybe $-        [ funName-        | (funName, _) <- moduleFuncs modl-        , getHsName funName == name-        ]+ where+  findVar name =+    fmap hsExprVar . listToMaybe $+      [ funName+      | (funName, _) <- moduleFuncs modl+      , 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"+  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 =-            hsExprApps-              (hsExprVar $ hsName 'Main.runSkeletest)-              [ hsExprApps (hsExprVar (hsName '(:))) $-                  [ hsExprRecordCon-                      (hsName 'Plugin.Plugin)-                      [ (hsName 'Plugin.cliFlags, cliFlagsExpr)-                      , (hsName 'Plugin.snapshotRenderers, snapshotRenderersExpr)-                      , (hsName 'Plugin.hooks, hooksExpr)-                      ]-                  , pluginsExpr-                  ]-              , hsExprVar $ hsVarName mainFileSpecsListIdentifier-              ]-        }+  mainFun =+    FunDef+      { funType = HsTypeApps (HsTypeCon $ hsName ''IO) [HsTypeTuple []]+      , funPats = []+      , funBody =+          hsExprApps+            (hsExprVar $ hsName 'Main.runSkeletest)+            [ hsExprApps (hsExprVar (hsName '(:))) $+                [ hsExprRecordCon+                    (hsName 'Plugin.Plugin)+                    [ (hsName 'Plugin.cliFlags, cliFlagsExpr)+                    , (hsName 'Plugin.snapshotRenderers, snapshotRenderersExpr)+                    , (hsName 'Plugin.hooks, hooksExpr)+                    ]+                , pluginsExpr+                ]+            , hsExprVar $ hsVarName mainFileSpecsListIdentifier+            ]+      }  transformTestModule :: Ctx -> HsExpr GhcRn -> HsExpr GhcRn transformTestModule ctx =@@ -95,7 +94,7 @@ --       User x0 x1 -> Just (HCons (pure x0) $ HCons (pure x1) $ HNil) --       _ -> Nothing --   )---   (HCons (H.eq "user1") $ HCons (P.contains "@") $ HNil)+--   (HCons (P.eq "user1") $ HCons (P.contains "@") $ HNil) -- -- P.con User{name = P.eq "user1", email = P.contains "@"} -- ====>@@ -125,80 +124,80 @@     -- Check if P.con is by itself     HsExprVar name       | isCon name ->-          skeletestPluginError "P.con must be applied to a constructor"+          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 "P.con must be applied to exactly one argument"+          skeletestPluginError (getLoc e) "P.con must be applied to exactly one argument"     _ -> e-  where-    isCon = matchesName ctx (hsName 'P.con)+ where+  isCon = matchesName ctx (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 "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-          ]+  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 ..]+  -- 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)-          ]+  -- 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-          ]+  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+  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.@@ -213,6 +212,6 @@       | matchesName ctx (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]+ where+  inlineIsoChecker l r = hsExprApps (hsExprCon $ hsName 'P.IsoChecker) [mkFun l, mkFun r]+  mkFun f = hsExprApps (hsExprCon $ hsName 'P.Fun) [hsExprLitString $ renderHsExpr f, f]

@@ -88,11 +88,6 @@ import Debug.RecoverRTTI (anythingToString) import GHC.Generics ((:*:) (..)) import GHC.Stack qualified as GHC-import UnliftIO (MonadUnliftIO)-import UnliftIO.Exception (Exception, displayException, try)-import Prelude hiding (abs, all, and, any, elem, not, or, (&&), (||))-import Prelude qualified- import Skeletest.Internal.CLI (getFlag) import Skeletest.Internal.Error (invariantViolation) import Skeletest.Internal.Snapshot (@@ -110,6 +105,10 @@ import Skeletest.Internal.Utils.HList qualified as HList import Skeletest.Prop.Gen (Gen) import Skeletest.Prop.Internal (PropertyM, forAll)+import UnliftIO (MonadUnliftIO)+import UnliftIO.Exception (Exception, displayException, try)+import Prelude hiding (abs, all, and, any, elem, not, or, (&&), (||))+import Prelude qualified  data Predicate m a = Predicate   { predicateFunc :: a -> m PredicateFuncResult@@ -205,7 +204,7 @@ {----- General -----}  -- | A predicate that matches any value-anything :: (Monad m) => Predicate m a+anything :: forall a m. (Monad m) => Predicate m a anything =   Predicate     { predicateFunc = \_ ->@@ -258,48 +257,48 @@ -- >>> Just 1 `shouldSatisfy` P.just (P.gt 0) just :: (Monad m) => Predicate m a -> Predicate m (Maybe a) just p = conMatches "Just" fieldNames toFields preds-  where-    fieldNames = Nothing-    toFields = \case-      Just x -> Just . HCons (pure x) $ HNil-      _ -> Nothing-    preds = HCons p HNil+ where+  fieldNames = Nothing+  toFields = \case+    Just x -> Just . HCons (pure x) $ HNil+    _ -> Nothing+  preds = HCons p HNil  -- | A predicate checking if the input is Nothing -- -- >>> Nothing `shouldSatisfy` P.nothing nothing :: (Monad m) => Predicate m (Maybe a) nothing = conMatches "Nothing" fieldNames toFields preds-  where-    fieldNames = Nothing-    toFields = \case-      Nothing -> Just HNil-      _ -> Nothing-    preds = HNil+ where+  fieldNames = Nothing+  toFields = \case+    Nothing -> Just HNil+    _ -> Nothing+  preds = HNil  -- | A predicate checking if the input is Left, wrapping a value matching the given predicate. -- -- >>> Left 1 `shouldSatisfy` P.left (P.gt 0) left :: (Monad m) => Predicate m a -> Predicate m (Either a b) left p = conMatches "Left" fieldNames toFields preds-  where-    fieldNames = Nothing-    toFields = \case-      Left x -> Just . HCons (pure x) $ HNil-      _ -> Nothing-    preds = HCons p HNil+ where+  fieldNames = Nothing+  toFields = \case+    Left x -> Just . HCons (pure x) $ HNil+    _ -> Nothing+  preds = HCons p HNil  -- | A predicate checking if the input is Right, wrapping a value matching the given predicate. -- -- >>> Right 1 `shouldSatisfy` P.right (P.gt 0) right :: (Monad m) => Predicate m b -> Predicate m (Either a b) right p = conMatches "Right" fieldNames toFields preds-  where-    fieldNames = Nothing-    toFields = \case-      Right x -> Just . HCons (pure x) $ HNil-      _ -> Nothing-    preds = HCons p HNil+ where+  fieldNames = Nothing+  toFields = \case+    Right x -> Just . HCons (pure x) $ HNil+    _ -> Nothing+  preds = HCons p HNil  -- | A predicate checking if the input is a list matching exactly the given predicates. --@@ -324,10 +323,10 @@     , predicateDisp = disp     , predicateDispNeg = dispNeg     }-  where-    listify vals = "[" <> Text.intercalate ", " vals <> "]"-    disp = listify $ map predicateDisp predList-    dispNeg = "not " <> disp+ where+  listify vals = "[" <> Text.intercalate ", " vals <> "]"+  disp = listify $ map predicateDisp predList+  dispNeg = "not " <> disp  class IsTuple a where   type TupleArgs a :: [Type]@@ -379,11 +378,11 @@     , predicateDisp = disp     , predicateDispNeg = dispNeg     }-  where-    preds = toHListPred (Proxy @a) predTup-    tupify vals = "(" <> Text.intercalate ", " vals <> ")"-    disp = tupify $ HList.toListWith predicateDisp preds-    dispNeg = "not " <> disp+ where+  preds = toHListPred (Proxy @a) predTup+  tupify vals = "(" <> Text.intercalate ", " vals <> ")"+  disp = tupify $ HList.toListWith predicateDisp preds+  dispNeg = "not " <> disp  -- | A predicate checking if the input matches the given constructor. --@@ -395,6 +394,11 @@ -- -- Record fields that are omitted are not checked at all; i.e. -- @P.con Foo{}@ and @P.con Foo{a = P.anything}@ are equivalent.+--+-- Positional arguments work also, as well as dollar signs.+--+-- >>> let email = P.con $ Email P.anything (P.eq "example.com")+-- >>> user `shouldSatisfy` P.con User{email = email} con :: a -> Predicate m a con =   -- A placeholder that will be replaced with conMatches in the plugin.@@ -405,11 +409,11 @@ -- so it should not be written directly, only generated from `con`. conMatches ::   (Monad m) =>-  String-  -> Maybe (HList (Const String) fields)-  -> (a -> Maybe (HList Identity fields))-  -> HList (Predicate m) fields-  -> Predicate m a+  String ->+  Maybe (HList (Const String) fields) ->+  (a -> Maybe (HList Identity fields)) ->+  HList (Predicate m) fields ->+  Predicate m a conMatches conNameS mFieldNames deconstruct preds =   Predicate     { predicateFunc = \actual ->@@ -425,20 +429,20 @@     , predicateDisp = disp     , predicateDispNeg = dispNeg     }-  where-    conName = Text.pack conNameS-    disp = "matches " <> predsDisp-    dispNeg = "does not match " <> predsDisp-    predsDisp = consify $ HList.toListWith predicateDisp preds+ where+  conName = Text.pack conNameS+  disp = "matches " <> predsDisp+  dispNeg = "does not match " <> predsDisp+  predsDisp = consify $ HList.toListWith predicateDisp preds -    -- consify ["= 1", "anything"] => User{id = (= 1), name = anything}-    -- consify ["= 1", "anything"] => Foo (= 1) anything-    consify vals =-      case HList.uncheck <$> mFieldNames of-        Nothing -> Text.unwords $ conName : map parens vals-        Just fieldNames ->-          let fields = zipWith (\field v -> Text.pack field <> " = " <> parens v) fieldNames vals-           in conName <> "{" <> Text.intercalate ", " fields <> "}"+  -- consify ["= 1", "anything"] => User{id = (= 1), name = anything}+  -- consify ["= 1", "anything"] => Foo (= 1) anything+  consify vals =+    case HList.uncheck <$> mFieldNames of+      Nothing -> Text.unwords $ conName : map parens vals+      Just fieldNames ->+        let fields = zipWith (\field v -> Text.pack field <> " = " <> parens v) fieldNames vals+         in conName <> "{" <> Text.intercalate ", " fields <> "}"  {----- Numeric -----} @@ -457,17 +461,17 @@ approx Tolerance{..} =   mkPredicateOp "≈" "≉" $ \actual expected ->     Prelude.abs (actual - expected) <= getTolerance expected-  where-    mRelTol = fromTol <$> rel-    absTol = fromTol abs-    getTolerance expected =-      case mRelTol of-        Just relTol -> max (relTol * Prelude.abs expected) absTol-        Nothing -> absTol+ where+  mRelTol = fromTol <$> rel+  absTol = fromTol abs+  getTolerance expected =+    case mRelTol of+      Just relTol -> max (relTol * Prelude.abs expected) absTol+      Nothing -> absTol -    fromTol x-      | x < 0 = error $ "tolerance can't be negative: " <> show x-      | otherwise = fromRational x+  fromTol x+    | x < 0 = error $ "tolerance can't be negative: " <> show x+    | otherwise = fromRational x  -- | The tolerance to use in 'approx'. --@@ -541,9 +545,9 @@     , predicateDisp = andify predList     , predicateDispNeg = "At least one failure:\n" <> andify predList     }-  where-    andify = Text.intercalate "\nand "-    predList = map (parens . predicateDisp) preds+ where+  andify = Text.intercalate "\nand "+  predList = map (parens . predicateDisp) preds  -- | A predicate checking if the input matches any of the given predicates --@@ -556,9 +560,9 @@     , predicateDisp = orify predList     , predicateDispNeg = "All failures:\n" <> orify predList     }-  where-    orify = Text.intercalate "\nor "-    predList = map (parens . predicateDisp) preds+ where+  orify = Text.intercalate "\nor "+  predList = map (parens . predicateDisp) preds  {----- Containers -----} @@ -629,9 +633,9 @@     , predicateDisp = disp     , predicateDispNeg = dispNeg     }-  where-    disp = "has prefix " <> render prefix-    dispNeg = "does not have prefix " <> render prefix+ where+  disp = "has prefix " <> render prefix+  dispNeg = "does not have prefix " <> render prefix  -- | A predicate checking if the input contains the given subsequence --@@ -654,9 +658,9 @@     , predicateDisp = disp     , predicateDispNeg = dispNeg     }-  where-    disp = "has infix " <> render elems-    dispNeg = "does not have infix " <> render elems+ where+  disp = "has infix " <> render elems+  dispNeg = "does not have infix " <> render elems  -- | A predicate checking if the input has the given suffix --@@ -679,9 +683,9 @@     , predicateDisp = disp     , predicateDispNeg = dispNeg     }-  where-    disp = "has suffix " <> render suffix-    dispNeg = "does not have suffix " <> render suffix+ where+  disp = "has suffix " <> render suffix+  dispNeg = "does not have suffix " <> render suffix  {----- IO -----} @@ -753,9 +757,9 @@     , predicateDisp = disp     , predicateDispNeg = dispNeg     }-  where-    disp = "throws (" <> predicateDisp <> ")"-    dispNeg = "does not throw (" <> predicateDisp <> ")"+ where+  disp = "throws (" <> predicateDisp <> ")"+  dispNeg = "does not throw (" <> predicateDisp <> ")"  {----- Functions -----} @@ -766,7 +770,7 @@ -- -- @ -- prop "reverse . reverse === id" $ do---   let genList = Gen.list (Gen.linear 0 10) $ Gen.int (Gen.linear 0 1000)+--   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@@ -803,9 +807,9 @@     , predicateDisp = disp     , predicateDispNeg = dispNeg     }-  where-    disp = "isomorphic"-    dispNeg = "not isomorphic"+ where+  disp = "isomorphic"+  dispNeg = "not isomorphic"  {----- Snapshot -----} @@ -855,15 +859,15 @@  mkPredicateOp ::   (Monad m) =>-  Text-  -- ^ operator-  -> Text-  -- ^ negative operator-  -> (a -> a -> Bool)-  -- ^ actual -> expected -> success-  -> a-  -- ^ expected-  -> Predicate m a+  -- | operator+  Text ->+  -- | negative operator+  Text ->+  -- | actual -> expected -> success+  (a -> a -> Bool) ->+  -- | expected+  a ->+  Predicate m a mkPredicateOp op negOp f expected =   Predicate     { predicateFunc = \actual -> do@@ -880,15 +884,15 @@     , predicateDisp = disp     , predicateDispNeg = dispNeg     }-  where-    disp = op <> " " <> render expected-    dispNeg = negOp <> " " <> render expected+ where+  disp = op <> " " <> render expected+  dispNeg = negOp <> " " <> render expected  runPredicates :: (Monad m) => HList (Predicate m) xs -> HList Identity xs -> m [PredicateFuncResult] runPredicates preds = HList.toListWithM run . HList.hzip preds-  where-    run :: (Predicate m :*: Identity) a -> m PredicateFuncResult-    run (p :*: Identity x) = predicateFunc p x+ where+  run :: (Predicate m :*: Identity) a -> m PredicateFuncResult+  run (p :*: Identity x) = predicateFunc p x  verifyAll :: ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult verifyAll mergeMessages results =@@ -900,8 +904,8 @@           Nothing -> mergeMessages $ map predicateExplain results     , predicateShowFailCtx = showMergedCtxs results     }-  where-    firstFailure = listToMaybe $ filter (Prelude.not . predicateSuccess) results+ where+  firstFailure = listToMaybe $ filter (Prelude.not . predicateSuccess) results  verifyAny :: ([Text] -> Text) -> [PredicateFuncResult] -> PredicateFuncResult verifyAny mergeMessages results =@@ -913,8 +917,8 @@           Nothing -> mergeMessages $ map predicateExplain results     , predicateShowFailCtx = showMergedCtxs results     }-  where-    firstSuccess = listToMaybe $ filter predicateSuccess results+ where+  firstSuccess = listToMaybe $ filter predicateSuccess results  render :: a -> Text render = Text.pack . anythingToString

@@ -10,13 +10,12 @@ import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Text qualified as Text+import Skeletest.Internal.Constants (mainFileSpecsListIdentifier)+import Skeletest.Internal.Error (SkeletestError (..)) import System.Directory (doesDirectoryExist, listDirectory) import System.FilePath (makeRelative, splitExtensions, takeDirectory, (</>)) import UnliftIO.Exception (throwIO) -import Skeletest.Internal.Constants (mainFileSpecsListIdentifier)-import Skeletest.Internal.Error (SkeletestError (..))- -- | Preprocess the given Haskell file. See Main.hs processFile :: FilePath -> Text -> IO Text processFile path file = do@@ -25,14 +24,14 @@     . addLine pluginPragma     . addLine linePragma     $ file'-  where-    addLine line f = line <> "\n" <> f-    quoted s = "\"" <> s <> "\""+ where+  addLine line f = line <> "\n" <> f+  quoted s = "\"" <> s <> "\"" -    pluginPragma = "{-# OPTIONS_GHC -fplugin=Skeletest.Internal.Plugin #-}"-    linePragma =-      -- this is needed to tell GHC to use original path in error messages-      "{-# LINE 1 " <> quoted (Text.pack path) <> " #-}"+  pluginPragma = "{-# OPTIONS_GHC -fplugin=Skeletest.Internal.Plugin #-}"+  linePragma =+    -- this is needed to tell GHC to use original path in error messages+    "{-# LINE 1 " <> quoted (Text.pack path) <> " #-}"  isMain :: Text -> Bool isMain file =@@ -43,11 +42,11 @@     [] -> True     -- something else? just silently ignore it     _ -> False-  where-    getModuleName s =-      case Text.words s of-        "module" : name : _ -> Just name-        _ -> Nothing+ where+  getModuleName s =+    case Text.words s of+      "module" : name : _ -> Just name+      _ -> Nothing  updateMainFile :: FilePath -> Text -> IO Text updateMainFile path file = do@@ -63,67 +62,67 @@ -- ["My.Module.Test1", "My.Module.Test2", ...] findTestModules :: FilePath -> IO [(FilePath, Text)] findTestModules path = mapMaybe toTestModule <$> listDirectoryRecursive testDir-  where-    testDir = takeDirectory path+ where+  testDir = takeDirectory path -    toTestModule fp = do-      guard (fp /= path)-      (fpNoExt, ".hs") <- pure $ splitExtensions fp-      guard ("Spec" `Text.isSuffixOf` Text.pack fpNoExt)-      name <- moduleNameFromPath $ Text.pack $ makeRelative testDir fpNoExt-      pure (fp, name)+  toTestModule fp = do+    guard (fp /= path)+    (fpNoExt, ".hs") <- pure $ splitExtensions fp+    guard ("Spec" `Text.isSuffixOf` Text.pack fpNoExt)+    name <- moduleNameFromPath $ Text.pack $ makeRelative testDir fpNoExt+    pure (fp, name) -    moduleNameFromPath = fmap (Text.intercalate ".") . mapM validateModuleName . Text.splitOn "/"+  moduleNameFromPath = fmap (Text.intercalate ".") . mapM validateModuleName . Text.splitOn "/" -    -- https://www.haskell.org/onlinereport/syntax-iso.html-    -- large { small | large | digit | ' }-    validateModuleName name = do-      (first, rest) <- Text.uncons name-      guard $ isUpper first-      guard $ Text.all (\c -> isUpper c || isLower c || isDigit c || c == '\'') rest-      pure name+  -- https://www.haskell.org/onlinereport/syntax-iso.html+  -- large { small | large | digit | ' }+  validateModuleName name = do+    (first, rest) <- Text.uncons name+    guard $ isUpper first+    guard $ Text.all (\c -> isUpper c || isLower c || isDigit c || c == '\'') rest+    pure name  addSpecsList :: [(FilePath, Text)] -> Text -> Text addSpecsList testModules file =   Text.unlines     [ file-    , mainFileSpecsListIdentifier <> " :: [(FilePath, String, Spec)]"+    , mainFileSpecsListIdentifier <> " :: [(FilePath, Spec)]"     , mainFileSpecsListIdentifier <> " = " <> renderSpecList specsList     ]-  where-    specsList =-      [ (quote $ Text.pack fp, quote modName, modName <> ".spec")-      | (fp, modName) <- testModules-      ]-    quote s = "\"" <> s <> "\""-    renderSpecList xs = "[" <> (Text.intercalate ", " . map renderSpecInfo) xs <> "]"-    renderSpecInfo (fp, name, spec) = "(" <> fp <> ", " <> name <> ", " <> spec <> ")"+ where+  specsList =+    [ (quote $ Text.pack fp, modName <> ".spec")+    | (fp, modName) <- testModules+    ]+  quote s = "\"" <> s <> "\""+  renderSpecList xs = "[" <> (Text.intercalate ", " . map renderSpecInfo) xs <> "]"+  renderSpecInfo (fp, spec) = "(" <> fp <> ", " <> spec <> ")"  -- | Add imports after the Skeletest.Main import, which should always be present in the Main module. insertImports :: [(FilePath, Text)] -> Text -> Either SkeletestError Text insertImports testModules file =   let (pre, post) = break isSkeletestImport $ Text.lines file    in if null post-        then Left $ CompilationError "Could not find Skeletest.Main import in Main module"+        then Left $ CompilationError Nothing "Could not find Skeletest.Main import in Main module"         else pure . Text.unlines $ pre <> importTests <> post-  where-    isSkeletestImport line =-      case Text.words line of-        "import" : "Skeletest.Main" : _ -> True-        _ -> False+ where+  isSkeletestImport line =+    case Text.words line of+      "import" : "Skeletest.Main" : _ -> True+      _ -> False -    importTests =-      [ "import qualified " <> name-      | (_, name) <- testModules-      ]+  importTests =+    [ "import qualified " <> name+    | (_, name) <- testModules+    ]  {----- Helpers -----}  listDirectoryRecursive :: FilePath -> IO [FilePath] listDirectoryRecursive fp = fmap (sort . concat) . mapM (go . (fp </>)) =<< listDirectory fp-  where-    go child = do-      isDir <- doesDirectoryExist child-      if isDir-        then listDirectoryRecursive child-        else pure [child]+ where+  go child = do+    isDir <- doesDirectoryExist child+    if isDir+      then listDirectoryRecursive child+      else pure [child]

@@ -49,6 +49,17 @@ 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.Fixtures (+  Fixture (..),+  FixtureScope (..),+  getFixture,+  noCleanup,+  withCleanup,+ )+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 System.IO.Error (isDoesNotExistError)@@ -63,18 +74,6 @@   writeIORef,  ) -import Skeletest.Internal.CLI (FlagSpec (..), IsFlag (..))-import Skeletest.Internal.Error (SkeletestError (..), invariantViolation)-import Skeletest.Internal.Fixtures (-  Fixture (..),-  FixtureScope (..),-  getFixture,-  noCleanup,-  withCleanup,- )-import Skeletest.Internal.TestInfo (TestInfo (..), getTestInfo)-import Skeletest.Internal.Utils.Map qualified as Map.Utils- {----- Infrastructure -----}  data SnapshotTestFixture = SnapshotTestFixture@@ -141,38 +140,38 @@ updateSnapshot snapshotContext testResult = do   SnapshotFileFixture{snapshotFileRef} <- getFixture   modifyIORef' snapshotFileRef (Just . setSnapshot . fromMaybe emptySnapshotFile)-  where-    SnapshotContext-      { snapshotRenderers = renderers-      , snapshotTestInfo = testInfo@TestInfo{testModule}-      , snapshotIndex-      } = snapshotContext+ where+  SnapshotContext+    { snapshotRenderers = renderers+    , snapshotTestInfo = testInfo@TestInfo{testFile}+    , snapshotIndex+    } = snapshotContext -    emptySnapshotFile =-      SnapshotFile-        { moduleName = testModule-        , snapshots = Map.empty-        }+  emptySnapshotFile =+    SnapshotFile+      { testFile = Text.pack testFile+      , 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}+  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}+  -- 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 SnapshotResult   = SnapshotMissing@@ -200,27 +199,27 @@       if snapshotContent == renderedTestResult         then SnapshotMatches         else SnapshotDiff{snapshotContent, renderedTestResult}-  where-    SnapshotContext-      { snapshotRenderers = renderers-      , snapshotTestInfo = testInfo-      , snapshotIndex-      } = snapshotContext+ where+  SnapshotContext+    { snapshotRenderers = renderers+    , snapshotTestInfo = testInfo+    , snapshotIndex+    } = snapshotContext -    returnE = throwE-    renderedTestResultVal = renderVal renderers testResult+  returnE = throwE+  renderedTestResultVal = renderVal renderers testResult -    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+  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  {----- Snapshot file -----}  data SnapshotFile = SnapshotFile-  { moduleName :: Text+  { testFile :: Text   , snapshots :: Map TestIdentifier [SnapshotValue]   -- ^ full test identifier => snapshots   -- e.g. ["group1", "group2", "returns val1 and val2"] => ["val1", "val2"]@@ -240,99 +239,99 @@  getSnapshotPath :: FilePath -> FilePath getSnapshotPath testFile = testDir </> "__snapshots__" </> snapshotFileName-  where-    (testDir, testFileName) = splitFileName testFile-    snapshotFileName = replaceExtension testFileName ".snap.md"+ where+  (testDir, testFileName) = splitFileName testFile+  snapshotFileName = replaceExtension testFileName ".snap.md"  toTestIdentifier :: TestInfo -> TestIdentifier toTestIdentifier TestInfo{testContexts, testName} = testContexts <> [testName]  decodeSnapshotFile :: Text -> Maybe SnapshotFile decodeSnapshotFile = parseFile . Text.lines-  where-    parseFile = \case-      line : rest-        | Just moduleName <- Text.stripPrefix "# " line -> do-            let snapshotFile =-                  SnapshotFile-                    { moduleName = Text.strip moduleName-                    , snapshots = Map.empty-                    }-            parseSections snapshotFile Nothing rest-      _ -> 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-      -> Maybe SnapshotFile-    parseSections snapshotFile@SnapshotFile{snapshots} 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}-            parseSections snapshotFile' (Just testIdentifier) rest-        -- found the beginning of a snapshot-        | Just lang <- (Text.stripPrefix "```" . Text.strip) line -> do-            testIdentifier <- mTest-            (snapshot, rest') <- parseSnapshot [] rest-            let-              snapshotVal =-                SnapshotValue-                  { snapshotContent = snapshot-                  , snapshotLang = if Text.null lang then Nothing else Just lang+ where+  parseFile = \case+    line : rest+      | Just testFile <- Text.stripPrefix "# " line -> do+          let snapshotFile =+                SnapshotFile+                  { testFile = Text.strip testFile+                  , snapshots = Map.empty                   }-              snapshotFile' = snapshotFile{snapshots = Map.adjust (<> [snapshotVal]) testIdentifier snapshots}-            parseSections snapshotFile' mTest rest'-        -- anything else is invalid-        | otherwise -> Nothing+          parseSections snapshotFile Nothing rest+    _ -> Nothing -    parseSnapshot snapshot = \case-      [] -> Nothing-      line : rest-        | "```" <- Text.strip line -> pure (Text.unlines snapshot, rest)-        | otherwise -> parseSnapshot (snapshot <> [line]) rest+  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+    Maybe SnapshotFile+  parseSections snapshotFile@SnapshotFile{snapshots} 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}+          parseSections snapshotFile' (Just testIdentifier) rest+      -- found the beginning of a snapshot+      | Just lang <- (Text.stripPrefix "```" . Text.strip) line -> do+          testIdentifier <- mTest+          (snapshot, rest') <- parseSnapshot [] rest+          let+            snapshotVal =+              SnapshotValue+                { snapshotContent = snapshot+                , snapshotLang = if Text.null lang then Nothing else Just lang+                }+            snapshotFile' = snapshotFile{snapshots = Map.adjust (<> [snapshotVal]) testIdentifier snapshots}+          parseSections snapshotFile' mTest rest'+      -- anything else is invalid+      | otherwise -> Nothing +  parseSnapshot snapshot = \case+    [] -> Nothing+    line : rest+      | "```" <- Text.strip line -> pure (Text.unlines snapshot, rest)+      | otherwise -> parseSnapshot (snapshot <> [line]) rest+ encodeSnapshotFile :: SnapshotFile -> Text encodeSnapshotFile SnapshotFile{..} =   Text.intercalate "\n" $-    h1 moduleName : concatMap toSection (Map.toList snapshots)-  where-    toSection (testIdentifier, snaps) =-      h2 (Text.intercalate " / " testIdentifier) : map codeBlock snaps+    h1 testFile : concatMap toSection (Map.toList snapshots)+ where+  toSection (testIdentifier, snaps) =+    h2 (Text.intercalate " / " testIdentifier) : map codeBlock snaps -    h1 s = "# " <> s <> "\n"-    h2 s = "## " <> s <> "\n"-    codeBlock SnapshotValue{..} =-      Text.concat-        [ "```" <> fromMaybe "" snapshotLang <> "\n"-        , snapshotContent-        , "```\n"-        ]+  h1 s = "# " <> s <> "\n"+  h2 s = "## " <> s <> "\n"+  codeBlock SnapshotValue{..} =+    Text.concat+      [ "```" <> fromMaybe "" snapshotLang <> "\n"+      , snapshotContent+      , "```\n"+      ]  normalizeSnapshotFile :: SnapshotFile -> SnapshotFile normalizeSnapshotFile file@SnapshotFile{snapshots} =   file     { snapshots = Map.fromList . map normalize . Map.toList $ snapshots     }-  where-    normalize (testIdentifier, vals) =-      ( map (sanitizeNonPrint . sanitizeSlashes . Text.strip) testIdentifier-      , map normalizeSnapshotVal vals-      )+ where+  normalize (testIdentifier, vals) =+    ( map (sanitizeNonPrint . sanitizeSlashes . Text.strip) testIdentifier+    , map normalizeSnapshotVal vals+    ) -    sanitizeSlashes = Text.replace " /" " \\/"+  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+  sanitizeNonPrint = Text.concatMap $ \case+    c | (not . isPrint) c -> Text.drop 1 . Text.dropEnd 1 . Text.pack . show $ c+    c -> Text.singleton c  {----- Renderers -----} @@ -360,12 +359,12 @@   , plainRenderer @Text id   , jsonRenderer   ]-  where-    jsonRenderer =-      SnapshotRenderer-        { render = TextL.toStrict . TextL.decodeUtf8 . Aeson.encodePretty @Aeson.Value-        , snapshotLang = Just "json"-        }+ where+  jsonRenderer =+    SnapshotRenderer+      { render = TextL.toStrict . TextL.decodeUtf8 . Aeson.encodePretty @Aeson.Value+      , snapshotLang = Just "json"+      }  renderVal :: (Typeable a) => [SnapshotRenderer] -> a -> SnapshotValue renderVal renderers a =@@ -377,10 +376,10 @@           , snapshotLang = Nothing           }       rendered : _ -> rendered-  where-    tryRender SnapshotRenderer{..} =-      let toValue v = SnapshotValue{snapshotContent = render v, snapshotLang}-       in toValue <$> Typeable.cast a+ where+  tryRender SnapshotRenderer{..} =+    let toValue v = SnapshotValue{snapshotContent = render v, snapshotLang}+     in toValue <$> Typeable.cast a  normalizeSnapshotVal :: SnapshotValue -> SnapshotValue normalizeSnapshotVal SnapshotValue{..} =@@ -388,13 +387,13 @@     { snapshotContent = normalizeTrailingNewlines snapshotContent     , snapshotLang = collapse $ Text.filter isAlpha <$> snapshotLang     }-  where-    collapse = \case-      Just "" -> Nothing-      m -> m+ where+  collapse = \case+    Just "" -> Nothing+    m -> m -    -- Ensure there's exactly one trailing newline.-    normalizeTrailingNewlines s = Text.dropWhileEnd (== '\n') s <> "\n"+  -- Ensure there's exactly one trailing newline.+  normalizeTrailingNewlines s = Text.dropWhileEnd (== '\n') s <> "\n"  snapshotRenderersRef :: IORef [SnapshotRenderer] snapshotRenderersRef = unsafePerformIO $ newIORef []

@@ -41,13 +41,8 @@ import Data.Text (Text) import Data.Text qualified as Text import Data.Text.IO qualified as Text-import UnliftIO.Exception (-  finally,-  fromException,-  try,- )- import Skeletest.Assertions (Testable, runTestable)+import Skeletest.Internal.Capture (addCapturedOutput, withCaptureOutput) import Skeletest.Internal.Fixtures (FixtureScopeKey (..), cleanupFixtures) import Skeletest.Internal.Markers (   AnonMarker (..),@@ -65,9 +60,16 @@  ) import Skeletest.Internal.TestTargets (TestTarget, TestTargets, matchesTest) import Skeletest.Internal.TestTargets qualified as TestTargets+import Skeletest.Internal.Utils.BoxDrawing (drawBox) import Skeletest.Internal.Utils.Color qualified as Color import Skeletest.Plugin (Hooks (..), defaultHooks) import Skeletest.Prop.Internal (Property)+import System.IO qualified as IO+import UnliftIO.Exception (+  finally,+  fromException,+  try,+ )  type Spec = Spec' () @@ -106,22 +108,22 @@ traverseSpecTrees ::   forall m.   (Monad m) =>-  ( (SpecTree -> m SpecTree)-    -> [SpecTree]-    -> m [SpecTree]-  )-  -> Spec-  -> m Spec+  ( (SpecTree -> m SpecTree) ->+    [SpecTree] ->+    m [SpecTree]+  ) ->+  Spec ->+  m Spec traverseSpecTrees f = withSpecTrees go-  where-    go :: [SpecTree] -> m [SpecTree]-    go = f recurseGroups+ where+  go :: [SpecTree] -> m [SpecTree]+  go = f recurseGroups -    recurseGroups = \case-      group@SpecGroup{} -> do-        trees' <- go $ groupTrees group-        pure group{groupTrees = trees'}-      stest@SpecTest{} -> pure stest+  recurseGroups = \case+    group@SpecGroup{} -> do+      trees' <- go $ groupTrees group+      pure group{groupTrees = trees'}+    stest@SpecTest{} -> pure stest  -- | Map the tree with the given processing function. --@@ -129,12 +131,12 @@ -- -- >>> mapSpecTrees (\go -> post . map go . pre) spec mapSpecTrees ::-  ( (SpecTree -> SpecTree)-    -> [SpecTree]-    -> [SpecTree]-  )-  -> Spec-  -> Spec+  ( (SpecTree -> SpecTree) ->+    [SpecTree] ->+    [SpecTree]+  ) ->+  Spec ->+  Spec mapSpecTrees f = runIdentity . traverseSpecTrees (\go -> pure . f (runIdentity . go))  {----- Execute spec -----}@@ -147,58 +149,58 @@       (`finally` cleanupFixtures (PerFileFixtureKey specPath)) $ do         let emptyTestInfo =               TestInfo-                { testModule = specName-                , testContexts = []+                { testContexts = []                 , testName = ""                 , testMarkers = []                 , testFile = specPath                 }-        Text.putStrLn specName+        Text.putStrLn $ Text.pack specPath         runTrees emptyTestInfo $ getSpecTrees specSpec-  where-    Hooks{..} = builtinHooks <> hooks0-    builtinHooks = xfailHook <> skipHook--    runTrees baseTestInfo = fmap and . mapM (runTree baseTestInfo)-    runTree baseTestInfo = \case-      SpecGroup{..} -> do-        let lvl = getIndentLevel baseTestInfo-        Text.putStrLn $ indent lvl groupLabel-        runTrees baseTestInfo{TestInfo.testContexts = TestInfo.testContexts baseTestInfo <> [groupLabel]} groupTrees-      SpecTest{..} -> do-        let lvl = getIndentLevel baseTestInfo-        Text.putStr $ indent lvl (testName <> ": ")+ where+  Hooks{..} = builtinHooks <> hooks0+  builtinHooks = xfailHook <> skipHook -        let testInfo =-              baseTestInfo-                { TestInfo.testName = testName-                , TestInfo.testMarkers = testMarkers-                }-        TestResult{..} <--          withTestInfo testInfo $ do-            tid <- myThreadId-            runTest testInfo testAction `finally` cleanupFixtures (PerTestFixtureKey tid)+  runTrees baseTestInfo = fmap and . mapM (runTree baseTestInfo)+  runTree baseTestInfo = \case+    SpecGroup{..} -> do+      let lvl = getIndentLevel baseTestInfo+      Text.putStrLn $ indent lvl groupLabel+      runTrees baseTestInfo{TestInfo.testContexts = TestInfo.testContexts baseTestInfo <> [groupLabel]} groupTrees+    SpecTest{..} -> do+      let lvl = getIndentLevel baseTestInfo+      Text.putStr $ indent lvl (testName <> ": ")+      IO.hFlush IO.stdout -        Text.putStrLn testResultLabel-        case testResultMessage of-          TestResultMessageNone -> pure ()-          TestResultMessageInline msg -> Text.putStrLn $ indent (lvl + 1) msg-          TestResultMessageSection msg -> Text.putStrLn $ withBorder msg-        pure testResultSuccess+      let testInfo =+            baseTestInfo+              { TestInfo.testName = testName+              , TestInfo.testMarkers = testMarkers+              }+      TestResult{..} <-+        withTestInfo testInfo $ do+          tid <- myThreadId+          runTest testInfo testAction `finally` cleanupFixtures (PerTestFixtureKey tid) -    runTest info action =-      hookRunTest info $ do-        try action >>= \case-          Right result -> pure result-          Left e-            | Just e' <- fromException e -> testResultFromAssertionFail e'-            | otherwise -> pure $ testResultFromError e+      Text.putStrLn testResultLabel+      case testResultMessage of+        TestResultMessageNone -> pure ()+        TestResultMessageInline msg -> Text.putStrLn $ indent (lvl + 1) msg+        TestResultMessageSection box -> drawBox box >>= Text.putStrLn+      pure testResultSuccess -    getIndentLevel testInfo = length (TestInfo.testContexts testInfo) + 1 -- +1 to include the module name-    indent lvl = Text.intercalate "\n" . map (Text.replicate (lvl * 4) " " <>) . Text.splitOn "\n"+  runTest info action =+    hookRunTest 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 -    border = Text.replicate 80 "-"-    withBorder msg = Text.intercalate "\n" [border, msg, border]+  getIndentLevel testInfo = length (TestInfo.testContexts testInfo) + 1 -- +1 to include the module name+  indent lvl = Text.intercalate "\n" . map (Text.replicate (lvl * 4) " " <>) . Text.splitOn "\n"  {----- Entrypoint -----} @@ -206,7 +208,6 @@  data SpecInfo = SpecInfo   { specPath :: FilePath-  , specName :: Text   , specSpec :: Spec   } @@ -215,10 +216,10 @@   let spec = mapSpecTrees (\go -> filter (not . isEmptySpec) . map go) (specSpec info)   guard $ (not . null . getSpecTrees) spec   pure info{specSpec = spec}-  where-    isEmptySpec = \case-      SpecGroup _ [] -> True-      _ -> False+ where+  isEmptySpec = \case+    SpecGroup _ [] -> True+    _ -> False  -- TODO: make hookable? implement manual tests with hook? applyTestSelections :: TestTargets -> SpecRegistry -> SpecRegistry@@ -226,55 +227,55 @@   Just selections -> map (applyTestSelections' selections)   -- if no selections are specified, hide manual tests   Nothing -> map (\info -> info{specSpec = hideManualTests $ specSpec info})-  where-    hideManualTests = mapSpecTrees (\go -> filter (not . isManualTest) . map go)-    isManualTest = \case-      SpecGroup{} -> False-      SpecTest{testMarkers} -> isJust $ findMarker @MarkerManual testMarkers+ where+  hideManualTests = mapSpecTrees (\go -> filter (not . isManualTest) . map go)+  isManualTest = \case+    SpecGroup{} -> False+    SpecTest{testMarkers} -> isJust $ findMarker @MarkerManual testMarkers  applyTestSelections' :: TestTarget -> SpecInfo -> SpecInfo applyTestSelections' selections info = info{specSpec = applySelections $ specSpec info}-  where-    applySelections = (`Trans.runReader` []) . traverseSpecTrees apply+ where+  applySelections = (`Trans.runReader` []) . traverseSpecTrees apply -    apply go = mapMaybeM $ \case-      group@SpecGroup{groupLabel} -> Just <$> Trans.local (<> [groupLabel]) (go group)-      stest@SpecTest{testName, testMarkers} -> do-        groups <- Trans.ask-        let attrs =-              TestTargets.TestAttrs-                { testPath = specPath info-                , testIdentifier = groups <> [testName]-                , testMarkers = [Text.pack $ getMarkerName m | SomeMarker m <- testMarkers]-                }-        pure $-          if matchesTest selections attrs-            then Just stest-            else Nothing+  apply go = mapMaybeM $ \case+    group@SpecGroup{groupLabel} -> Just <$> Trans.local (<> [groupLabel]) (go group)+    stest@SpecTest{testName, testMarkers} -> do+      groups <- Trans.ask+      let attrs =+            TestTargets.TestAttrs+              { testPath = specPath info+              , testIdentifier = groups <> [testName]+              , testMarkers = [Text.pack $ getMarkerName m | SomeMarker m <- testMarkers]+              }+      pure $+        if matchesTest selections attrs+          then Just stest+          else Nothing -    mapMaybeM f = fmap catMaybes . mapM f+  mapMaybeM f = fmap catMaybes . mapM f  {----- Defining a Spec -----}  -- | The entity or concept being tested. describe :: String -> Spec -> Spec describe name = runIdentity . withSpecTrees (pure . (: []) . mkGroup)-  where-    mkGroup trees =-      SpecGroup-        { groupLabel = Text.pack name-        , groupTrees = trees-        }+ where+  mkGroup trees =+    SpecGroup+      { groupLabel = Text.pack name+      , groupTrees = trees+      }  test :: (Testable m) => String -> m () -> Spec test name t = Spec $ tell [mkTest]-  where-    mkTest =-      SpecTest-        { testName = Text.pack name-        , testMarkers = []-        , testAction = runTestable t-        }+ where+  mkTest =+    SpecTest+      { testName = Text.pack name+      , testMarkers = []+      , testAction = runTestable t+      }  -- | Define an IO-based test. --@@ -317,21 +318,21 @@           Just (MarkerXFail reason) -> modify reason <$> runTest           Nothing -> runTest     }-  where-    modify reason TestResult{..} =-      if testResultSuccess-        then-          TestResult-            { testResultSuccess = False-            , testResultLabel = Color.red "XPASS"-            , testResultMessage = TestResultMessageInline reason-            }-        else-          TestResult-            { testResultSuccess = True-            , testResultLabel = Color.yellow "XFAIL"-            , testResultMessage = TestResultMessageInline reason-            }+ where+  modify reason TestResult{..} =+    if testResultSuccess+      then+        TestResult+          { testResultSuccess = False+          , testResultLabel = Color.red "XPASS"+          , testResultMessage = TestResultMessageInline reason+          }+      else+        TestResult+          { testResultSuccess = True+          , testResultLabel = Color.yellow "XFAIL"+          , testResultMessage = TestResultMessageInline reason+          }  -- | Skip all tests in the given spec. --@@ -383,11 +384,11 @@ -- Useful for selecting tests from the command line or identifying tests in hooks withMarker :: (IsMarker a) => a -> Spec -> Spec withMarker m = mapSpecTrees (\go -> map (addMarker . go))-  where-    marker = SomeMarker m-    addMarker = \case-      group@SpecGroup{} -> group-      tree@SpecTest{} -> tree{testMarkers = marker : testMarkers tree}+ where+  marker = SomeMarker m+  addMarker = \case+    group@SpecGroup{} -> group+    tree@SpecTest{} -> tree{testMarkers = marker : testMarkers tree}  -- | Adds the given names as plain markers to all tests in the given spec. --

@@ -11,18 +11,16 @@ import Data.Map (Map) import Data.Map qualified as Map import Data.Text (Text)+import Skeletest.Internal.Error (invariantViolation)+import Skeletest.Internal.Markers (SomeMarker) import System.IO.Unsafe (unsafePerformIO) import UnliftIO (MonadUnliftIO) import UnliftIO.Concurrent (ThreadId, myThreadId) import UnliftIO.Exception (bracket_) import UnliftIO.IORef (IORef, modifyIORef, newIORef, readIORef) -import Skeletest.Internal.Error (invariantViolation)-import Skeletest.Internal.Markers (SomeMarker)- data TestInfo = TestInfo-  { testModule :: Text-  , testContexts :: [Text]+  { testContexts :: [Text]   , testName :: Text   , testMarkers :: [SomeMarker]   , testFile :: FilePath@@ -40,9 +38,9 @@ withTestInfo info m = do   tid <- myThreadId   bracket_ (set tid) (unset tid) m-  where-    set tid = modifyIORef testInfoMapRef $ Map.insert tid info-    unset tid = modifyIORef testInfoMapRef $ Map.delete tid+ where+  set tid = modifyIORef testInfoMapRef $ Map.insert tid info+  unset tid = modifyIORef testInfoMapRef $ Map.delete tid  lookupTestInfo :: (MonadIO m) => m (Maybe TestInfo) lookupTestInfo = do

@@ -18,25 +18,29 @@   FailContext, ) where +import Control.Monad (guard) import Control.Monad.IO.Class (MonadIO) import Data.Maybe (listToMaybe) import Data.Text (Text) import Data.Text qualified as Text import Data.Text.IO qualified as Text+import Data.Typeable (typeOf)+import GHC.IO.Exception qualified as GHC import GHC.Stack (CallStack) import GHC.Stack qualified as GHC+import Skeletest.Internal.Error (SkeletestError)+import Skeletest.Internal.TestInfo (TestInfo)+import Skeletest.Internal.Utils.BoxDrawing (BoxSpec, BoxSpecContent (..))+import Skeletest.Internal.Utils.Color qualified as Color+import Text.Read (readMaybe) import UnliftIO.Exception (   Exception,-  SomeException,+  SomeException (..),   displayException,   fromException,   try,  ) -import Skeletest.Internal.Error (SkeletestError)-import Skeletest.Internal.TestInfo (TestInfo)-import Skeletest.Internal.Utils.Color qualified as Color- {----- Testable -----}  class (MonadIO m) => Testable m where@@ -61,7 +65,7 @@ data TestResultMessage   = TestResultMessageNone   | TestResultMessageInline Text-  | TestResultMessageSection Text+  | TestResultMessageSection BoxSpec  testResultPass :: TestResult testResultPass =@@ -78,24 +82,75 @@     TestResult       { testResultSuccess = False       , testResultLabel = Color.red "FAIL"-      , testResultMessage = TestResultMessageSection msg+      , testResultMessage = TestResultMessageSection [BoxText msg]       } -testResultFromError :: SomeException -> TestResult-testResultFromError e =-  TestResult-    { testResultSuccess = False-    , testResultLabel = Color.red "ERROR"-    , testResultMessage = TestResultMessageInline $ Text.pack msg-    }-  where-    msg =-      case fromException e of-        -- In GHC 9.10+, SomeException shows the callstack, which we don't-        -- want to see for known Skeletest errors-        Just (err :: SkeletestError) -> displayException err-        Nothing -> displayException e+testResultFromError :: SomeException -> IO TestResult+testResultFromError e = do+  msg <- renderMsg+  pure+    TestResult+      { testResultSuccess = False+      , testResultLabel = Color.red "ERROR"+      , testResultMessage = TestResultMessageSection [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+    | Just err <- parseDoBlockFail e = do+        renderDoBlockFail err+    | SomeException err <- e = do+        pure . Text.strip . Text.pack . unlines $+          [ "Got exception of type `" <> (show . typeOf) err <> "`:"+          , displayException e+          ] +{----- DoBlockFail -----}++data DoBlockFail = DoBlockFail+  { doBlockFailMessage :: Text+  , doBlockFailFile :: FilePath+  , doBlockFailLine :: Int+  , doBlockFailStartCol :: Int+  , doBlockFailEndCol :: Int+  }++-- | See if the exception is from a pattern match fail in a do-block.+parseDoBlockFail :: SomeException -> Maybe DoBlockFail+parseDoBlockFail e = do+  GHC.IOError _ GHC.UserError _ msgStr _ _ <- fromException e+  let msg = Text.pack msgStr+  guard $ "Pattern match failure " `Text.isPrefixOf` msg+  [msgWithoutLoc, locInfo] <- pure $ Text.splitOn " at " msg+  [file, lineStr, colSpan] <- pure $ Text.splitOn ":" locInfo+  line <- readT lineStr+  [startCol, endCol] <- mapM readT $ Text.splitOn "-" colSpan+  pure+    DoBlockFail+      { doBlockFailMessage = msgWithoutLoc+      , doBlockFailFile = Text.unpack file+      , doBlockFailLine = line+      , doBlockFailStartCol = startCol+      , -- seems like srcLocEndCol is exclusive, while the columns in the fail message are inclusive+        doBlockFailEndCol = endCol + 1+      }+ where+  readT = readMaybe . Text.unpack++renderDoBlockFail :: DoBlockFail -> IO Text+renderDoBlockFail DoBlockFail{..} =+  renderPrettyFailure+    doBlockFailMessage+    doBlockFailContext+    [ (doBlockFailFile, doBlockFailLine, doBlockFailStartCol, doBlockFailEndCol)+    ]+ where+  doBlockFailContext = []+ {----- AssertionFail -----}  data AssertionFail = AssertionFail@@ -122,43 +177,62 @@ -- Right 1 ≠ Left 1 -- @ renderAssertionFail :: AssertionFail -> IO Text-renderAssertionFail AssertionFail{..} = do-  prettyStackTrace <- mapM renderCallLine . reverse $ GHC.getCallStack callStack+renderAssertionFail AssertionFail{..} =+  renderPrettyFailure+    testFailMessage+    testFailContext+    [ (srcLocFile, srcLocStartLine, srcLocStartCol, srcLocEndCol)+    | (_, GHC.SrcLoc{..}) <- GHC.getCallStack callStack+    ]++-- | Render a test failure like:+--+-- @+-- At test/Skeletest/Internal/TestTargetsSpec.hs:19:+-- |+-- |           parseTestTargets input `shouldBe` Right (Just expected)+-- |                                   ^^^^^^^^+--+-- Right 1 ≠ Left 1+-- @+renderPrettyFailure ::+  -- | Message+  Text ->+  FailContext ->+  -- | Call stack (file, line, startCol, endCol)+  [(FilePath, Int, Int, Int)] ->+  IO Text+renderPrettyFailure msg ctx callstack = do+  prettyStackTrace <- mapM renderCallLine . reverse $ callstack   pure . Text.intercalate "\n\n" . concat $     [ prettyStackTrace-    , if null testFailContext+    , if null ctx         then []-        else [Text.intercalate "\n" $ reverse testFailContext]-    , [testFailMessage]+        else [Text.intercalate "\n" $ reverse ctx]+    , [msg]     ]-  where-    renderCallLine (_, loc) = do-      let-        path = GHC.srcLocFile loc-        lineNum = GHC.srcLocStartLine loc-        startCol = GHC.srcLocStartCol loc-        endCol = GHC.srcLocEndCol loc--      mLine <--        try (Text.readFile path) >>= \case-          Right srcFile -> pure $ getLineNum lineNum srcFile-          Left (_ :: SomeException) -> pure Nothing-      let (srcLine, pointerLine) =-            case mLine of-              Just line ->-                ( line-                , Text.replicate (startCol - 1) " " <> Text.replicate (endCol - startCol) "^"-                )-              Nothing ->-                ( "<unknown line>"-                , ""-                )+ where+  renderCallLine (path, lineNum, startCol, endCol) = do+    mLine <-+      try (Text.readFile path) >>= \case+        Right srcFile -> pure $ getLineNum lineNum srcFile+        Left (_ :: SomeException) -> pure Nothing+    let (srcLine, pointerLine) =+          case mLine of+            Just line ->+              ( line+              , Text.replicate (startCol - 1) " " <> Text.replicate (endCol - startCol) "^"+              )+            Nothing ->+              ( "<unknown line>"+              , ""+              ) -      pure . Text.intercalate "\n" $-        [ Text.pack path <> ":" <> (Text.pack . show) lineNum <> ":"-        , "|"-        , "| " <> srcLine-        , "| " <> pointerLine-        ]+    pure . Text.intercalate "\n" $+      [ Text.pack path <> ":" <> (Text.pack . show) lineNum <> ":"+      , "|"+      , "| " <> srcLine+      , "| " <> pointerLine+      ] -    getLineNum n = listToMaybe . take 1 . drop (n - 1) . Text.lines+  getLineNum n = listToMaybe . take 1 . drop (n - 1) . Text.lines

@@ -44,15 +44,15 @@  matchesTest :: TestTarget -> TestAttrs -> Bool matchesTest selection TestAttrs{..} = go selection-  where-    go = \case-      TestTargetEverything -> True-      TestTargetFile path -> testPath == path-      TestTargetName s -> s `Text.isInfixOf` Text.unwords testIdentifier-      TestTargetMarker marker -> marker `elem` testMarkers-      TestTargetNot e -> not $ go e-      TestTargetAnd l r -> go l && go r-      TestTargetOr l r -> go l || go r+ where+  go = \case+    TestTargetEverything -> True+    TestTargetFile path -> testPath == path+    TestTargetName s -> s `Text.isInfixOf` Text.unwords testIdentifier+    TestTargetMarker marker -> marker `elem` testMarkers+    TestTargetNot e -> not $ go e+    TestTargetAnd l r -> go l && go r+    TestTargetOr l r -> go l || go r  {----- Parsing -----} @@ -61,8 +61,8 @@   case NonEmpty.nonEmpty args of     Nothing -> pure Nothing     Just args' -> Just . Foldable1.foldr1 TestTargetOr <$> mapM parseTestTarget args'-  where-    parseTestTarget = first showTestTargetParseError . Parser.parse (testTargetParser <* Parser.eof) ""+ where+  parseTestTarget = first showTestTargetParseError . Parser.parse (testTargetParser <* Parser.eof) ""  type Parser = Parsec Void Text type ParseErrorBundle = Parser.ParseErrorBundle Text Void@@ -85,32 +85,32 @@     [ [prefix "not" TestTargetNot]     , [binary "and" TestTargetAnd, binary "or" TestTargetOr]     ]-  where-    prefix name f = Parser.Prefix (f <$ symbol name)-    binary name f = Parser.InfixL (f <$ symbol name)+ where+  prefix name f = Parser.Prefix (f <$ symbol name)+  binary name f = Parser.InfixL (f <$ symbol name) -    symbol = Parser.L.symbol Parser.space-    parens = Parser.between (symbol "(") (symbol ")")+  symbol = Parser.L.symbol Parser.space+  parens = Parser.between (symbol "(") (symbol ")") -    everythingParser = TestTargetEverything <$ symbol "*"+  everythingParser = TestTargetEverything <$ symbol "*" -    nameParser =-      Parser.label "test name" $-        fmap TestTargetName . Parser.between (symbol "[") (symbol "]") $-          Parser.takeWhile1P Nothing (/= ']')+  nameParser =+    Parser.label "test name" $+      fmap TestTargetName . Parser.between (symbol "[") (symbol "]") $+        Parser.takeWhile1P Nothing (/= ']') -    markerParser =-      Parser.label "marker" . ignoreSpacesAfter $ do-        _ <- symbol "@"-        fmap TestTargetMarker . Parser.takeWhile1P Nothing $-          (||) <$> isAlphaNum <*> (`elem` ("-_." :: [Char]))+  markerParser =+    Parser.label "marker" . ignoreSpacesAfter $ do+      _ <- symbol "@"+      fmap TestTargetMarker . Parser.takeWhile1P Nothing $+        (||) <$> isAlphaNum <*> (`elem` ("-_." :: [Char])) -    fileParser =-      Parser.label "test file" . ignoreSpacesAfter $-        fmap (TestTargetFile . Text.unpack) . Parser.takeWhile1P Nothing $-          (||) <$> isAlphaNum <*> (`elem` ("-_./" :: [Char]))+  fileParser =+    Parser.label "test file" . ignoreSpacesAfter $+      fmap (TestTargetFile . Text.unpack) . Parser.takeWhile1P Nothing $+        (||) <$> isAlphaNum <*> (`elem` ("-_./" :: [Char])) -    ignoreSpacesAfter m = m <* Parser.space+  ignoreSpacesAfter m = m <* Parser.space  showTestTargetParseError :: ParseErrorBundle -> Text showTestTargetParseError bundle =

@@ -0,0 +1,49 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Skeletest.Internal.Utils.BoxDrawing (+  BoxSpec,+  BoxSpecContent (..),+  drawBox,+) where++import Data.Text (Text)+import Data.Text qualified as Text+import System.Console.Terminal.Size qualified as Term++type BoxSpec = [BoxSpecContent]++data BoxSpecContent+  = BoxText Text+  | BoxHeader Text+  deriving (Show, Eq)++drawBox :: BoxSpec -> IO Text+drawBox box = do+  width <- maybe 80 (max 40 . Term.width) <$> Term.size+  pure $ drawBox' width box++drawBox' :: Int -> BoxSpec -> Text+drawBox' width boxContents = Text.intercalate "\n" $ [header] <> concatMap draw boxContents <> [footer]+ where+  header = "╔" <> Text.replicate (width - 2) "═" <> "╗"+  footer = "╚" <> Text.replicate (width - 2) "═" <> "╝"++  draw = \case+    BoxHeader s ->+      [ drawLine ""+      , "╟─" <> cpad (width - 4) "─" ("⟨ " <> s <> " ⟩") <> "─╢"+      ]+    BoxText s ->+      [ drawLine line+      | rawLine <- Text.lines s+      , line <- if Text.null rawLine then [""] else Text.chunksOf (width - 4) rawLine+      ]+  drawLine s = "║ " <> rpad (width - 4) " " s <> " ║"++  rpad n fill s = s <> Text.replicate (n - Text.length s) fill+  cpad n fill s =+    let total = n - Text.length s+        left = total `div` 2+        right = total - left+     in Text.replicate left fill <> s <> Text.replicate right fill

@@ -13,5 +13,5 @@   Text.pack . PP.render $     prettyContextDiff (ppText fromName) (ppText toName) (ppText . Diff.unnumber) $       getContextDiff (Just 5) (Text.lines fromContent) (Text.lines toContent)-  where-    ppText = PP.text . Text.unpack+ where+  ppText = PP.text . Text.unpack

@@ -37,10 +37,10 @@  hzipWithM ::   (Monad m) =>-  (forall x. f x -> g x -> m (h x))-  -> HList f xs-  -> HList g xs-  -> m (HList h xs)+  (forall x. f x -> g x -> m (h x)) ->+  HList f xs ->+  HList g xs ->+  m (HList h xs) hzipWithM k = \cases   HNil HNil -> pure HNil   (HCons f fs) (HCons g gs) -> HCons <$> k f g <*> hzipWithM k fs gs

@@ -21,11 +21,8 @@ ) where  import Control.Monad (unless)-import Data.Maybe (fromMaybe)-import Data.Text qualified as Text-import System.Exit (exitFailure)- import Skeletest.Internal.CLI (Flag, flag, loadCliArgs)+import Skeletest.Internal.Capture (CaptureOutputFlag) import Skeletest.Internal.Snapshot (   SnapshotRenderer (..),   SnapshotUpdateFlag,@@ -42,11 +39,12 @@  ) import Skeletest.Plugin (Plugin (..)) import Skeletest.Prop.Internal (PropLimitFlag, PropSeedFlag)+import System.Exit (exitFailure) -runSkeletest :: [Plugin] -> [(FilePath, String, Spec)] -> IO ()+runSkeletest :: [Plugin] -> [(FilePath, Spec)] -> IO () runSkeletest = runSkeletest' . mconcat -runSkeletest' :: Plugin -> [(FilePath, String, Spec)] -> IO ()+runSkeletest' :: Plugin -> [(FilePath, Spec)] -> IO () runSkeletest' Plugin{..} testModules = do   selections <- loadCliArgs builtinFlags cliFlags   setSnapshotRenderers (snapshotRenderers <> defaultSnapshotRenderers)@@ -54,19 +52,16 @@   let initialSpecs = map mkSpec testModules   success <- runSpecs hooks . pruneSpec . applyTestSelections selections $ initialSpecs   unless success exitFailure-  where-    builtinFlags =-      [ flag @SnapshotUpdateFlag-      , flag @PropSeedFlag-      , flag @PropLimitFlag-      ]--    mkSpec (specPath, name, specSpec) =-      SpecInfo-        { specPath-        , specName = stripSuffix "Spec" $ Text.pack name-        , specSpec-        }+ where+  builtinFlags =+    [ flag @SnapshotUpdateFlag+    , flag @PropSeedFlag+    , flag @PropLimitFlag+    , flag @CaptureOutputFlag+    ] -    -- same as Text.stripSuffix, except return original string if not match-    stripSuffix suf s = fromMaybe s $ Text.stripSuffix suf s+  mkSpec (specPath, specSpec) =+    SpecInfo+      { specPath+      , specSpec+      }

@@ -45,14 +45,6 @@ import Hedgehog.Internal.Runner qualified as Hedgehog import Hedgehog.Internal.Seed qualified as Hedgehog.Seed import Hedgehog.Internal.Source qualified as Hedgehog-import Text.Read (readEither, readMaybe)-import UnliftIO.Exception (throwIO)-import UnliftIO.IORef (IORef, newIORef, readIORef, writeIORef)--#if !MIN_VERSION_base(4, 20, 0)-import Data.Foldable (foldl')-#endif- import Skeletest.Internal.CLI (FlagSpec (..), IsFlag (..), getFlag) import Skeletest.Internal.TestInfo (getTestInfo) import Skeletest.Internal.TestRunner (@@ -63,7 +55,14 @@   testResultPass,  ) import Skeletest.Internal.Utils.Color qualified as Color+import Text.Read (readEither, readMaybe)+import UnliftIO.Exception (throwIO)+import UnliftIO.IORef (IORef, newIORef, readIORef, writeIORef) +#if !MIN_VERSION_base(4, 20, 0)+import Data.Foldable (foldl')+#endif+ -- | A property to run, with optional configuration settings specified up front. -- -- Settings should be specified before any other 'Property' calls; any settings@@ -121,44 +120,44 @@  resolveConfig :: [PropertyConfig] -> Hedgehog.PropertyConfig resolveConfig = foldl' go defaultConfig-  where-    defaultConfig =-      Hedgehog.PropertyConfig-        { propertyDiscardLimit = 100-        , propertyShrinkLimit = 1000-        , propertyShrinkRetries = 0-        , propertyTerminationCriteria = Hedgehog.NoConfidenceTermination 100-        , propertySkip = Nothing-        }+ where+  defaultConfig =+    Hedgehog.PropertyConfig+      { propertyDiscardLimit = 100+      , propertyShrinkLimit = 1000+      , propertyShrinkRetries = 0+      , propertyTerminationCriteria = Hedgehog.NoConfidenceTermination 100+      , propertySkip = Nothing+      } -    go cfg = \case-      DiscardLimit x -> cfg{Hedgehog.propertyDiscardLimit = Hedgehog.DiscardLimit x}-      ShrinkLimit x -> cfg{Hedgehog.propertyShrinkLimit = Hedgehog.ShrinkLimit x}-      ShrinkRetries x -> cfg{Hedgehog.propertyShrinkRetries = Hedgehog.ShrinkRetries x}-      SetConfidence x ->-        cfg-          { Hedgehog.propertyTerminationCriteria =-              case Hedgehog.propertyTerminationCriteria cfg of-                Hedgehog.NoEarlyTermination _ tests -> Hedgehog.NoEarlyTermination (Hedgehog.Confidence $ fromIntegral x) tests-                Hedgehog.NoConfidenceTermination tests -> Hedgehog.NoEarlyTermination (Hedgehog.Confidence $ fromIntegral x) tests-                Hedgehog.EarlyTermination _ tests -> Hedgehog.EarlyTermination (Hedgehog.Confidence $ fromIntegral x) tests-          }-      SetVerifiedTermination ->-        cfg-          { Hedgehog.propertyTerminationCriteria =-              case Hedgehog.propertyTerminationCriteria cfg of-                Hedgehog.NoEarlyTermination c tests -> Hedgehog.EarlyTermination c tests-                Hedgehog.NoConfidenceTermination tests -> Hedgehog.EarlyTermination Hedgehog.defaultConfidence tests-                Hedgehog.EarlyTermination c tests -> Hedgehog.EarlyTermination c tests-          }-      SetTestLimit x ->-        cfg-          { Hedgehog.propertyTerminationCriteria =-              case Hedgehog.propertyTerminationCriteria cfg of-                Hedgehog.NoEarlyTermination c _ -> Hedgehog.NoEarlyTermination c (Hedgehog.TestLimit x)-                Hedgehog.NoConfidenceTermination _ -> Hedgehog.NoConfidenceTermination (Hedgehog.TestLimit x)-                Hedgehog.EarlyTermination c _ -> Hedgehog.EarlyTermination c (Hedgehog.TestLimit x)-          }+  go cfg = \case+    DiscardLimit x -> cfg{Hedgehog.propertyDiscardLimit = Hedgehog.DiscardLimit x}+    ShrinkLimit x -> cfg{Hedgehog.propertyShrinkLimit = Hedgehog.ShrinkLimit x}+    ShrinkRetries x -> cfg{Hedgehog.propertyShrinkRetries = Hedgehog.ShrinkRetries x}+    SetConfidence x ->+      cfg+        { Hedgehog.propertyTerminationCriteria =+            case Hedgehog.propertyTerminationCriteria cfg of+              Hedgehog.NoEarlyTermination _ tests -> Hedgehog.NoEarlyTermination (Hedgehog.Confidence $ fromIntegral x) tests+              Hedgehog.NoConfidenceTermination tests -> Hedgehog.NoEarlyTermination (Hedgehog.Confidence $ fromIntegral x) tests+              Hedgehog.EarlyTermination _ tests -> Hedgehog.EarlyTermination (Hedgehog.Confidence $ fromIntegral x) tests+        }+    SetVerifiedTermination ->+      cfg+        { Hedgehog.propertyTerminationCriteria =+            case Hedgehog.propertyTerminationCriteria cfg of+              Hedgehog.NoEarlyTermination c tests -> Hedgehog.EarlyTermination c tests+              Hedgehog.NoConfidenceTermination tests -> Hedgehog.EarlyTermination Hedgehog.defaultConfidence tests+              Hedgehog.EarlyTermination c tests -> Hedgehog.EarlyTermination c tests+        }+    SetTestLimit x ->+      cfg+        { Hedgehog.propertyTerminationCriteria =+            case Hedgehog.propertyTerminationCriteria cfg of+              Hedgehog.NoEarlyTermination c _ -> Hedgehog.NoEarlyTermination c (Hedgehog.TestLimit x)+              Hedgehog.NoConfidenceTermination _ -> Hedgehog.NoConfidenceTermination (Hedgehog.TestLimit x)+              Hedgehog.EarlyTermination c _ -> Hedgehog.EarlyTermination c (Hedgehog.TestLimit x)+        }  runProperty :: Property -> IO TestResult runProperty = \case@@ -242,63 +241,63 @@                     -- N.B. testFailContext is reversed!                     testFailContext failure <> reverse info                 }-  where-    reportProgress _ = pure ()-    renderSeed report =-      let Hedgehog.Seed value gamma = Hedgehog.reportSeed report-       in show value <> ":" <> show gamma-    renderCoverage coverage testCount =-      let columns =-            [ (name, percentStr, percentBar)-            | Hedgehog.MkLabel{..} <- List.sortOn Hedgehog.labelLocation $ Map.elems coverage-            , let-                Hedgehog.LabelName name = labelName-                Hedgehog.CoverCount count = labelAnnotation-                percent = round $ fromIntegral count / fromIntegral testCount * (100 :: Double)-                percentStr = show percent <> "%"-                percentBar = renderPercentBar percent-            ]-          (maxNameLen, maxPercentLen) =-            foldr-              ( \(name, percent, _) (nameAcc, percentAcc) ->-                  (max (length name) nameAcc, max (length percent) percentAcc)-              )-              (0, 0)-              columns-       in [ rjust maxNameLen name <> " " <> rjust maxPercentLen percentStr <> " " <> percentBar-          | (name, percentStr, percentBar) <- columns+ where+  reportProgress _ = pure ()+  renderSeed report =+    let Hedgehog.Seed value gamma = Hedgehog.reportSeed report+     in show value <> ":" <> show gamma+  renderCoverage coverage testCount =+    let columns =+          [ (name, percentStr, percentBar)+          | Hedgehog.MkLabel{..} <- List.sortOn Hedgehog.labelLocation $ Map.elems coverage+          , let+              Hedgehog.LabelName name = labelName+              Hedgehog.CoverCount count = labelAnnotation+              percent = round $ fromIntegral count / fromIntegral testCount * (100 :: Double)+              percentStr = show percent <> "%"+              percentBar = renderPercentBar percent           ]-    rjust n s = replicate (n - length s) ' ' <> s-    renderPercentBar percent =-      -- render percentage bar 20 characters wide-      let (n, r) = percent `divMod` 5-       in concat-            [ replicate n '█'-            , case r of-                0 -> ""-                1 -> "▏"-                2 -> "▍"-                3 -> "▌"-                4 -> "▊"-                _ -> "" -- unreachable-            , replicate (20 - n - (if r == 0 then 0 else 1)) '·'-            ]-    toCallStack mSpan =-      GHC.fromCallSiteList $-        case mSpan of-          Nothing -> []-          Just Hedgehog.Span{..} ->-            let loc =-                  GHC.SrcLoc-                    { srcLocPackage = ""-                    , srcLocModule = ""-                    , srcLocFile = spanFile-                    , srcLocStartLine = Hedgehog.unLineNo spanStartLine-                    , srcLocStartCol = Hedgehog.unColumnNo spanStartColumn-                    , srcLocEndLine = Hedgehog.unLineNo spanEndLine-                    , srcLocEndCol = Hedgehog.unColumnNo spanEndColumn-                    }-             in [("<unknown>", loc)]+        (maxNameLen, maxPercentLen) =+          foldr+            ( \(name, percent, _) (nameAcc, percentAcc) ->+                (max (length name) nameAcc, max (length percent) percentAcc)+            )+            (0, 0)+            columns+     in [ rjust maxNameLen name <> " " <> rjust maxPercentLen percentStr <> " " <> percentBar+        | (name, percentStr, percentBar) <- columns+        ]+  rjust n s = replicate (n - length s) ' ' <> s+  renderPercentBar percent =+    -- render percentage bar 20 characters wide+    let (n, r) = percent `divMod` 5+     in concat+          [ replicate n '█'+          , case r of+              0 -> ""+              1 -> "▏"+              2 -> "▍"+              3 -> "▌"+              4 -> "▊"+              _ -> "" -- unreachable+          , replicate (20 - n - (if r == 0 then 0 else 1)) '·'+          ]+  toCallStack mSpan =+    GHC.fromCallSiteList $+      case mSpan of+        Nothing -> []+        Just Hedgehog.Span{..} ->+          let loc =+                GHC.SrcLoc+                  { srcLocPackage = ""+                  , srcLocModule = ""+                  , srcLocFile = spanFile+                  , srcLocStartLine = Hedgehog.unLineNo spanStartLine+                  , srcLocStartCol = Hedgehog.unColumnNo spanStartColumn+                  , srcLocEndLine = Hedgehog.unLineNo spanEndLine+                  , srcLocEndCol = Hedgehog.unColumnNo spanEndColumn+                  }+           in [("<unknown>", loc)]  loadPropFlags :: IO (Hedgehog.Seed, [PropertyConfig]) loadPropFlags = do@@ -389,12 +388,12 @@       { flagDefault = PropSeedFlag Nothing       , flagParse = parse       }-    where-      parse s = maybe (Left $ "Invalid seed: " <> s) Right $ do-        (valS, ':' : gammaS) <- pure $ break (== ':') s-        val <- readMaybe valS-        gamma <- readMaybe gammaS-        pure . PropSeedFlag . Just $ Hedgehog.Seed val gamma+   where+    parse s = maybe (Left $ "Invalid seed: " <> s) Right $ do+      (valS, ':' : gammaS) <- pure $ break (== ':') s+      val <- readMaybe valS+      gamma <- readMaybe gammaS+      pure . PropSeedFlag . Just $ Hedgehog.Seed val gamma  newtype PropLimitFlag = PropLimitFlag (Maybe Int) 

@@ -45,7 +45,7 @@ handleErrors = handle $ \(e :: SkeletestError) -> do   hPutStrLn stderr $ normalizeLines $ displayException e   exitFailure-  where-    normalizeLines-      | __GLASGOW_HASKELL__ == (908 :: Int) = dropWhileEnd (== '\n')-      | otherwise = id+ where+  normalizeLines+    | __GLASGOW_HASKELL__ == (908 :: Int) = dropWhileEnd (== '\n')+    | otherwise = id

@@ -4,7 +4,6 @@  import Data.IORef (IORef, modifyIORef', newIORef, readIORef) import Data.Text qualified as Text- import Skeletest import Skeletest.Predicate qualified as P import Skeletest.Prop qualified as Prop

@@ -1,10 +1,15 @@+{-# LANGUAGE CPP #-}+ module Skeletest.AssertionsSpec (spec) where  import Skeletest import Skeletest.Predicate qualified as P- import Skeletest.TestUtils.Integration +#if __GLASGOW_HASKELL__ == 910+import Data.Text qualified as Text+#endif+ spec :: Spec spec = do   describe "shouldBe" $ do@@ -140,3 +145,51 @@     code `shouldBe` ExitFailure 1     stderr `shouldBe` ""     stdout `shouldSatisfy` P.matchesSnapshot++  integration . it "shows helpful error on pattern match fail" $ do+    runner <- getFixture+    addTestFile runner "ExampleSpec.hs" $+      [ "module ExampleSpec (spec) where"+      , ""+      , "import Skeletest"+      , "import qualified Skeletest.Predicate as P"+      , ""+      , "spec = it \"should fail\" $ do"+      , "  Just x <- pure Nothing"+      , "  x `shouldBe` True"+      ]++    (code, stdout, stderr) <- runTests runner []+    code `shouldBe` ExitFailure 1+    stderr `shouldBe` ""+    stdout `shouldSatisfy` P.matchesSnapshot++  integration . it "shows unrecognized exceptions" $ do+    runner <- getFixture+    addTestFile runner "ExampleSpec.hs" $+      [ "module ExampleSpec (spec) where"+      , ""+      , "import Skeletest"+      , "import qualified Skeletest.Predicate as P"+      , ""+      , "spec = it \"should fail\" $ do"+      , "  _ <- readFile \"unknown-file.txt\""+      , "  pure ()"+      ]++    (code, stdout, stderr) <- runTests runner []+    code `shouldBe` ExitFailure 1+    stderr `shouldBe` ""+    sanitizeTraceback stdout `shouldSatisfy` P.matchesSnapshot++-- GHC 9.10 specifically added a backtrace to SomeException, which was reverted in 9.12+-- https://github.com/haskell/core-libraries-committee/issues/285+sanitizeTraceback :: String -> String+#if __GLASGOW_HASKELL__ == 910+sanitizeTraceback s =+  let (pre, post) = break (Text.pack "HasCallStack backtrace:" `Text.isInfixOf`) $ Text.lines $ Text.pack s+      (_, post2) = break (Text.pack "╚" `Text.isPrefixOf`) $ drop 1 post+   in Text.unpack . Text.unlines $ pre ++ post2+#else+sanitizeTraceback = id+#endif

@@ -5,14 +5,13 @@ import Data.Map qualified as Map import Data.Typeable (Typeable, typeOf) import Skeletest-import Skeletest.Predicate qualified as P- import Skeletest.Internal.CLI (   CLIFlagStore,   CLIParseResult (..),   flag,   parseCliArgs,  )+import Skeletest.Predicate qualified as P import Skeletest.TestUtils.Integration  newtype FooFlag = FooFlag String

@@ -0,0 +1,182 @@+{-# LANGUAGE OverloadedRecordDot #-}++module Skeletest.Internal.CaptureSpec (spec) where++import Data.List qualified as List+import Skeletest+import Skeletest.Predicate qualified as P+import Skeletest.TestUtils.Integration++spec :: Spec+spec = do+  mapM_ runtimeSpec ["stdout", "stderr"]++  describe "FixtureCapturedOutput" $ do+    mapM_ fixtureGetSpec $+      [ ("stdout", "getStdout")+      , ("stderr", "getStderr")+      ]+    mapM_ fixtureReadSpec $+      [ ("stdout", "readStdout")+      , ("stderr", "readStderr")+      ]++runtimeSpec :: String -> Spec+runtimeSpec handle = do+  describe handle $ do+    integration . it "is hidden on test success" $ do+      runner <- getFixture+      addTestFile runner "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) <- runTests runner []+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot+      code `shouldBe` ExitSuccess++    integration . it "is rendered on test failure" $ do+      runner <- getFixture+      addTestFile runner "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"+        , "    1 `shouldBe` 2"+        ]+      (code, stdout, stderr) <- runTests runner []+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot+      code `shouldBe` ExitFailure 1++    integration . it "is rendered on test error" $ do+      runner <- getFixture+      addTestFile runner "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"+        , "    Just _ <- pure Nothing"+        , "    pure ()"+        ]+      (code, stdout, stderr) <- runTests runner []+      stderr `shouldBe` ""+      stdout `shouldSatisfy` P.matchesSnapshot+      code `shouldBe` ExitFailure 1++    integration . it "is not captured with --capture-output=off" $ do+      runner <- getFixture+      addTestFile runner "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) <- runTests runner ["--capture-output=off"]+      List.intercalate "\n\n" [">>> stdout", stdout, ">>> stderr", stderr] `shouldSatisfy` P.matchesSnapshot+      code `shouldBe` ExitSuccess++fixtureGetSpec :: (String, String) -> Spec+fixtureGetSpec (handle, func) =+  describe func $ do+    integration . it "returns captured output from current test" $ do+      runner <- getFixture+      addTestFile runner "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"+        , "    output <- getFixture @FixtureCapturedOutput"+        , "    s <- output." <> func+        , "    s `shouldBe` " <> show ""+        , "    " <> render_hPutStrLn handle "test1"+        , "    s <- output." <> func+        , "    s `shouldBe` " <> show "test1\n"+        , "    " <> render_hPutStrLn handle "test2"+        , "    s <- output." <> func+        , "    s `shouldBe` " <> show "test1\ntest2\n"+        ]+      (code, stdout, stderr) <- runTests runner []+      stderr `shouldBe` ""+      context stdout $+        code `shouldBe` ExitSuccess++fixtureReadSpec :: (String, String) -> Spec+fixtureReadSpec (handle, func) =+  describe func $ do+    integration . it "returns captured output from current test" $ do+      runner <- getFixture+      addTestFile runner "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"+        , "    output <- getFixture @FixtureCapturedOutput"+        , "    s <- output." <> func+        , "    s `shouldBe` " <> show ""+        , "    " <> render_hPutStrLn handle "test1"+        , "    s <- output." <> func+        , "    s `shouldBe` " <> show "test1\n"+        , "    " <> render_hPutStrLn handle "test2"+        , "    s <- output." <> func+        , "    s `shouldBe` " <> show "test2\n"+        ]+      (code, stdout, stderr) <- runTests runner []+      stderr `shouldBe` ""+      context stdout $+        code `shouldBe` ExitSuccess++render_hPutStrLn :: String -> String -> String+render_hPutStrLn handle s = "IO.hPutStrLn IO." <> handle <> " " <> show s

@@ -2,7 +2,6 @@  import Skeletest import Skeletest.Predicate qualified as P- import Skeletest.TestUtils.Integration  spec :: Spec

@@ -1,14 +1,12 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}  module Skeletest.Internal.SnapshotSpec (spec) where  import Data.Aeson qualified as Aeson import Data.String (fromString)+import Data.Text qualified as Text import Skeletest-import Skeletest.Predicate qualified as P-import Skeletest.Prop.Gen qualified as Gen-import Skeletest.Prop.Range qualified as Range- import Skeletest.Internal.Snapshot (   SnapshotFile (..),   SnapshotValue (..),@@ -16,6 +14,9 @@   encodeSnapshotFile,   normalizeSnapshotFile,  )+import Skeletest.Predicate qualified as P+import Skeletest.Prop.Gen qualified as Gen+import Skeletest.Prop.Range qualified as Range import Skeletest.TestUtils.Integration  spec :: Spec@@ -111,25 +112,29 @@  genSnapshotFileRaw :: Gen SnapshotFile genSnapshotFileRaw = do-  moduleName <- Gen.text (Range.linear 0 100) genHsModuleChar+  testFile <- genHsModule   snapshots <- Gen.map rangeNumTests genSnapshot   pure SnapshotFile{..}-  where-    rangeNumTests = Range.linear 0 10-    rangeSnapshotsPerTest = Range.linear 0 5-    rangeSnapshotSize = Range.linear 0 1000+ where+  rangeNumTests = Range.linear 0 10+  rangeSnapshotsPerTest = Range.linear 0 5+  rangeSnapshotSize = Range.linear 0 1000 -    genHsModuleChar = Gen.choice [Gen.alphaNum, pure '\'']+  genHsModule = do+    dirs <- Gen.list (Range.linear 0 10) genHsModuleName+    file <- genHsModuleName+    pure $ Text.intercalate "/" dirs <> file <> ".hs"+  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)-      vals <- Gen.list rangeSnapshotsPerTest genSnapshotVal-      pure (ident, vals)+  genSnapshot = do+    ident <- Gen.list (Range.linear 1 10) (Gen.text (Range.linear 1 100) Gen.unicode)+    vals <- Gen.list rangeSnapshotsPerTest genSnapshotVal+    pure (ident, vals) -    genSnapshotVal = do-      snapshotContent <- Gen.text rangeSnapshotSize Gen.unicode-      snapshotLang <- Gen.maybe $ Gen.text (Range.linear 1 5) Gen.unicode-      pure SnapshotValue{..}+  genSnapshotVal = do+    snapshotContent <- Gen.text rangeSnapshotSize Gen.unicode+    snapshotLang <- Gen.maybe $ Gen.text (Range.linear 1 5) Gen.unicode+    pure SnapshotValue{..}  genSnapshotFile :: Gen SnapshotFile genSnapshotFile = normalizeSnapshotFile <$> genSnapshotFileRaw

@@ -2,7 +2,6 @@  import Skeletest import Skeletest.Predicate qualified as P- import Skeletest.TestUtils.Integration  spec :: Spec

@@ -3,9 +3,8 @@ module Skeletest.Internal.TestTargetsSpec (spec) where  import Skeletest-import Skeletest.Predicate qualified as P- import Skeletest.Internal.TestTargets+import Skeletest.Predicate qualified as P  spec :: Spec spec = do

@@ -1,9 +1,12 @@-# Skeletest.Internal.CLI+# test/Skeletest/Internal/CLISpec.hs  ## getFlag / errors if flag is not registered  ```-Example+./ExampleSpec.hs     should error: ERROR-        CLI flag 'my-flag' was not registered. Did you add it to cliFlags in Main.hs?+╔══════════════════════════════════════════════════════════════════════════════╗+║ CLI flag 'my-flag' was not registered. Did you add it to cliFlags in Main.hs ║+║ ?                                                                            ║+╚══════════════════════════════════════════════════════════════════════════════╝ ```

@@ -1,9 +1,12 @@-# Skeletest.Internal.Fixtures+# test/Skeletest/Internal/FixturesSpec.hs  ## getFixture / detects circular dependencies  ```-Example+./ExampleSpec.hs     should error: ERROR-        Found circular dependency when resolving fixtures: FixtureA -> FixtureB -> FixtureD -> FixtureA+╔══════════════════════════════════════════════════════════════════════════════╗+║ Found circular dependency when resolving fixtures: FixtureA -> FixtureB -> F ║+║ ixtureD -> FixtureA                                                          ║+╚══════════════════════════════════════════════════════════════════════════════╝ ```

@@ -1,11 +1,13 @@-# Skeletest.Internal.Snapshot+# test/Skeletest/Internal/SnapshotSpec.hs  ## detects corrupted snapshot files  ```-Example+./ExampleSpec.hs     should error: ERROR-        Snapshot file was corrupted: ./__snapshots__/ExampleSpec.snap.md+╔══════════════════════════════════════════════════════════════════════════════╗+║ Snapshot file was corrupted: ./__snapshots__/ExampleSpec.snap.md             ║+╚══════════════════════════════════════════════════════════════════════════════╝ ```  ## renders JSON values@@ -22,24 +24,24 @@ ## shows helpful failure messages  ```-Example+./ExampleSpec.hs     fails: FAIL----------------------------------------------------------------------------------./ExampleSpec.hs:7:-|-|   unlines ["new1", "same1", "same2", "new2"] `shouldSatisfy` P.matchesSnapshot-|                                              ^^^^^^^^^^^^^^^--Result differed from snapshot. Update snapshot with --update.---- expected-+++ actual-@@ -1,4 +1,4 @@-+new1- same1--old1- same2--old2-+new2----------------------------------------------------------------------------------+╔══════════════════════════════════════════════════════════════════════════════╗+║ ./ExampleSpec.hs:7:                                                          ║+║ |                                                                            ║+║ |   unlines ["new1", "same1", "same2", "new2"] `shouldSatisfy` P.matchesSnap ║+║ shot                                                                         ║+║ |                                              ^^^^^^^^^^^^^^^               ║+║                                                                              ║+║ Result differed from snapshot. Update snapshot with --update.                ║+║ --- expected                                                                 ║+║ +++ actual                                                                   ║+║ @@ -1,4 +1,4 @@                                                              ║+║ +new1                                                                        ║+║  same1                                                                       ║+║ -old1                                                                        ║+║  same2                                                                       ║+║ -old2                                                                        ║+║ +new2                                                                        ║+╚══════════════════════════════════════════════════════════════════════════════╝ ```

@@ -1,9 +1,9 @@-# Skeletest.Internal.Spec+# test/Skeletest/Internal/SpecSpec.hs  ## skip / skips tests completely  ```-Example+./ExampleSpec.hs     should not run: SKIP         broken tests     should not run either: SKIP@@ -13,7 +13,7 @@ ## xfail / checks for expected failures  ```-Example+./ExampleSpec.hs     should fail: XFAIL         broken tests     should fail too: XFAIL@@ -23,7 +23,7 @@ ## xfail / errors on unexpected passes  ```-Example+./ExampleSpec.hs     should fail: XPASS         broken tests     should fail too: XPASS

@@ -1,4 +1,4 @@-# Skeletest.Internal.TestTargets+# test/Skeletest/Internal/TestTargetsSpec.hs  ## parseTestTargets / fails with a helpful error message 

@@ -5,7 +5,6 @@ import Data.Text qualified as Text import Skeletest import Skeletest.Predicate qualified as P- import Skeletest.TestUtils.Integration  spec :: Spec@@ -59,16 +58,16 @@  normalizePluginError :: String -> String normalizePluginError = Text.unpack . go . Text.pack-  where-    replace old new = Text.replace (Text.pack old) (Text.pack new)-    go-      | __GLASGOW_HASKELL__ == (908 :: Int) = replace "*** Exception: ExitFailure 1" "\n*** Exception: ExitFailure 1"-      | otherwise = id+ where+  replace old new = Text.replace (Text.pack old) (Text.pack new)+  go+    | __GLASGOW_HASKELL__ == (908 :: Int) = replace "*** Exception: ExitFailure 1" "\n*** Exception: ExitFailure 1"+    | otherwise = id  normalizeGhc29916 :: String -> String normalizeGhc29916 = Text.unpack . go . Text.pack-  where-    replace old new = Text.replace (Text.pack old) (Text.pack new)-    go-      | __GLASGOW_HASKELL__ == (908 :: Int) = replace "<generated>" "<no location info>"-      | otherwise = id+ where+  replace old new = Text.replace (Text.pack old) (Text.pack new)+  go+    | __GLASGOW_HASKELL__ == (908 :: Int) = replace "<generated>" "<no location info>"+    | otherwise = id

@@ -7,11 +7,10 @@ import Data.IORef (newIORef, readIORef, writeIORef) import Data.Text qualified as Text import Skeletest-import Skeletest.Predicate qualified as P-import UnliftIO.Exception (Exception, throwIO)- import Skeletest.Internal.Predicate (PredicateResult (..), runPredicate)+import Skeletest.Predicate qualified as P import Skeletest.TestUtils.Integration+import UnliftIO.Exception (Exception, throwIO)  data User = User   { name :: String@@ -398,67 +397,67 @@  normalizeVars :: String -> String normalizeVars = go-  where-    go = \case-      [] -> []-      'x' : '0' : '_' : cs -> "x0" <> go (drop 4 cs)-      'a' : 'c' : 't' : 'u' : 'a' : 'l' : '_' : cs -> "actual" <> go (drop 4 cs)-      c : cs -> c : go cs+ where+  go = \case+    [] -> []+    'x' : '0' : '_' : cs -> "x0" <> go (drop 4 cs)+    'a' : 'c' : 't' : 'u' : 'a' : 'l' : '_' : cs -> "actual" <> go (drop 4 cs)+    c : cs -> c : go cs  normalizeConFailure :: String -> String normalizeConFailure = Text.unpack . go . Text.pack-  where-    go-      | __GLASGOW_HASKELL__ == (908 :: Int) =-          let old =-                Text.pack . unlines $-                  [ "    • In a stmt of a 'do' block:"-                  , "        User \"alice\" (Just 1)"-                  , "          `shouldSatisfy`"-                  , "            Skeletest.Internal.Predicate.conMatches"-                  , "              \"User\" Nothing"-                  , "              \\ actual"-                  , "                -> case pure actual of"-                  , "                     Just (User x0)"-                  , "                       -> Just"-                  , "                            (Skeletest.Internal.Utils.HList.HCons"-                  , "                               (pure x0) Skeletest.Internal.Utils.HList.HNil)"-                  , "                     _ -> Nothing"-                  , "              (Skeletest.Internal.Utils.HList.HCons"-                  , "                 (P.eq \"\") Skeletest.Internal.Utils.HList.HNil)"-                  , "      In the second argument of ‘($)’, namely"-                  , "        ‘do User \"alice\" (Just 1)"-                  , "              `shouldSatisfy`"-                  , "                Skeletest.Internal.Predicate.conMatches"-                  , "                  \"User\" Nothing"-                  , "                  \\ actual"-                  , "                    -> case pure actual of"-                  , "                         Just (User x0) -> ..."-                  , "                         _ -> ..."-                  , "                  (Skeletest.Internal.Utils.HList.HCons"-                  , "                     (P.eq \"\") Skeletest.Internal.Utils.HList.HNil)’"-                  , "      In the expression:"-                  , "        it \"should error\""-                  , "          $ do User \"alice\" (Just 1)"-                  , "                 `shouldSatisfy`"-                  , "                   Skeletest.Internal.Predicate.conMatches"-                  , "                     \"User\" Nothing"-                  , "                     \\ actual"-                  , "                       -> case pure actual of"-                  , "                            Just (User x0) -> ..."-                  , "                            _ -> ..."-                  , "                     (Skeletest.Internal.Utils.HList.HCons"-                  , "                        (P.eq \"\") Skeletest.Internal.Utils.HList.HNil)"-                  ]-              new =-                Text.pack . unlines $-                  [ "    • 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)"-                  ]-           in Text.replace old new-      | otherwise = id+ where+  go+    | __GLASGOW_HASKELL__ == (908 :: Int) =+        let old =+              Text.pack . unlines $+                [ "    • In a stmt of a 'do' block:"+                , "        User \"alice\" (Just 1)"+                , "          `shouldSatisfy`"+                , "            Skeletest.Internal.Predicate.conMatches"+                , "              \"User\" Nothing"+                , "              \\ actual"+                , "                -> case pure actual of"+                , "                     Just (User x0)"+                , "                       -> Just"+                , "                            (Skeletest.Internal.Utils.HList.HCons"+                , "                               (pure x0) Skeletest.Internal.Utils.HList.HNil)"+                , "                     _ -> Nothing"+                , "              (Skeletest.Internal.Utils.HList.HCons"+                , "                 (P.eq \"\") Skeletest.Internal.Utils.HList.HNil)"+                , "      In the second argument of ‘($)’, namely"+                , "        ‘do User \"alice\" (Just 1)"+                , "              `shouldSatisfy`"+                , "                Skeletest.Internal.Predicate.conMatches"+                , "                  \"User\" Nothing"+                , "                  \\ actual"+                , "                    -> case pure actual of"+                , "                         Just (User x0) -> ..."+                , "                         _ -> ..."+                , "                  (Skeletest.Internal.Utils.HList.HCons"+                , "                     (P.eq \"\") Skeletest.Internal.Utils.HList.HNil)’"+                , "      In the expression:"+                , "        it \"should error\""+                , "          $ do User \"alice\" (Just 1)"+                , "                 `shouldSatisfy`"+                , "                   Skeletest.Internal.Predicate.conMatches"+                , "                     \"User\" Nothing"+                , "                     \\ actual"+                , "                       -> case pure actual of"+                , "                            Just (User x0) -> ..."+                , "                            _ -> ..."+                , "                     (Skeletest.Internal.Utils.HList.HCons"+                , "                        (P.eq \"\") Skeletest.Internal.Utils.HList.HNil)"+                ]+            new =+              Text.pack . unlines $+                [ "    • 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)"+                ]+         in Text.replace old new+    | otherwise = id

@@ -4,7 +4,6 @@ import Skeletest.Predicate qualified as P import Skeletest.Prop.Gen qualified as Gen import Skeletest.Prop.Range qualified as Range- import Skeletest.TestUtils.Integration  spec :: Spec

@@ -60,12 +60,12 @@         { testRunnerDir = tmpdir         , testRunnerSettingsRef = settingsRef         }-    where-      defaultSettings =-        TestRunnerSettings-          { mainFile = ["import Skeletest.Main"]-          , testFiles = []-          }+   where+    defaultSettings =+      TestRunnerSettings+        { mainFile = ["import Skeletest.Main"]+        , testFiles = []+        }  setMainFile :: FixtureTestRunner -> FileContents -> IO () setMainFile FixtureTestRunner{testRunnerSettingsRef} contents =@@ -93,25 +93,25 @@         ]    pure (code, sanitize stdout, sanitize stderr)-  where-    addFile fp contents = do-      let path = testRunnerDir </> fp-      createDirectoryIfMissing True (takeDirectory path)-      writeFile path (unlines contents)+ where+  addFile fp contents = do+    let path = testRunnerDir </> fp+    createDirectoryIfMissing True (takeDirectory path)+    writeFile path (unlines contents) -    ghcArgs =-      concat-        [ ["-hide-all-packages"]-        , ["-F", "-pgmF=skeletest-preprocessor"]-        , ["-package skeletest"]-        ]-    setCWD dir p = p{cwd = Just dir}+  ghcArgs =+    concat+      [ ["-hide-all-packages"]+      , ["-F", "-pgmF=skeletest-preprocessor"]+      , ["-package skeletest"]+      ]+  setCWD dir p = p{cwd = Just dir} -    sanitize = Text.unpack . stripControlChars . Text.strip . Text.pack-    stripControlChars s =-      case Text.breakOn "\x1b" s of-        (_, "") -> s-        (pre, post) -> pre <> stripControlChars (Text.drop 1 . Text.dropWhile (/= 'm') $ post)+  sanitize = Text.unpack . stripControlChars . Text.strip . Text.pack+  stripControlChars s =+    case Text.breakOn "\x1b" s of+      (_, "") -> s+      (pre, post) -> pre <> stripControlChars (Text.drop 1 . Text.dropWhile (/= 'm') $ post)  expectSuccess :: (HasCallStack) => IO (ExitCode, String, String) -> IO (String, String) expectSuccess m = do

@@ -1,131 +1,157 @@-# Skeletest.Assertions+# test/Skeletest/AssertionsSpec.hs  ## context / should show failure context  ```-Example+./ExampleSpec.hs     should fail: FAIL----------------------------------------------------------------------------------./ExampleSpec.hs:7:-|-|     1 `shouldBe` (2 :: Int)-|       ^^^^^^^^^^--hello-world--1 ≠ 2---------------------------------------------------------------------------------+╔══════════════════════════════════════════════════════════════════════════════╗+║ ./ExampleSpec.hs:7:                                                          ║+║ |                                                                            ║+║ |     1 `shouldBe` (2 :: Int)                                                ║+║ |       ^^^^^^^^^^                                                           ║+║                                                                              ║+║ hello                                                                        ║+║ world                                                                        ║+║                                                                              ║+║ 1 ≠ 2                                                                        ║+╚══════════════════════════════════════════════════════════════════════════════╝ ```  ## failTest / should show failure  ```-Example+./ExampleSpec.hs     should fail: FAIL----------------------------------------------------------------------------------./ExampleSpec.hs:5:-|-| spec = it "should fail" $ failTest "error message"-|                           ^^^^^^^^--error message---------------------------------------------------------------------------------+╔══════════════════════════════════════════════════════════════════════════════╗+║ ./ExampleSpec.hs:5:                                                          ║+║ |                                                                            ║+║ | spec = it "should fail" $ failTest "error message"                         ║+║ |                           ^^^^^^^^                                         ║+║                                                                              ║+║ error message                                                                ║+╚══════════════════════════════════════════════════════════════════════════════╝ ```  ## shouldBe / should show helpful failure  ```-Example+./ExampleSpec.hs     should fail: FAIL----------------------------------------------------------------------------------./ExampleSpec.hs:5:-|-| spec = it "should fail" $ 1 `shouldBe` (2 :: Int)-|                             ^^^^^^^^^^--1 ≠ 2---------------------------------------------------------------------------------+╔══════════════════════════════════════════════════════════════════════════════╗+║ ./ExampleSpec.hs:5:                                                          ║+║ |                                                                            ║+║ | spec = it "should fail" $ 1 `shouldBe` (2 :: Int)                          ║+║ |                             ^^^^^^^^^^                                     ║+║                                                                              ║+║ 1 ≠ 2                                                                        ║+╚══════════════════════════════════════════════════════════════════════════════╝ ```  ## shouldNotBe / should show helpful failure  ```-Example+./ExampleSpec.hs     should fail: FAIL----------------------------------------------------------------------------------./ExampleSpec.hs:5:-|-| spec = it "should fail" $ 1 `shouldNotBe` (1 :: Int)-|                             ^^^^^^^^^^^^^--1 = 1--Expected:-  ≠ 1--Got:-  1---------------------------------------------------------------------------------+╔══════════════════════════════════════════════════════════════════════════════╗+║ ./ExampleSpec.hs:5:                                                          ║+║ |                                                                            ║+║ | spec = it "should fail" $ 1 `shouldNotBe` (1 :: Int)                       ║+║ |                             ^^^^^^^^^^^^^                                  ║+║                                                                              ║+║ 1 = 1                                                                        ║+║                                                                              ║+║ Expected:                                                                    ║+║   ≠ 1                                                                        ║+║                                                                              ║+║ Got:                                                                         ║+║   1                                                                          ║+╚══════════════════════════════════════════════════════════════════════════════╝ ```  ## shouldNotSatisfy / should show helpful failure  ```-Example+./ExampleSpec.hs     should fail: FAIL----------------------------------------------------------------------------------./ExampleSpec.hs:6:-|-| spec = it "should fail" $ 1 `shouldNotSatisfy` P.gt (0 :: Int)-|                             ^^^^^^^^^^^^^^^^^^--1 > 0--Expected:-  ≯ 0--Got:-  1---------------------------------------------------------------------------------+╔══════════════════════════════════════════════════════════════════════════════╗+║ ./ExampleSpec.hs:6:                                                          ║+║ |                                                                            ║+║ | spec = it "should fail" $ 1 `shouldNotSatisfy` P.gt (0 :: Int)             ║+║ |                             ^^^^^^^^^^^^^^^^^^                             ║+║                                                                              ║+║ 1 > 0                                                                        ║+║                                                                              ║+║ Expected:                                                                    ║+║   ≯ 0                                                                        ║+║                                                                              ║+║ Got:                                                                         ║+║   1                                                                          ║+╚══════════════════════════════════════════════════════════════════════════════╝ ```  ## shouldSatisfy / should show helpful failure  ```-Example+./ExampleSpec.hs     should fail: FAIL----------------------------------------------------------------------------------./ExampleSpec.hs:6:-|-| spec = it "should fail" $ (-1) `shouldSatisfy` P.gt (0 :: Int)-|                                ^^^^^^^^^^^^^^^---1 ≯ 0---------------------------------------------------------------------------------+╔══════════════════════════════════════════════════════════════════════════════╗+║ ./ExampleSpec.hs:6:                                                          ║+║ |                                                                            ║+║ | spec = it "should fail" $ (-1) `shouldSatisfy` P.gt (0 :: Int)             ║+║ |                                ^^^^^^^^^^^^^^^                             ║+║                                                                              ║+║ -1 ≯ 0                                                                       ║+╚══════════════════════════════════════════════════════════════════════════════╝ ```  ## shows backtrace of failed assertions  ```-Example+./ExampleSpec.hs     should fail: FAIL----------------------------------------------------------------------------------./ExampleSpec.hs:6:-|-| spec = it "should fail" $ expectPositive (-1)-|                           ^^^^^^^^^^^^^^+╔══════════════════════════════════════════════════════════════════════════════╗+║ ./ExampleSpec.hs:6:                                                          ║+║ |                                                                            ║+║ | spec = it "should fail" $ expectPositive (-1)                              ║+║ |                           ^^^^^^^^^^^^^^                                   ║+║                                                                              ║+║ ./ExampleSpec.hs:9:                                                          ║+║ |                                                                            ║+║ | expectPositive = expectGT 0                                                ║+║ |                  ^^^^^^^^                                                  ║+║                                                                              ║+║ ./ExampleSpec.hs:12:                                                         ║+║ |                                                                            ║+║ | expectGT x actual = actual `shouldSatisfy` P.gt x                          ║+║ |                            ^^^^^^^^^^^^^^^                                 ║+║                                                                              ║+║ -1 ≯ 0                                                                       ║+╚══════════════════════════════════════════════════════════════════════════════╝+``` -./ExampleSpec.hs:9:-|-| expectPositive = expectGT 0-|                  ^^^^^^^^+## shows helpful error on pattern match fail -./ExampleSpec.hs:12:-|-| expectGT x actual = actual `shouldSatisfy` P.gt x-|                            ^^^^^^^^^^^^^^^+```+./ExampleSpec.hs+    should fail: ERROR+╔══════════════════════════════════════════════════════════════════════════════╗+║ ExampleSpec.hs:7:                                                            ║+║ |                                                                            ║+║ |   Just x <- pure Nothing                                                   ║+║ |   ^^^^^^                                                                   ║+║                                                                              ║+║ Pattern match failure in 'do' block                                          ║+╚══════════════════════════════════════════════════════════════════════════════╝+``` --1 ≯ 0---------------------------------------------------------------------------------+## 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)       ║+╚══════════════════════════════════════════════════════════════════════════════╝ ```

@@ -1,4 +1,4 @@-# Skeletest.Main+# test/Skeletest/MainSpec.hs  ## errors if Skeletest.Main not imported 

@@ -1,4 +1,4 @@-# Skeletest.Internal.Predicate+# test/Skeletest/PredicateSpec.hs  ## Combinators / && / shows helpful failure messages @@ -197,28 +197,29 @@ ## Data types / con / fails to compile when applied to multiple arguments  ```-<no location info>: error:-    -******************** skeletest failure ********************-P.con must be applied to exactly one argument+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  ```-<no location info>: error:-    -******************** skeletest failure ********************-P.con must be applied to a 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 non-constructor  ```-<no location info>: error:-    -******************** skeletest failure ********************-P.con must be applied to a 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@@ -250,22 +251,22 @@ ## Data types / con / shows a helpful failure message  ```-Example+./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"---------------------------------------------------------------------------------+╔══════════════════════════════════════════════════════════════════════════════╗+║ ./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

@@ -1,52 +1,54 @@-# Skeletest.Prop+# test/Skeletest/PropSpec.hs  ## === / shows a helpful failure message  ```-Example+./ExampleSpec.hs     is isomorphic: FAIL----------------------------------------------------------------------------------./ExampleSpec.hs:10:-|-|     (read . show) P.=== (+ 1) `shouldSatisfy` P.isoWith (Gen.int $ Range.linear 0 10)-|                               ^^^^^^^^^^^^^^^--Failed after 1 tests.-Rerun with --seed=0:0 to reproduce.--./ExampleSpec.hs:10:47 ==> 0--0 ≠ 1-where-  0 = (read . show) 0-  1 = (+ 1) 0---------------------------------------------------------------------------------+╔══════════════════════════════════════════════════════════════════════════════╗+║ ./ExampleSpec.hs:10:                                                         ║+║ |                                                                            ║+║ |     (read . show) P.=== (+ 1) `shouldSatisfy` P.isoWith (Gen.int $ Range.l ║+║ inear 0 10)                                                                  ║+║ |                               ^^^^^^^^^^^^^^^                              ║+║                                                                              ║+║ Failed after 1 tests.                                                        ║+║ Rerun with --seed=0:0 to reproduce.                                          ║+║                                                                              ║+║ ./ExampleSpec.hs:10:47 ==> 0                                                 ║+║                                                                              ║+║ 0 ≠ 1                                                                        ║+║ where                                                                        ║+║   0 = (read . show) 0                                                        ║+║   1 = (+ 1) 0                                                                ║+╚══════════════════════════════════════════════════════════════════════════════╝     is not isomorphic: FAIL----------------------------------------------------------------------------------./ExampleSpec.hs:12:-|-|     (read . show) P.=== id `shouldNotSatisfy` P.isoWith (Gen.int $ Range.linear 0 10)-|                            ^^^^^^^^^^^^^^^^^^--Failed after 1 tests.-Rerun with --seed=0:0 to reproduce.--./ExampleSpec.hs:12:47 ==> 0--0 = 0-where-  0 = (read . show) 0-  0 = id 0---------------------------------------------------------------------------------+╔══════════════════════════════════════════════════════════════════════════════╗+║ ./ExampleSpec.hs:12:                                                         ║+║ |                                                                            ║+║ |     (read . show) P.=== id `shouldNotSatisfy` P.isoWith (Gen.int $ Range.l ║+║ inear 0 10)                                                                  ║+║ |                            ^^^^^^^^^^^^^^^^^^                              ║+║                                                                              ║+║ Failed after 1 tests.                                                        ║+║ Rerun with --seed=0:0 to reproduce.                                          ║+║                                                                              ║+║ ./ExampleSpec.hs:12:47 ==> 0                                                 ║+║                                                                              ║+║ 0 = 0                                                                        ║+║ where                                                                        ║+║   0 = (read . show) 0                                                        ║+║   0 = id 0                                                                   ║+╚══════════════════════════════════════════════════════════════════════════════╝ ```  ## setDiscardLimit / sets discard limit  ```-Example+./ExampleSpec.hs     discards: FAIL----------------------------------------------------------------------------------Gave up after 10 discards.-Passed 0 tests.---------------------------------------------------------------------------------+╔══════════════════════════════════════════════════════════════════════════════╗+║ Gave up after 10 discards.                                                   ║+║ Passed 0 tests.                                                              ║+╚══════════════════════════════════════════════════════════════════════════════╝ ```

@@ -1,4 +1,4 @@-# Example+# test/ExampleSpec.hs  ## predicates / matches snapshots