Add support for GHC 9.12 (#32)

* Drop support for GHC 9.6 * Use __GLASGOW_HASKELL__ as Int instead of #if * Add support for GHC 9.12 * Handle exceptions explicitly, with new uncaught exception behavior * Release v0.1.1
brandonchinn178 · Dec 21, 2024 · b6a864c · b6a864c
1 parent f9c6ca8
commit b6a864c
Show file tree

Hide file tree

Showing 16 changed files with 310 additions and 245 deletions.
diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml
@@ -11,11 +11,11 @@ jobs:
     strategy:
       matrix:
         ghc_version:
-          - '9.6'
           - '9.8'
           - '9.10'
+          - '9.12'
         include:
-          - ghc_version: '9.6.1'
+          - ghc_version: '9.8.1'
             oldest: true
 
     name: build_and_test (${{ matrix.ghc_version }})

diff --git 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/cabal.project 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
@@ -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,15 +60,15 @@ 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
   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
@@ -78,7 +78,7 @@ library
     , 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 @@ 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
@@ -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/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
@@ -551,7 +553,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"
@@ -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
@@ -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
@@ -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)
 
@@ -16,9 +18,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
 
@@ -38,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