diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## v0.1.1 + +* Support Diff-1.0 +* Support GHC 9.12, drop support for GHC 9.6 + ## v0.1.0 Initial release diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,8 @@ # Skeletest +[![GitHub Actions](https://img.shields.io/github/actions/workflow/status/brandonchinn178/skeletest/ci.yml?branch=main)](https://github.com/brandonchinn178/skeletest/actions?query=branch%3Amain) +[![](https://img.shields.io/hackage/v/skeletest)](https://hackage.haskell.org/package/skeletest) + Skeletest is a batteries-included, opinionated test framework heavily inspired by [pytest](https://pytest.org) and [jest](https://jestjs.io). It's the built-in test framework for [Skelly](https://github.com/brandonchinn178/skelly), but it can be used as a standalone library as well. Features: @@ -30,18 +33,18 @@ myFunc 1 2 `shouldSatisfy` P.list [P.eq "a", P.anything, P.anything] prop "myFunc 0 x == []" $ do - x <- gen $ Gen.int (Range.linear 0 100) + x <- forAll $ Gen.int (Range.linear 0 100) myFunc 0 x `shouldBe` "" prop "myFunc x y == myFunc y x" $ do - x <- gen $ Gen.int (Range.linear 0 100) - y <- gen $ Gen.int (Range.linear 0 100) + x <- forAll $ Gen.int (Range.linear 0 100) + y <- forAll $ Gen.int (Range.linear 0 100) myFunc x y `shouldBe` myFunc y x -- top-level property that's not grouped under -- either myFunc nor otherFunc prop "myFunc x . otherFunc === id" $ do - x <- gen $ Gen.int (Range.linear 0 100) + x <- forAll $ Gen.int (Range.linear 0 100) let input = Gen.list (Range.linear 0 10) $ Gen.string (Range.linear 0 100) Gen.unicode @@ -190,7 +193,7 @@ `shouldSatisfy` is the most general function, but the others are provided for convenience. `shouldSatisfy` takes in the value being tested on the left, and a predicate on the right. Predicates should be imported from `Skeletest.Predicate`, qualified as `P`. -Some notable predicates are listed here. See the [Haddocks](https://hackage.haskell.org/package/aeson-schemas/docs/Skeletest-Predicate.html) for a full list of available predicates. +Some notable predicates are listed here. See the [Haddocks](https://hackage.haskell.org/package/skeletest/docs/Skeletest-Predicate.html) for a full list of available predicates. * `P.eq 10` * Satisfied when the actual value is equal to `10`. 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.1.0 +version: 0.1.1 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 @@ -60,25 +60,25 @@ Skeletest.Prop.Gen Skeletest.Prop.Internal Skeletest.Prop.Range - if impl(ghc >= 9.6) && impl(ghc < 9.8) - other-modules: - Skeletest.Internal.GHC.Compat_9_6 if impl(ghc >= 9.8) && impl(ghc < 9.10) other-modules: Skeletest.Internal.GHC.Compat_9_8 if impl(ghc >= 9.10) && impl(ghc < 9.12) other-modules: Skeletest.Internal.GHC.Compat_9_10 + if impl(ghc >= 9.12) && impl(ghc < 9.14) + other-modules: + Skeletest.Internal.GHC.Compat_9_12 build-depends: base < 5 , aeson , aeson-pretty , ansi-terminal >= 0.4.0 , containers - , Diff >= 0.5 + , Diff >= 1.0 , directory , filepath - , ghc ^>= 9.6 || ^>= 9.8 || ^>= 9.10 + , ghc ^>= 9.8 || ^>= 9.10 || ^>= 9.12 , hedgehog , megaparsec , ordered-containers >= 0.2.4 @@ -98,6 +98,7 @@ base , skeletest , text + , unliftio default-language: GHC2021 ghc-options: -Wall -Wcompat 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 @@ -7,14 +7,17 @@ invariantViolation, ) where -import Data.List (dropWhileEnd) import Data.Text (Text) import Data.Text qualified as Text import GHC.Utils.Panic (pgmError) -import UnliftIO.Exception (Exception (..)) +import UnliftIO.Exception (Exception (..), impureThrow) data SkeletestError - = TestInfoNotFound + = -- | A user error during compilation, e.g. during the preprocessor or plugin phases. + CompilationError Text + | -- | An error in a situation that should never happen, and indicates a bug. + InvariantViolation Text + | TestInfoNotFound | CliFlagNotFound Text | FixtureCircularDependency [Text] | SnapshotFileCorrupted FilePath @@ -23,6 +26,17 @@ instance Exception SkeletestError where displayException = Text.unpack . \case + CompilationError msg -> + Text.unlines + [ "" + , "******************** skeletest failure ********************" + , msg + ] + InvariantViolation msg -> + Text.unlines + [ "Invariant violation: " <> msg + , "**** This is a skeletest bug. Please report it at https://github.com/brandonchinn178/skeletest/issues" + ] TestInfoNotFound -> "Could not find test info" CliFlagNotFound name -> @@ -32,19 +46,10 @@ SnapshotFileCorrupted fp -> "Snapshot file was corrupted: " <> Text.pack fp --- | Throw a user error during compilation, e.g. during the preprocessor or plugin phases. skeletestPluginError :: String -> a -skeletestPluginError msg = - pgmError . dropWhileEnd (== '\n') . unlines $ - [ "" - , "******************** skeletest failure ********************" - , msg - ] +skeletestPluginError = pgmError . stripEnd . displayException . CompilationError . Text.pack + where + stripEnd = Text.unpack . Text.stripEnd . Text.pack --- | Throw an error in a situation that should never happen, and indicates a bug. invariantViolation :: String -> a -invariantViolation msg = - error . unlines $ - [ "Invariant violation: " <> msg - , "**** This is a skeletest bug. Please report it at https://github.com/brandonchinn178/skeletest/issues" - ] +invariantViolation = impureThrow . InvariantViolation . Text.pack 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 @@ -280,7 +280,7 @@ _ -> HsExprOther getRecField GHC.HsFieldBind{hfbLHS = field, hfbRHS = expr} = - (hsGhcName . GHC.foExt . unLoc $ field, goExpr 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 @@ -402,16 +402,18 @@ [ mkSigD name ty , genLoc . GHC.ValD GHC.noExtField $ GHC.FunBind GHC.noExtField (genLoc name) . GHC.MG GHC.FromSource . genLoc $ - [ genLoc $ + [ genLoc GHC.Match - GHC.noAnn - (GHC.FunRhs (genLoc name) GHC.Prefix GHC.NoSrcStrict) - pats - ( GHC.GRHSs - GHC.emptyComments - [genLoc $ GHC.GRHS GHC.noAnn [] body] - (GHC.EmptyLocalBinds GHC.noExtField) - ) + { m_ext = GHC.Compat.xMatch + , m_ctxt = GHC.Compat.mkPrefixFunRhs (genLoc name) GHC.noAnn + , m_pats = GHC.Compat.toMatchArgs pats + , m_grhss = + GHC.GRHSs + { grhssExt = GHC.emptyComments + , grhssGRHSs = [genLoc $ GHC.GRHS GHC.noAnn [] body] + , grhssLocalBinds = GHC.EmptyLocalBinds GHC.noExtField + } + } ] ] where @@ -517,9 +519,9 @@ GHC.MG origin . genLoc $ [ genLoc $ GHC.Match - { m_ext = GHC.noAnn + { m_ext = GHC.Compat.xMatch , m_ctxt = GHC.Compat.lamAltSingle - , m_pats = pats' + , m_pats = GHC.Compat.toMatchArgs pats' , m_grhss = GHC.GRHSs { grhssExt = GHC.emptyComments @@ -537,9 +539,9 @@ body' <- goExpr body pure . genLoc $ GHC.Match - { m_ext = GHC.noAnn + { m_ext = GHC.Compat.xMatch , m_ctxt = GHC.CaseAlt - , m_pats = [pat'] + , m_pats = GHC.Compat.toMatchArgs [pat'] , m_grhss = GHC.GRHSs { grhssExt = GHC.emptyComments @@ -551,7 +553,7 @@ ] pure . genLoc - . GHC.HsCase (onPsOrRn @p GHC.noAnn GHC.Compat.xCaseRn) expr' + . GHC.HsCase (onPsOrRn @p GHC.noAnn GHC.CaseAlt) expr' $ GHC.MG origin (genLoc matches') HsExprOther -> invariantViolation "Compiling HsExprOther not supported" @@ -641,11 +643,7 @@ } | (field, x) <- fields ] - pure - GHC.HsRecFields - { rec_flds = fields' - , rec_dotdot = Nothing - } + pure $ GHC.Compat.mkHsRecFields fields' where compileFieldOcc field = do name <- compileHsName field @@ -655,10 +653,7 @@ { foExt = GHC.noExtField , foLabel = genLoc name } - GHC.FieldOcc - { foExt = name - , foLabel = genLoc $ GHC.getRdrName name - } + (GHC.Compat.fieldOccRn name) genLocConLikeP :: forall p. 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 @@ -2,10 +2,10 @@ module Skeletest.Internal.GHC.Compat (module X) where -#if __GLASGOW_HASKELL__ == 906 -import Skeletest.Internal.GHC.Compat_9_6 as X -#elif __GLASGOW_HASKELL__ == 908 +#if __GLASGOW_HASKELL__ == 908 import Skeletest.Internal.GHC.Compat_9_8 as X #elif __GLASGOW_HASKELL__ == 910 import Skeletest.Internal.GHC.Compat_9_10 as X +#elif __GLASGOW_HASKELL__ == 912 +import Skeletest.Internal.GHC.Compat_9_12 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,7 +6,9 @@ ) where import Data.Data (toConstr) -import GHC +import GHC hiding (FieldOcc (..), mkPrefixFunRhs) +import GHC qualified +import GHC.Types.Name.Reader (getRdrName) import Skeletest.Internal.Error (invariantViolation) @@ -16,9 +18,6 @@ lamAltSingle :: HsMatchContext fn lamAltSingle = LamAlt LamSingle -xCaseRn :: XCase GhcRn -xCaseRn = CaseAlt - hsLit :: HsLit (GhcPass p) -> HsExpr (GhcPass p) hsLit = HsLit noExtField @@ -38,8 +37,34 @@ hsTupPresent :: LHsExpr (GhcPass p) -> HsTupArg (GhcPass p) hsTupPresent = Present noExtField +xMatch :: XCMatch (GhcPass p) b +xMatch = noAnn + +mkHsRecFields :: [LHsRecField (GhcPass p) arg] -> HsRecFields (GhcPass p) arg +mkHsRecFields fields = + GHC.HsRecFields + { rec_flds = fields + , rec_dotdot = Nothing + } + +foLabel :: GHC.FieldOcc GhcRn -> LIdP GhcRn +foLabel = genLoc . GHC.foExt + +fieldOccRn :: Name -> GHC.FieldOcc GhcRn +fieldOccRn name = + GHC.FieldOcc + { GHC.foExt = name + , GHC.foLabel = genLoc $ getRdrName name + } + hsApp :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p) hsApp = HsApp noExtField -genLoc :: (NoAnn ann) => e -> GenLocated (EpAnn ann) e +genLoc :: (NoAnn ann) => e -> GenLocated ann e genLoc = L noAnn + +mkPrefixFunRhs :: fn -> [ann] -> HsMatchContext fn +mkPrefixFunRhs fn _ = GHC.mkPrefixFunRhs fn + +toMatchArgs :: [LPat p] -> [LPat p] +toMatchArgs = id diff --git a/src/Skeletest/Internal/GHC/Compat_9_12.hs b/src/Skeletest/Internal/GHC/Compat_9_12.hs new file mode 100644 --- /dev/null +++ b/src/Skeletest/Internal/GHC/Compat_9_12.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} + +module Skeletest.Internal.GHC.Compat_9_12 ( + module Skeletest.Internal.GHC.Compat_9_12, + mkPrefixFunRhs, +) where + +import Data.Data (toConstr) +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) +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 + } + +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 diff --git a/src/Skeletest/Internal/GHC/Compat_9_6.hs b/src/Skeletest/Internal/GHC/Compat_9_6.hs deleted file mode 100644 --- a/src/Skeletest/Internal/GHC/Compat_9_6.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - -module Skeletest.Internal.GHC.Compat_9_6 ( - module Skeletest.Internal.GHC.Compat_9_6, -) where - -import Data.Data (toConstr) -import GHC -import GHC.Types.SrcLoc - -import Skeletest.Internal.Error (invariantViolation) - -hsLamSingle :: MatchGroup (GhcPass p) (LHsExpr (GhcPass p)) -> HsExpr (GhcPass p) -hsLamSingle = HsLam noExtField - -lamAltSingle :: HsMatchContext fn -lamAltSingle = LambdaExpr - -xCaseRn :: XCase GhcRn -xCaseRn = noExtField - -hsLit :: HsLit (GhcPass p) -> HsExpr (GhcPass p) -hsLit = HsLit noAnn - -hsPar :: LHsExpr (GhcPass p) -> HsExpr (GhcPass p) -hsPar e = HsPar noAnn (L NoTokenLoc HsTok) e (L NoTokenLoc HsTok) - -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 noAnn - -hsApp :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p) -hsApp = HsApp noAnn - -genLoc :: e -> GenLocated (SrcAnn ann) e -genLoc = L (SrcSpanAnn noAnn generatedSrcSpan) 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,7 +5,9 @@ ) where import Data.Data (toConstr) -import GHC +import GHC hiding (FieldOcc (..), mkPrefixFunRhs) +import GHC qualified +import GHC.Types.Name.Reader (getRdrName) import GHC.Types.SrcLoc import Skeletest.Internal.Error (invariantViolation) @@ -16,9 +18,6 @@ lamAltSingle :: HsMatchContext fn lamAltSingle = LambdaExpr -xCaseRn :: XCase GhcRn -xCaseRn = CaseAlt - hsLit :: HsLit (GhcPass p) -> HsExpr (GhcPass p) hsLit = HsLit noAnn @@ -33,8 +32,34 @@ hsTupPresent :: LHsExpr (GhcPass p) -> HsTupArg (GhcPass p) hsTupPresent = Present noAnn +xMatch :: XCMatch (GhcPass p) b +xMatch = noAnn + +mkHsRecFields :: [LHsRecField (GhcPass p) arg] -> HsRecFields (GhcPass p) arg +mkHsRecFields fields = + GHC.HsRecFields + { rec_flds = fields + , rec_dotdot = Nothing + } + +foLabel :: GHC.FieldOcc GhcRn -> LIdP GhcRn +foLabel = genLoc . GHC.foExt + +fieldOccRn :: Name -> GHC.FieldOcc GhcRn +fieldOccRn name = + GHC.FieldOcc + { GHC.foExt = name + , GHC.foLabel = genLoc $ getRdrName name + } + hsApp :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> HsExpr (GhcPass p) hsApp = HsApp noAnn genLoc :: e -> GenLocated (SrcAnn ann) e genLoc = L (SrcSpanAnn noAnn generatedSrcSpan) + +mkPrefixFunRhs :: LIdP GhcPs -> EpAnn () -> HsMatchContext GhcPs +mkPrefixFunRhs fn _ = GHC.mkPrefixFunRhs fn + +toMatchArgs :: [LPat p] -> [LPat p] +toMatchArgs = id 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 @@ -12,9 +12,10 @@ import Data.Text qualified as Text import System.Directory (doesDirectoryExist, listDirectory) import System.FilePath (makeRelative, splitExtensions, takeDirectory, ()) +import UnliftIO.Exception (throwIO) import Skeletest.Internal.Constants (mainFileSpecsListIdentifier) -import Skeletest.Internal.Error (skeletestPluginError) +import Skeletest.Internal.Error (SkeletestError (..)) -- | Preprocess the given Haskell file. See Main.hs processFile :: FilePath -> Text -> IO Text @@ -51,10 +52,10 @@ updateMainFile :: FilePath -> Text -> IO Text updateMainFile path file = do modules <- findTestModules path - pure - . addSpecsList modules - . insertImports modules - $ file + either throwIO pure $ + pure file + >>= insertImports modules + >>= pure . addSpecsList modules -- | Find all test modules using the given path to the Main module. -- @@ -99,12 +100,12 @@ renderSpecInfo (fp, name, spec) = "(" <> fp <> ", " <> name <> ", " <> spec <> ")" -- | Add imports after the Skeletest.Main import, which should always be present in the Main module. -insertImports :: [(FilePath, Text)] -> Text -> Text +insertImports :: [(FilePath, Text)] -> Text -> Either SkeletestError Text insertImports testModules file = let (pre, post) = break isSkeletestImport $ Text.lines file in if null post - then skeletestPluginError "Could not find Skeletest.Main import in Main module" - else Text.unlines $ pre <> importTests <> post + then Left $ CompilationError "Could not find Skeletest.Main import in Main module" + else pure . Text.unlines $ pre <> importTests <> post where isSkeletestImport line = case Text.words line of 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 @@ -2,7 +2,8 @@ showLineDiff, ) where -import Data.Algorithm.DiffContext (getContextDiffNew, prettyContextDiff) +import Data.Algorithm.DiffContext (getContextDiff, prettyContextDiff) +import Data.Algorithm.DiffContext qualified as Diff import Data.Text (Text) import Data.Text qualified as Text import Text.PrettyPrint qualified as PP @@ -10,7 +11,7 @@ showLineDiff :: (Text, Text) -> (Text, Text) -> Text showLineDiff (fromName, fromContent) (toName, toContent) = Text.pack . PP.render $ - prettyContextDiff (ppText fromName) (ppText toName) ppText $ - getContextDiffNew (Just 5) (Text.lines fromContent) (Text.lines toContent) + prettyContextDiff (ppText fromName) (ppText toName) (ppText . Diff.unnumber) $ + getContextDiff (Just 5) (Text.lines fromContent) (Text.lines toContent) where ppText = PP.text . Text.unpack 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-| A preprocessor that registers skeletest in a test suite. @@ -18,14 +19,19 @@ -} module Main where +import Data.List (dropWhileEnd) import Data.Text.IO qualified as Text import GHC.IO.Encoding (setLocaleEncoding, utf8) import System.Environment (getArgs) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) +import UnliftIO.Exception (displayException, handle) +import Skeletest.Internal.Error (SkeletestError) import Skeletest.Internal.Preprocessor (processFile) main :: IO () -main = do +main = handleErrors $ do -- just to be extra sure we don't run into encoding issues setLocaleEncoding utf8 @@ -33,3 +39,13 @@ -- https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/phases.html#options-affecting-a-haskell-pre-processor [fp, input, output] -> Text.readFile input >>= processFile fp >>= Text.writeFile output _ -> error "The skeletest preprocessor does not accept any additional arguments." + +-- | Output SkeletestError +handleErrors :: IO a -> IO a +handleErrors = handle $ \(e :: SkeletestError) -> do + hPutStrLn stderr $ normalizeLines $ displayException e + exitFailure + where + normalizeLines + | __GLASGOW_HASKELL__ == (908 :: Int) = dropWhileEnd (== '\n') + | otherwise = id 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 @@ -33,7 +33,7 @@ Result differed from snapshot. Update snapshot with --update. --- expected +++ actual -@@ +@@ -1,4 +1,4 @@ +new1 same1 -old1 diff --git a/test/Skeletest/MainSpec.hs b/test/Skeletest/MainSpec.hs --- a/test/Skeletest/MainSpec.hs +++ b/test/Skeletest/MainSpec.hs @@ -57,27 +57,18 @@ , "spec = it \"should run\" $ pure ()" ] -normalizePluginError, normalizeGhc29916 :: String -> String -#if __GLASGOW_HASKELL__ == 906 -normalizePluginError = - Text.unpack - . Text.replace (Text.pack "*** Exception: ExitFailure 1") (Text.pack "\n*** Exception: ExitFailure 1") - . Text.pack -normalizeGhc29916 = - Text.unpack - . Text.replace (Text.pack "error:\n") (Text.pack "error: [GHC-29916]\n") - . Text.replace (Text.pack "") (Text.pack "") - . Text.pack -#elif __GLASGOW_HASKELL__ == 908 -normalizePluginError = - Text.unpack - . Text.replace (Text.pack "*** Exception: ExitFailure 1") (Text.pack "\n*** Exception: ExitFailure 1") - . Text.pack -normalizeGhc29916 = - Text.unpack - . Text.replace (Text.pack "") (Text.pack "") - . Text.pack -#else -normalizePluginError = Text.unpack . Text.pack -normalizeGhc29916 = Text.unpack . Text.pack -#endif +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 + +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 diff --git a/test/Skeletest/PredicateSpec.hs b/test/Skeletest/PredicateSpec.hs --- a/test/Skeletest/PredicateSpec.hs +++ b/test/Skeletest/PredicateSpec.hs @@ -395,116 +395,59 @@ c : cs -> c : go cs normalizeConFailure :: String -> String -#if __GLASGOW_HASKELL__ == 906 -normalizeConFailure = Text.unpack . Text.replace old new . Text.pack - where - old = - Text.pack . unlines $ - [ "ExampleSpec.hs:9:3: error:" - , " • The constructor ‘User’ should have 2 arguments, but has been given 1" - , " • 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 $ - [ "ExampleSpec.hs:9:3: error: [GHC-27346]" - , " • The data constructor ‘User’ should have 2 arguments, but has been given 1" - , " • In the pattern: User x0" - , " In the pattern: Just (User x0)" - , " In a case alternative:" - , " Just (User x0)" - , " -> Just" - , " (Skeletest.Internal.Utils.HList.HCons" - , " (pure x0) Skeletest.Internal.Utils.HList.HNil)" - ] -#elif __GLASGOW_HASKELL__ == 908 -normalizeConFailure = Text.unpack . Text.replace old new . Text.pack +normalizeConFailure = Text.unpack . go . Text.pack where - 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)" - ] -#else -normalizeConFailure = Text.unpack . Text.pack -#endif + 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/__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 @@ -3,7 +3,6 @@ ## errors if Skeletest.Main not imported ``` -skeletest-preprocessor: ******************** skeletest failure ******************** Could not find Skeletest.Main import in Main module