diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index d6b8eed..e9fdee4 100644 --- a/.github/workflows/build.yml +++ b/.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, diff --git a/logbook.md b/logbook.md index 70ed45c..ebf4707 100644 --- a/logbook.md +++ b/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 diff --git a/src/Seminal/Compiler/API.hs b/src/Seminal/Compiler/API.hs index 82aed19..2e90d29 100644 --- a/src/Seminal/Compiler/API.hs +++ b/src/Seminal/Compiler/API.hs @@ -1,6 +1,7 @@ {-# 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 @@ -8,7 +9,8 @@ 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 \ No newline at end of file diff --git a/src/Seminal/Compiler/Runner.hs b/src/Seminal/Compiler/Runner.hs index 08cb51d..e847fc3 100644 --- a/src/Seminal/Compiler/Runner.hs +++ b/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) diff --git a/src/Seminal/Enumerator/Bindings.hs b/src/Seminal/Enumerator/Bindings.hs index 79b628f..0c574b6 100644 --- a/src/Seminal/Enumerator/Bindings.hs +++ b/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 _ _ = [] diff --git a/src/Seminal/Enumerator/Expressions.hs b/src/Seminal/Enumerator/Expressions.hs index cce4c01..72c4e27 100644 --- a/src/Seminal/Enumerator/Expressions.hs +++ b/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) diff --git a/src/Seminal/Enumerator/Modules.hs b/src/Seminal/Enumerator/Modules.hs index 8eb6433..a9a3a75 100644 --- a/src/Seminal/Enumerator/Modules.hs +++ b/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) diff --git a/src/Seminal/Enumerator/Types.hs b/src/Seminal/Enumerator/Types.hs index b1689ad..a56b4e0 100644 --- a/src/Seminal/Enumerator/Types.hs +++ b/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 [] diff --git a/test/TestSeminal.hs b/test/TestSeminal.hs index 6e8d897..4f76d85 100644 --- a/test/TestSeminal.hs +++ b/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