From 28bb3e726250fa0ab18b28c86bc7c715561597ef Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Sat, 21 Dec 2024 12:05:29 -0800 Subject: [PATCH 1/5] Drop support for GHC 9.6 --- .github/workflows/ci.yml | 3 +- skeletest.cabal | 5 +- src/Skeletest/Internal/GHC.hs | 2 +- src/Skeletest/Internal/GHC/Compat.hs | 4 +- src/Skeletest/Internal/GHC/Compat_9_10.hs | 3 -- src/Skeletest/Internal/GHC/Compat_9_6.hs | 40 --------------- src/Skeletest/Internal/GHC/Compat_9_8.hs | 3 -- test/Skeletest/MainSpec.hs | 12 +---- test/Skeletest/PredicateSpec.hs | 59 +---------------------- 9 files changed, 6 insertions(+), 125 deletions(-) delete mode 100644 src/Skeletest/Internal/GHC/Compat_9_6.hs diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 6c1ecf1..7134fc2 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -11,11 +11,10 @@ jobs: strategy: matrix: ghc_version: - - '9.6' - '9.8' - '9.10' include: - - ghc_version: '9.6.1' + - ghc_version: '9.8.1' oldest: true name: build_and_test (${{ matrix.ghc_version }}) diff --git a/skeletest.cabal b/skeletest.cabal index ba1611c..2152845 100644 --- a/skeletest.cabal +++ b/skeletest.cabal @@ -60,9 +60,6 @@ library 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 @@ -78,7 +75,7 @@ library , Diff >= 1.0 , directory , filepath - , ghc ^>= 9.6 || ^>= 9.8 || ^>= 9.10 + , ghc ^>= 9.8 || ^>= 9.10 , hedgehog , megaparsec , ordered-containers >= 0.2.4 diff --git a/src/Skeletest/Internal/GHC.hs b/src/Skeletest/Internal/GHC.hs index 934f4da..48dfc03 100644 --- a/src/Skeletest/Internal/GHC.hs +++ b/src/Skeletest/Internal/GHC.hs @@ -551,7 +551,7 @@ compileHsExpr = goExpr ] 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" diff --git a/src/Skeletest/Internal/GHC/Compat.hs b/src/Skeletest/Internal/GHC/Compat.hs index 77fe611..4e2ef67 100644 --- a/src/Skeletest/Internal/GHC/Compat.hs +++ b/src/Skeletest/Internal/GHC/Compat.hs @@ -2,9 +2,7 @@ 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 diff --git a/src/Skeletest/Internal/GHC/Compat_9_10.hs b/src/Skeletest/Internal/GHC/Compat_9_10.hs index 3ebb158..ee892d0 100644 --- a/src/Skeletest/Internal/GHC/Compat_9_10.hs +++ b/src/Skeletest/Internal/GHC/Compat_9_10.hs @@ -16,9 +16,6 @@ hsLamSingle = HsLam noAnn LamSingle lamAltSingle :: HsMatchContext fn lamAltSingle = LamAlt LamSingle -xCaseRn :: XCase GhcRn -xCaseRn = CaseAlt - hsLit :: HsLit (GhcPass p) -> HsExpr (GhcPass p) hsLit = HsLit noExtField diff --git a/src/Skeletest/Internal/GHC/Compat_9_6.hs b/src/Skeletest/Internal/GHC/Compat_9_6.hs deleted file mode 100644 index 8d22352..0000000 --- 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 index 2583498..e1089a3 100644 --- a/src/Skeletest/Internal/GHC/Compat_9_8.hs +++ b/src/Skeletest/Internal/GHC/Compat_9_8.hs @@ -16,9 +16,6 @@ hsLamSingle = HsLam noExtField lamAltSingle :: HsMatchContext fn lamAltSingle = LambdaExpr -xCaseRn :: XCase GhcRn -xCaseRn = CaseAlt - hsLit :: HsLit (GhcPass p) -> HsExpr (GhcPass p) hsLit = HsLit noAnn diff --git a/test/Skeletest/MainSpec.hs b/test/Skeletest/MainSpec.hs index 7ff2bd4..d015301 100644 --- a/test/Skeletest/MainSpec.hs +++ b/test/Skeletest/MainSpec.hs @@ -58,17 +58,7 @@ minimalTest name = ] 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 +#if __GLASGOW_HASKELL__ == 908 normalizePluginError = Text.unpack . Text.replace (Text.pack "*** Exception: ExitFailure 1") (Text.pack "\n*** Exception: ExitFailure 1") diff --git a/test/Skeletest/PredicateSpec.hs b/test/Skeletest/PredicateSpec.hs index 2172f4b..e390507 100644 --- a/test/Skeletest/PredicateSpec.hs +++ b/test/Skeletest/PredicateSpec.hs @@ -395,64 +395,7 @@ normalizeVars = go 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 +#if __GLASGOW_HASKELL__ == 908 normalizeConFailure = Text.unpack . Text.replace old new . Text.pack where old = From 9f3c325e7d77ab1b04e84eb3e2b36ba03a7b11d4 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Sat, 21 Dec 2024 12:09:52 -0800 Subject: [PATCH 2/5] Use __GLASGOW_HASKELL__ as Int instead of #if --- test/Skeletest/MainSpec.hs | 29 +++++---- test/Skeletest/PredicateSpec.hs | 110 ++++++++++++++++---------------- 2 files changed, 70 insertions(+), 69 deletions(-) diff --git a/test/Skeletest/MainSpec.hs b/test/Skeletest/MainSpec.hs index d015301..49929f1 100644 --- a/test/Skeletest/MainSpec.hs +++ b/test/Skeletest/MainSpec.hs @@ -57,17 +57,18 @@ minimalTest name = , "spec = it \"should run\" $ pure ()" ] -normalizePluginError, normalizeGhc29916 :: String -> String -#if __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 index e390507..7caa8b5 100644 --- a/test/Skeletest/PredicateSpec.hs +++ b/test/Skeletest/PredicateSpec.hs @@ -395,59 +395,59 @@ normalizeVars = go c : cs -> c : go cs normalizeConFailure :: String -> String -#if __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 From 25813c6390928b8845ccbb6b4b453eeb845d09cf Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Sat, 21 Dec 2024 12:10:42 -0800 Subject: [PATCH 3/5] Add support for GHC 9.12 --- .github/workflows/ci.yml | 1 + cabal.project | 24 +++++++ skeletest.cabal | 5 +- src/Skeletest/Internal/GHC.hs | 41 ++++++------ src/Skeletest/Internal/GHC/Compat.hs | 2 + src/Skeletest/Internal/GHC/Compat_9_10.hs | 32 +++++++++- src/Skeletest/Internal/GHC/Compat_9_12.hs | 77 +++++++++++++++++++++++ src/Skeletest/Internal/GHC/Compat_9_8.hs | 30 ++++++++- 8 files changed, 185 insertions(+), 27 deletions(-) create mode 100644 cabal.project create mode 100644 src/Skeletest/Internal/GHC/Compat_9_12.hs diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 7134fc2..c4043c6 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -13,6 +13,7 @@ jobs: ghc_version: - '9.8' - '9.10' + - '9.12' include: - ghc_version: '9.8.1' oldest: true diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..d2bd4e8 --- /dev/null +++ b/cabal.project @@ -0,0 +1,24 @@ +packages: . + +-- TODO: remove when packages updated for GHC 9.12 +allow-newer: + , aeson:ghc-prim + , aeson:hashable + , aeson:template-haskell + , boring:base + , hedgehog:template-haskell + , indexed-traversable:base + , indexed-traversable-instances:base + , integer-conversion:base + , recover-rtti:base + , recover-rtti:ghc-heap + , recover-rtti:ghc-prim + , scientific:base + , scientific:template-haskell + , semialign:base + , sop-core:base + , these:base + , time-compat:base + , time-compat:time + , unordered-containers:template-haskell + , uuid-types:template-haskell diff --git a/skeletest.cabal b/skeletest.cabal index 2152845..2918c7e 100644 --- a/skeletest.cabal +++ b/skeletest.cabal @@ -66,6 +66,9 @@ library 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 @@ -75,7 +78,7 @@ library , Diff >= 1.0 , directory , filepath - , ghc ^>= 9.8 || ^>= 9.10 + , ghc ^>= 9.8 || ^>= 9.10 || ^>= 9.12 , hedgehog , megaparsec , ordered-containers >= 0.2.4 diff --git a/src/Skeletest/Internal/GHC.hs b/src/Skeletest/Internal/GHC.hs index 48dfc03..581c553 100644 --- a/src/Skeletest/Internal/GHC.hs +++ b/src/Skeletest/Internal/GHC.hs @@ -280,7 +280,7 @@ parseHsExpr = goExpr _ -> 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 @@ compileFunDef funName FunDef{..} = do [ 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 @@ compileHsExpr = goExpr 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 @@ compileHsExpr = goExpr 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 @@ -641,11 +643,7 @@ compileRecFields f fields = do } | (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 @@ compileRecFields f fields = do { 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 index 4e2ef67..8cb0254 100644 --- a/src/Skeletest/Internal/GHC/Compat.hs +++ b/src/Skeletest/Internal/GHC/Compat.hs @@ -6,4 +6,6 @@ module Skeletest.Internal.GHC.Compat (module X) where 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 index ee892d0..334c26b 100644 --- a/src/Skeletest/Internal/GHC/Compat_9_10.hs +++ b/src/Skeletest/Internal/GHC/Compat_9_10.hs @@ -6,7 +6,9 @@ module Skeletest.Internal.GHC.Compat_9_10 ( ) 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) @@ -35,8 +37,34 @@ unHsPar = \case 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 index 0000000..81e9428 --- /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_8.hs b/src/Skeletest/Internal/GHC/Compat_9_8.hs index e1089a3..f44e679 100644 --- a/src/Skeletest/Internal/GHC/Compat_9_8.hs +++ b/src/Skeletest/Internal/GHC/Compat_9_8.hs @@ -5,7 +5,9 @@ module Skeletest.Internal.GHC.Compat_9_8 ( ) 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) @@ -30,8 +32,34 @@ unHsPar = \case 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 From 8816508b8fb54e6f007affbe05d1e58f205ada54 Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Sat, 21 Dec 2024 14:15:51 -0800 Subject: [PATCH 4/5] Handle exceptions explicitly, with new uncaught exception behavior --- skeletest.cabal | 1 + src/Skeletest/Internal/Error.hs | 37 +++++++++++-------- src/Skeletest/Internal/Preprocessor.hs | 17 +++++---- src/bin/skeletest-preprocessor.hs | 18 ++++++++- test/Skeletest/__snapshots__/MainSpec.snap.md | 1 - 5 files changed, 48 insertions(+), 26 deletions(-) diff --git a/skeletest.cabal b/skeletest.cabal index 2918c7e..9baa9d7 100644 --- a/skeletest.cabal +++ b/skeletest.cabal @@ -98,6 +98,7 @@ executable skeletest-preprocessor 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 index 01451d7..9bafdbd 100644 --- a/src/Skeletest/Internal/Error.hs +++ b/src/Skeletest/Internal/Error.hs @@ -7,14 +7,17 @@ module Skeletest.Internal.Error ( 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 @@ data SkeletestError 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 @@ instance Exception SkeletestError where 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/Preprocessor.hs b/src/Skeletest/Internal/Preprocessor.hs index 1ae89fe..1bb8ed5 100644 --- a/src/Skeletest/Internal/Preprocessor.hs +++ b/src/Skeletest/Internal/Preprocessor.hs @@ -12,9 +12,10 @@ import Data.Text (Text) 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 @@ isMain file = 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 @@ addSpecsList testModules file = 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/bin/skeletest-preprocessor.hs b/src/bin/skeletest-preprocessor.hs index b059167..e614ccc 100644 --- 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 @@ the code. So what we'll do here is: -} 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 @@ main = do -- 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/__snapshots__/MainSpec.snap.md b/test/Skeletest/__snapshots__/MainSpec.snap.md index 67b6e53..d7587f1 100644 --- 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 From d3f8b4b21f0d7ddf40317a358d7184857a442d7d Mon Sep 17 00:00:00 2001 From: Brandon Chinn Date: Sat, 21 Dec 2024 14:17:06 -0800 Subject: [PATCH 5/5] Release v0.1.1 --- CHANGELOG.md | 3 +++ skeletest.cabal | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f986106..8b6d86b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,9 @@ ## Unreleased +## v0.1.1 + * Support Diff-1.0 +* Support GHC 9.12, drop support for GHC 9.6 ## v0.1.0 diff --git a/skeletest.cabal b/skeletest.cabal index 9baa9d7..1143a1a 100644 --- 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