Support GHC 9.6.1

.github/workflows/build.yml

@@ -11,6 +11,7 @@ jobs:
       fail-fast: false
       matrix:
         ghc-version: [
+          9.6.1,
           9.4.5,
           9.4.4,
           9.4.3,

logbook.md

@@ -179,6 +179,7 @@
 - Bump GHC Version
 - Wrap GHC's API in custom module
 - Backward support for GHC 9.2.7-9.4.4
+- Backward support for GHC 9.6.1
 
 ## Difficulties encountered
 

src/Seminal/Compiler/API.hs

@@ -1,14 +1,16 @@
 {-# LANGUAGE CPP #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 {-# HLINT ignore "Use fewer imports" #-}
+{-# LANGUAGE PatternSynonyms #-}
 -- | We want to split imports as muc has possible to use CPP preprocessors more easily
 
 -- | Import and reexport GHC's API. This is done to make transitions between GHC's version easier
 module Seminal.Compiler.API (
     GenLocated(..),
     unLoc,
     getLoc,
-    HsModule(..),
+    HsModule,
+    pattern GHCHsModule.HsModule,
     ParsedModule(..),
     Ghc,
     liftIO,
@@ -30,7 +32,6 @@ module Seminal.Compiler.API (
     depanal,
     load,
     LoadHowMuch(..),
-    Backend(..),
     DynFlags(..),
     mgModSummaries,
     GhcException(..),
@@ -99,7 +100,10 @@ module Seminal.Compiler.API (
     Extension(..),
     insert,
     throwGhcException,
-    msHsFilePath
+    msHsFilePath,
+    noBackend,
+    hsmodDecls,
+    eqSDoc,
 ) where
 
 -- | Location
@@ -130,7 +134,8 @@ import GHC.Types.SourceText (mkIntegralLit)
 import GHC.Types.SourceText (mkTHFractionalLit)
 
 -- | AST
-import GHC.Hs(HsModule(..))
+import qualified GHC.Hs as GHCHsModule(HsModule(..))
+import GHC.Hs(hsmodDecls)
 import GHC.Hs.Decls(LHsDecl)
 import GHC.Hs.Decls(HsDecl(..))
 import GHC.Hs.Decls(TyClDecl(..))
@@ -153,7 +158,9 @@ import Language.Haskell.Syntax.Lit(OverLitVal(..))
 import Language.Haskell.Syntax.Type(HsType(..))
 import Language.Haskell.Syntax.Type(HsArrow(..))
 import Language.Haskell.Syntax.Type (HsTupleSort(..))
-#if MIN_VERSION_ghc(9,4,1)
+#if MIN_VERSION_ghc(9,6,1)
+import Language.Haskell.Syntax.Concrete (HsUniToken(HsUnicodeTok))
+#elif MIN_VERSION_ghc(9,4,1)
 import Language.Haskell.Syntax.Extension (HsUniToken(HsUnicodeTok))
 #else
 import GHC.Parser.Annotation (IsUnicodeSyntax(..))
@@ -183,7 +190,11 @@ import GHC(parseModule)
 import GHC.Driver.Make(depanal)
 import GHC.Driver.Make(load)
 import GHC.Driver.Make(LoadHowMuch(..))
-import GHC.Driver.Backend(Backend(..))
+#if MIN_VERSION_ghc(9,6,1)
+import GHC.Driver.Backend(noBackend)
+#else
+import GHC.Driver.Backend(Backend(NoBackend))
+#endif
 import GHC.Driver.Session(DynFlags(..))
 import GHC.Unit.Module.Graph(mgModSummaries)
 import GHC(typecheckModule)
@@ -213,13 +224,34 @@ import GHC.Types.Name.Occurrence(mkTcOcc)
 import GHC.Types.Name.Occurrence(mkVarOcc)
 import GHC.Types.Name.Occurrence(mkDataOcc)
 
+-- | Misc
+import GHC.Plugins (PromotionFlag (NotPromoted))
+import GHC.Plugins (Boxity (Boxed))
+import GHC.LanguageExtensions (Extension(PartialTypeSignatures))
+
 -- | Pretty Print
 import GHC.Utils.Outputable(showPprUnsafe)
 import GHC.Utils.Outputable(ppr)
 import GHC.Utils.Outputable(Outputable)
 import GHC.Utils.Outputable(SDoc)
+#if MIN_VERSION_ghc(9,6,1)
+import GHC.Base(eqString)
+import GHC.Utils.Outputable(showSDocUnsafe)
+eqSDoc :: SDoc -> SDoc -> Bool
+eqSDoc a b = eqString (showSDocUnsafe a) (showSDocUnsafe b)
+#else
+eqSDoc :: SDoc -> SDoc -> Bool
+eqSDoc a b = ppr a == ppr b
+#endif
 
--- | Misc
-import GHC.Plugins (PromotionFlag (NotPromoted))
-import GHC.Plugins (Boxity (Boxed))
-import GHC.LanguageExtensions (Extension(PartialTypeSignatures))
+#if MIN_VERSION_ghc(9,6,1)
+type HsModule = GHCHsModule.HsModule GhcPs
+#else
+type HsModule = GHCHsModule.HsModule
+#endif
+
+#if MIN_VERSION_ghc(9,6,1)
+#else
+noBackend :: Backend
+noBackend = NoBackend
+#endif

src/Seminal/Compiler/Runner.hs

@@ -25,7 +25,7 @@ runCompiler filePaths action = do
             setSessionDynFlags (flags {
                 mainFunIs = Just "undefined",
                 mainModuleNameIs = mkModuleName "Prelude",
-                backend = NoBackend,
+                backend = noBackend,
                 ghcLink = NoLink,
                 maxErrors = Just 0,
                 extensionFlags = insert PartialTypeSignatures (extensionFlags flags)

src/Seminal/Enumerator/Bindings.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 module Seminal.Enumerator.Bindings (
     enumerateChangesInBinding,
     enumerateChangesInFuncBinding
@@ -13,19 +14,41 @@ import {-# SOURCE #-} Seminal.Enumerator.Matches (enumerateChangesInMatch)
 -- | Enumeration of changes for bindings, i.e. anything with an `=`
 -- See [API doc](https://hackage.haskell.org/package/ghc-9.6.1/docs/Language-Haskell-Syntax-Binds.html#t:HsBindLR)
 enumerateChangesInBinding :: Enumerator (HsBind GhcPs)
+#if MIN_VERSION_ghc(9,6,1)
+enumerateChangesInBinding (FunBind a b c) l = enumerateChangesInFuncBinding (FunBind a b c) l
+#else
 enumerateChangesInBinding (FunBind a b c d) l = enumerateChangesInFuncBinding (FunBind a b c d) l
-enumerateChangesInBinding (PatBind a (L loc pat) c d) _ = enumerateChangesInPattern pat (locA loc)
-    <&&> (L loc)
-    <&&> (\b -> PatBind a b c d)
+#endif
+#if MIN_VERSION_ghc(9,6,1)
+enumerateChangesInBinding (PatBind a (L loc pat) c) _ =
+#else
+enumerateChangesInBinding (PatBind a (L loc pat) c d) _ =
+#endif
+    enumerateChangesInPattern pat (locA loc)
+        <&&> (L loc)
+#if MIN_VERSION_ghc(9,6,1)
+        <&&> (\b -> PatBind a b c)
+#else
+        <&&> (\b -> PatBind a b c d)
+#endif
 enumerateChangesInBinding _ _ = []
 
 -- | Enumerates changes to apply on function binding, e.g. `a True = True`.
 -- One function binding groups all the matches
 -- Basically get changes for each match
 enumerateChangesInFuncBinding :: Enumerator (HsBind GhcPs)
-enumerateChangesInFuncBinding (FunBind a b (MG c1 (L la ats) c3) d) _ = concat $ splitEverywhere ats
-    <&> (\(h, L l e, t) -> let (SrcSpanAnn _ loc) = l in enumerateChangesInMatch e loc
-            <&&> (\r ->  h ++ [L l r] ++ t)
-            <&&> (\c2 -> FunBind a b (MG c1 (L la c2) c3) d)
-    )
+#if MIN_VERSION_ghc(9,6,1)
+enumerateChangesInFuncBinding (FunBind a b (MG c1 (L la ats))) _ =
+#else
+enumerateChangesInFuncBinding (FunBind a b (MG c1 (L la ats) c3) d) _ =
+#endif
+    concat $ splitEverywhere ats
+        <&> (\(h, L l e, t) -> let (SrcSpanAnn _ loc) = l in enumerateChangesInMatch e loc
+                <&&> (\r ->  h ++ [L l r] ++ t)
+#if MIN_VERSION_ghc(9,6,1)
+                <&&> (\c2 -> FunBind a b (MG c1 (L la c2)))
+#else
+                <&&> (\c2 -> FunBind a b (MG c1 (L la c2) c3) d)
+#endif
+        )
 enumerateChangesInFuncBinding _ _ = []

src/Seminal/Enumerator/Expressions.hs

@@ -184,14 +184,24 @@ enumerateChangesInExpression' expr loc = case expr of
             enumRoot = let (L lroot root) = lrootExpr in enumerateChangesInExpression root (locA lroot)
                 <&&> (L lroot)
                 <&&> (\newRoot -> HsCase xcase newRoot lmatchExpr)
-            enumMatches = let (MG xmatch (L lmatches matches) origin) = lmatchExpr in concat (splitEverywhere matches
-                <&> (\(h, L lmatch match, t) -> enumerateChangesInMatch match (locA lmatch)
-                        <&&> (L lmatch)
-                        <&&> (\newMatch -> h ++ [newMatch] ++ t)
-                        <&&> (L lmatches)
-                        <&&> (\newMatches -> MG xmatch newMatches origin)
-                        <&&> (HsCase xcase lrootExpr)
-                ))
+            enumMatches = let
+#if MIN_VERSION_ghc(9,6,1)
+                (MG xmatch (L lmatches matches)) = lmatchExpr
+#else
+                (MG xmatch (L lmatches matches) origin) = lmatchExpr
+#endif
+                in concat (splitEverywhere matches
+                    <&> (\(h, L lmatch match, t) -> enumerateChangesInMatch match (locA lmatch)
+                            <&&> (L lmatch)
+                            <&&> (\newMatch -> h ++ [newMatch] ++ t)
+                            <&&> (L lmatches)
+#if MIN_VERSION_ghc(9,6,1)
+                            <&&> (MG xmatch)
+#else
+                            <&&> (\newMatches -> MG xmatch newMatches origin)
+#endif
+                            <&&> (HsCase xcase lrootExpr)
+                    ))
     (OpApp xapp lleftExpr lopExpr lrightExpr) -> enumLeft ++ enumOp ++ enumRight
         where
             enumLeft = let (L lleft leftExpr) = lleftExpr in enumerateChangesInExpression leftExpr (locA lleft)

src/Seminal/Enumerator/Modules.hs

@@ -22,9 +22,11 @@ enumerateChangesAtModuleRoot list = concat $ splitEverywhere list <&> \(h, L l r
     in case removed of
         -- | In the case of a variable, we do not try to remove it, as it may be accompanied by a type declaration,
         -- And standalone type declaration are not allowed
-        (ValD v (FunBind a b c d)) -> enumerateChangesInFuncBinding (FunBind a b c d) removedLoc
-            <&&> (L l . ValD v)
-            <&&> (\change -> h ++ [change] ++ t)
+        (ValD v body) -> case body of
+            (FunBind {}) -> enumerateChangesInFuncBinding body removedLoc
+                <&&> (L l . ValD v)
+                <&&> (\change -> h ++ [change] ++ t)
+            _ -> []
         (TyClD x typeDecl) -> enumerateChangesInTypeDeclaration typeDecl removedLoc
             <&&> (L l . TyClD x)
             <&&> (\change -> h ++ [change] ++ t)

src/Seminal/Enumerator/Types.hs

@@ -25,7 +25,7 @@ enumerateChangeInType typ loc = (case typ of
 enumerateChangeInType' :: Enumerator (HsType GhcPs)
 enumerateChangeInType' typ loc = ioWrapping : case typ of
     (HsTyVar _ _  (L _ oldtype)) -> let
-        filteredAtomicTypes = filter (((ppr oldtype) /=) . ppr) atomicTypes
+        filteredAtomicTypes = filter ((not . eqSDoc (ppr oldtype)) . ppr) atomicTypes
         in (filteredAtomicTypes <&> (\newType ->
             Change (node typ) [node newType] loc []
             (formatMessage newType oldtype) Terminal
@@ -35,7 +35,7 @@ enumerateChangeInType' typ loc = ioWrapping : case typ of
         where
             (L lp parent) = lparent
             (L _ child) = lchild
-            filteredMonads = filter ((ppr monad /=) . ppr) topMonads
+            filteredMonads = filter ((not . eqSDoc (ppr monad)) . ppr) topMonads
             monadSubstitutions = buildType <$> filteredMonads <&> (\newM -> Change
                 (node typ) [node $ HsAppTy x (L lp newM) lchild] loc []
                 (formatMessage newM parent)
@@ -96,7 +96,7 @@ enumerateChangeInType' typ loc = ioWrapping : case typ of
                 <&> (\(h, child, t) -> enumerateChangeInType' child loc
                     <&&> (\newChild -> typeListToHsFunTy $ h ++ [newChild] ++ t))
             -- We have to remove duplicates. There is no need to run swpas on `a -> a`
-            swaps = let filteredSwaps = filter ((ppr typeList /=) . ppr) (permutations typeList) in
+            swaps = let filteredSwaps = filter ((not . eqSDoc (ppr typeList)) . ppr) (permutations typeList) in
                 filteredSwaps <&> (\newType -> Change
                     (node typ)
                     [node $ typeListToHsFunTy newType] loc []

test/TestSeminal.hs

@@ -6,6 +6,7 @@ import Test.Framework.Providers.HUnit (testCase)
 import Seminal (runSeminal, Status (..))
 import Seminal.Change (Change(..), ChangeNode(pretty))
 import Seminal.Options
+import GHC.Driver.Ppr (showPprUnsafe)
 
 buildAssetPath :: [Char] -> [Char]
 buildAssetPath filename = "test/assets/invalid/" ++ filename ++ ".hs"
@@ -27,8 +28,8 @@ testSeminal files name expectedSrc expectedExec index = do
     return $ testCase name $ case res of
         Result (_, [(_, _, changelist)]) -> let
             bestChange = changelist !! index in do
-            show (pretty (src bestChange)) @?= expectedSrc
-            show (pretty (head $ exec bestChange)) @?= expectedExec
+            showPprUnsafe (pretty (src bestChange)) @?= expectedSrc
+            showPprUnsafe (pretty (head $ exec bestChange)) @?= expectedExec
         _ -> assertFailure "Seminal Failed"
 
 testSuite :: Test