diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/skeletest.cabal b/skeletest.cabal --- a/skeletest.cabal +++ b/skeletest.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: skeletest -version: 0.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 diff --git a/src/Skeletest.hs b/src/Skeletest.hs --- a/src/Skeletest.hs +++ b/src/Skeletest.hs @@ -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 diff --git a/src/Skeletest/Assertions.hs b/src/Skeletest/Assertions.hs --- a/src/Skeletest/Assertions.hs +++ b/src/Skeletest/Assertions.hs @@ -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 diff --git a/src/Skeletest/Internal/CLI.hs b/src/Skeletest/Internal/CLI.hs --- a/src/Skeletest/Internal/CLI.hs +++ b/src/Skeletest/Internal/CLI.hs @@ -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 = ("--" <>) diff --git a/src/Skeletest/Internal/Capture.hs b/src/Skeletest/Internal/Capture.hs new file mode 100644 --- /dev/null +++ b/src/Skeletest/Internal/Capture.hs @@ -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 + } diff --git a/src/Skeletest/Internal/Error.hs b/src/Skeletest/Internal/Error.hs --- a/src/Skeletest/Internal/Error.hs +++ b/src/Skeletest/Internal/Error.hs @@ -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 diff --git a/src/Skeletest/Internal/Fixtures.hs b/src/Skeletest/Internal/Fixtures.hs --- a/src/Skeletest/Internal/Fixtures.hs +++ b/src/Skeletest/Internal/Fixtures.hs @@ -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) $ diff --git a/src/Skeletest/Internal/GHC.hs b/src/Skeletest/Internal/GHC.hs --- a/src/Skeletest/Internal/GHC.hs +++ b/src/Skeletest/Internal/GHC.hs @@ -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) diff --git a/src/Skeletest/Internal/GHC/Compat.hs b/src/Skeletest/Internal/GHC/Compat.hs --- a/src/Skeletest/Internal/GHC/Compat.hs +++ b/src/Skeletest/Internal/GHC/Compat.hs @@ -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 diff --git a/src/Skeletest/Internal/GHC/Compat_9_10.hs b/src/Skeletest/Internal/GHC/Compat_9_10.hs --- a/src/Skeletest/Internal/GHC/Compat_9_10.hs +++ b/src/Skeletest/Internal/GHC/Compat_9_10.hs @@ -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 [] diff --git a/src/Skeletest/Internal/GHC/Compat_9_12.hs b/src/Skeletest/Internal/GHC/Compat_9_12.hs --- a/src/Skeletest/Internal/GHC/Compat_9_12.hs +++ b/src/Skeletest/Internal/GHC/Compat_9_12.hs @@ -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 [] diff --git a/src/Skeletest/Internal/GHC/Compat_9_14.hs b/src/Skeletest/Internal/GHC/Compat_9_14.hs new file mode 100644 --- /dev/null +++ b/src/Skeletest/Internal/GHC/Compat_9_14.hs @@ -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 diff --git a/src/Skeletest/Internal/GHC/Compat_9_8.hs b/src/Skeletest/Internal/GHC/Compat_9_8.hs --- a/src/Skeletest/Internal/GHC/Compat_9_8.hs +++ b/src/Skeletest/Internal/GHC/Compat_9_8.hs @@ -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 [] diff --git a/src/Skeletest/Internal/Plugin.hs b/src/Skeletest/Internal/Plugin.hs --- a/src/Skeletest/Internal/Plugin.hs +++ b/src/Skeletest/Internal/Plugin.hs @@ -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] diff --git a/src/Skeletest/Internal/Predicate.hs b/src/Skeletest/Internal/Predicate.hs --- a/src/Skeletest/Internal/Predicate.hs +++ b/src/Skeletest/Internal/Predicate.hs @@ -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 diff --git a/src/Skeletest/Internal/Preprocessor.hs b/src/Skeletest/Internal/Preprocessor.hs --- a/src/Skeletest/Internal/Preprocessor.hs +++ b/src/Skeletest/Internal/Preprocessor.hs @@ -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] diff --git a/src/Skeletest/Internal/Snapshot.hs b/src/Skeletest/Internal/Snapshot.hs --- a/src/Skeletest/Internal/Snapshot.hs +++ b/src/Skeletest/Internal/Snapshot.hs @@ -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 [] diff --git a/src/Skeletest/Internal/Spec.hs b/src/Skeletest/Internal/Spec.hs --- a/src/Skeletest/Internal/Spec.hs +++ b/src/Skeletest/Internal/Spec.hs @@ -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. -- diff --git a/src/Skeletest/Internal/TestInfo.hs b/src/Skeletest/Internal/TestInfo.hs --- a/src/Skeletest/Internal/TestInfo.hs +++ b/src/Skeletest/Internal/TestInfo.hs @@ -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 diff --git a/src/Skeletest/Internal/TestRunner.hs b/src/Skeletest/Internal/TestRunner.hs --- a/src/Skeletest/Internal/TestRunner.hs +++ b/src/Skeletest/Internal/TestRunner.hs @@ -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 -> - ( "" - , "" - ) + 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 -> + ( "" + , "" + ) - 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 diff --git a/src/Skeletest/Internal/TestTargets.hs b/src/Skeletest/Internal/TestTargets.hs --- a/src/Skeletest/Internal/TestTargets.hs +++ b/src/Skeletest/Internal/TestTargets.hs @@ -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 = diff --git a/src/Skeletest/Internal/Utils/BoxDrawing.hs b/src/Skeletest/Internal/Utils/BoxDrawing.hs new file mode 100644 --- /dev/null +++ b/src/Skeletest/Internal/Utils/BoxDrawing.hs @@ -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 diff --git a/src/Skeletest/Internal/Utils/Diff.hs b/src/Skeletest/Internal/Utils/Diff.hs --- a/src/Skeletest/Internal/Utils/Diff.hs +++ b/src/Skeletest/Internal/Utils/Diff.hs @@ -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 diff --git a/src/Skeletest/Internal/Utils/HList.hs b/src/Skeletest/Internal/Utils/HList.hs --- a/src/Skeletest/Internal/Utils/HList.hs +++ b/src/Skeletest/Internal/Utils/HList.hs @@ -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 diff --git a/src/Skeletest/Main.hs b/src/Skeletest/Main.hs --- a/src/Skeletest/Main.hs +++ b/src/Skeletest/Main.hs @@ -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 + } diff --git a/src/Skeletest/Prop/Internal.hs b/src/Skeletest/Prop/Internal.hs --- a/src/Skeletest/Prop/Internal.hs +++ b/src/Skeletest/Prop/Internal.hs @@ -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 [("", 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 [("", 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) diff --git a/src/bin/skeletest-preprocessor.hs b/src/bin/skeletest-preprocessor.hs --- a/src/bin/skeletest-preprocessor.hs +++ b/src/bin/skeletest-preprocessor.hs @@ -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 diff --git a/test/ExampleSpec.hs b/test/ExampleSpec.hs --- a/test/ExampleSpec.hs +++ b/test/ExampleSpec.hs @@ -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 diff --git a/test/Skeletest/AssertionsSpec.hs b/test/Skeletest/AssertionsSpec.hs --- a/test/Skeletest/AssertionsSpec.hs +++ b/test/Skeletest/AssertionsSpec.hs @@ -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 diff --git a/test/Skeletest/Internal/CLISpec.hs b/test/Skeletest/Internal/CLISpec.hs --- a/test/Skeletest/Internal/CLISpec.hs +++ b/test/Skeletest/Internal/CLISpec.hs @@ -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 diff --git a/test/Skeletest/Internal/CaptureSpec.hs b/test/Skeletest/Internal/CaptureSpec.hs new file mode 100644 --- /dev/null +++ b/test/Skeletest/Internal/CaptureSpec.hs @@ -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 diff --git a/test/Skeletest/Internal/FixturesSpec.hs b/test/Skeletest/Internal/FixturesSpec.hs --- a/test/Skeletest/Internal/FixturesSpec.hs +++ b/test/Skeletest/Internal/FixturesSpec.hs @@ -2,7 +2,6 @@ import Skeletest import Skeletest.Predicate qualified as P - import Skeletest.TestUtils.Integration spec :: Spec diff --git a/test/Skeletest/Internal/SnapshotSpec.hs b/test/Skeletest/Internal/SnapshotSpec.hs --- a/test/Skeletest/Internal/SnapshotSpec.hs +++ b/test/Skeletest/Internal/SnapshotSpec.hs @@ -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 diff --git a/test/Skeletest/Internal/SpecSpec.hs b/test/Skeletest/Internal/SpecSpec.hs --- a/test/Skeletest/Internal/SpecSpec.hs +++ b/test/Skeletest/Internal/SpecSpec.hs @@ -2,7 +2,6 @@ import Skeletest import Skeletest.Predicate qualified as P - import Skeletest.TestUtils.Integration spec :: Spec diff --git a/test/Skeletest/Internal/TestTargetsSpec.hs b/test/Skeletest/Internal/TestTargetsSpec.hs --- a/test/Skeletest/Internal/TestTargetsSpec.hs +++ b/test/Skeletest/Internal/TestTargetsSpec.hs @@ -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 diff --git a/test/Skeletest/Internal/__snapshots__/CLISpec.snap.md b/test/Skeletest/Internal/__snapshots__/CLISpec.snap.md --- a/test/Skeletest/Internal/__snapshots__/CLISpec.snap.md +++ b/test/Skeletest/Internal/__snapshots__/CLISpec.snap.md @@ -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 ║ +║ ? ║ +╚══════════════════════════════════════════════════════════════════════════════╝ ``` diff --git a/test/Skeletest/Internal/__snapshots__/FixturesSpec.snap.md b/test/Skeletest/Internal/__snapshots__/FixturesSpec.snap.md --- a/test/Skeletest/Internal/__snapshots__/FixturesSpec.snap.md +++ b/test/Skeletest/Internal/__snapshots__/FixturesSpec.snap.md @@ -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 ║ +╚══════════════════════════════════════════════════════════════════════════════╝ ``` diff --git a/test/Skeletest/Internal/__snapshots__/SnapshotSpec.snap.md b/test/Skeletest/Internal/__snapshots__/SnapshotSpec.snap.md --- a/test/Skeletest/Internal/__snapshots__/SnapshotSpec.snap.md +++ b/test/Skeletest/Internal/__snapshots__/SnapshotSpec.snap.md @@ -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 ║ +╚══════════════════════════════════════════════════════════════════════════════╝ ``` diff --git a/test/Skeletest/Internal/__snapshots__/SpecSpec.snap.md b/test/Skeletest/Internal/__snapshots__/SpecSpec.snap.md --- a/test/Skeletest/Internal/__snapshots__/SpecSpec.snap.md +++ b/test/Skeletest/Internal/__snapshots__/SpecSpec.snap.md @@ -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 diff --git a/test/Skeletest/Internal/__snapshots__/TestTargetsSpec.snap.md b/test/Skeletest/Internal/__snapshots__/TestTargetsSpec.snap.md --- a/test/Skeletest/Internal/__snapshots__/TestTargetsSpec.snap.md +++ b/test/Skeletest/Internal/__snapshots__/TestTargetsSpec.snap.md @@ -1,4 +1,4 @@ -# Skeletest.Internal.TestTargets +# test/Skeletest/Internal/TestTargetsSpec.hs ## parseTestTargets / fails with a helpful error message diff --git a/test/Skeletest/MainSpec.hs b/test/Skeletest/MainSpec.hs --- a/test/Skeletest/MainSpec.hs +++ b/test/Skeletest/MainSpec.hs @@ -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 "" "" - | otherwise = id + where + replace old new = Text.replace (Text.pack old) (Text.pack new) + go + | __GLASGOW_HASKELL__ == (908 :: Int) = replace "" "" + | otherwise = id diff --git a/test/Skeletest/PredicateSpec.hs b/test/Skeletest/PredicateSpec.hs --- a/test/Skeletest/PredicateSpec.hs +++ b/test/Skeletest/PredicateSpec.hs @@ -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 diff --git a/test/Skeletest/PropSpec.hs b/test/Skeletest/PropSpec.hs --- a/test/Skeletest/PropSpec.hs +++ b/test/Skeletest/PropSpec.hs @@ -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 diff --git a/test/Skeletest/TestUtils/Integration.hs b/test/Skeletest/TestUtils/Integration.hs --- a/test/Skeletest/TestUtils/Integration.hs +++ b/test/Skeletest/TestUtils/Integration.hs @@ -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 diff --git a/test/Skeletest/__snapshots__/AssertionsSpec.snap.md b/test/Skeletest/__snapshots__/AssertionsSpec.snap.md --- a/test/Skeletest/__snapshots__/AssertionsSpec.snap.md +++ b/test/Skeletest/__snapshots__/AssertionsSpec.snap.md @@ -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) ║ +╚══════════════════════════════════════════════════════════════════════════════╝ ``` diff --git a/test/Skeletest/__snapshots__/MainSpec.snap.md b/test/Skeletest/__snapshots__/MainSpec.snap.md --- a/test/Skeletest/__snapshots__/MainSpec.snap.md +++ b/test/Skeletest/__snapshots__/MainSpec.snap.md @@ -1,4 +1,4 @@ -# Skeletest.Main +# test/Skeletest/MainSpec.hs ## errors if Skeletest.Main not imported diff --git a/test/Skeletest/__snapshots__/PredicateSpec.snap.md b/test/Skeletest/__snapshots__/PredicateSpec.snap.md --- a/test/Skeletest/__snapshots__/PredicateSpec.snap.md +++ b/test/Skeletest/__snapshots__/PredicateSpec.snap.md @@ -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 ``` -: 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 ``` -: 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 ``` -: 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 diff --git a/test/Skeletest/__snapshots__/PropSpec.snap.md b/test/Skeletest/__snapshots__/PropSpec.snap.md --- a/test/Skeletest/__snapshots__/PropSpec.snap.md +++ b/test/Skeletest/__snapshots__/PropSpec.snap.md @@ -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. ║ +╚══════════════════════════════════════════════════════════════════════════════╝ ``` diff --git a/test/__snapshots__/ExampleSpec.snap.md b/test/__snapshots__/ExampleSpec.snap.md --- a/test/__snapshots__/ExampleSpec.snap.md +++ b/test/__snapshots__/ExampleSpec.snap.md @@ -1,4 +1,4 @@ -# Example +# test/ExampleSpec.hs ## predicates / matches snapshots