From 1e5244e4025302e8b028d02714682185f1f4b626 Mon Sep 17 00:00:00 2001 From: Claudio Bley Date: Wed, 13 Sep 2023 12:17:53 +0200 Subject: [PATCH] Support GHC 9.6 --- src/GHC/SourceGen/Binds.hs | 4 ++ src/GHC/SourceGen/Binds/Internal.hs | 12 +++++- src/GHC/SourceGen/Decl.hs | 31 ++++++++++++-- src/GHC/SourceGen/Expr.hs | 15 +++++-- src/GHC/SourceGen/Module.hs | 61 ++++++++++++++++++++++++---- src/GHC/SourceGen/Overloaded.hs | 11 ++++- src/GHC/SourceGen/Pat.hs | 10 ++++- src/GHC/SourceGen/Syntax/Internal.hs | 2 +- 8 files changed, 127 insertions(+), 19 deletions(-) diff --git a/src/GHC/SourceGen/Binds.hs b/src/GHC/SourceGen/Binds.hs index 4137c46..b4e7e9e 100644 --- a/src/GHC/SourceGen/Binds.hs +++ b/src/GHC/SourceGen/Binds.hs @@ -106,7 +106,9 @@ funBindsWithFixity fixity name matches = bindB $ withPlaceHolder WpHole #endif ) +#if !MIN_VERSION_ghc(9,6,0) [] +#endif where name' = valueRdrName $ unqual name occ = valueOccName name @@ -189,7 +191,9 @@ patBindGRHSs p g = $ withPlaceHolder (withPlaceHolder (withEpAnnNotUsed PatBind (builtPat p) (mkGRHSs g))) +#if !MIN_VERSION_ghc(9,6,0) $ ([],[]) +#endif -- | Defines a pattern binding without any guards. -- diff --git a/src/GHC/SourceGen/Binds/Internal.hs b/src/GHC/SourceGen/Binds/Internal.hs index 99605cf..079dc5c 100644 --- a/src/GHC/SourceGen/Binds/Internal.hs +++ b/src/GHC/SourceGen/Binds/Internal.hs @@ -24,6 +24,7 @@ import PlaceHolder (PlaceHolder(..)) import GHC.SourceGen.Pat.Internal (parenthesize) import GHC.SourceGen.Syntax.Internal +import GHC (noExtField, NoExtField (NoExtField)) -- | A binding definition inside of a @let@ or @where@ clause. -- @@ -83,12 +84,19 @@ data RawGRHSs = RawGRHSs matchGroup :: HsMatchContext' -> [RawMatch] -> MatchGroup' LHsExpr' matchGroup context matches = - noExt MG (mkLocated $ map (mkLocated . mkMatch) matches) +#if MIN_VERSION_ghc(9,6,0) + MG Generated +#else + noExt MG +#endif + matches' #if !MIN_VERSION_ghc(8,6,0) [] PlaceHolder -#endif +#elif !MIN_VERSION_ghc(9,6,0) Generated +#endif where + matches' = mkLocated $ map (mkLocated . mkMatch) matches mkMatch :: RawMatch -> Match' LHsExpr' mkMatch r = withEpAnnNotUsed Match context (map builtPat $ map parenthesize $ rawMatchPats r) diff --git a/src/GHC/SourceGen/Decl.hs b/src/GHC/SourceGen/Decl.hs index 35acdc0..1c76a4c 100644 --- a/src/GHC/SourceGen/Decl.hs +++ b/src/GHC/SourceGen/Decl.hs @@ -51,10 +51,20 @@ module GHC.SourceGen.Decl , patSynBind ) where +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,6,0) +import GHC.Types.SrcLoc (LayoutInfo(..)) +#endif #if MIN_VERSION_ghc(9,0,0) import GHC (LexicalFixity(Prefix)) import GHC.Data.Bag (listToBag) + +#if MIN_VERSION_ghc(9,6,0) +import GHC (GhcPs, LayoutInfo (NoLayoutInfo)) +#else +import GHC (GhcPs) import GHC.Types.SrcLoc (LayoutInfo(..)) +#endif + #else import BasicTypes (LexicalFixity(Prefix)) import Bag (listToBag) @@ -62,7 +72,6 @@ import Bag (listToBag) #if !MIN_VERSION_ghc(8,6,0) import BasicTypes (DerivStrategy(..)) #endif -import GHC (GhcPs) import GHC.Hs.Binds import GHC.Hs.Decls @@ -108,6 +117,7 @@ import GHC.SourceGen.Name import GHC.SourceGen.Name.Internal import GHC.SourceGen.Syntax.Internal import GHC.SourceGen.Type.Internal +import GHC.Hs -- | A definition that can appear in the body of a @class@ declaration. -- @@ -174,7 +184,10 @@ class' class' context name vars decls = noExt TyClD $ ClassDecl { tcdCtxt = toHsContext $ mkLocated $ map mkLocated context -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,6,0) + , tcdLayout = NoLayoutInfo + , tcdCExt = (EpAnnNotUsed, NoAnnSortKey) +#elif MIN_VERSION_ghc(9,2,0) , tcdCExt = (EpAnnNotUsed, NoAnnSortKey, NoLayoutInfo) #elif MIN_VERSION_ghc(9,0,0) , tcdCExt = NoLayoutInfo @@ -323,11 +336,23 @@ newOrDataType newOrData name vars conDecls derivs withEpAnnNotUsed DataDecl (typeRdrName $ unqual name) (mkQTyVars vars) Prefix - $ noExt HsDataDefn newOrData + $ noExt HsDataDefn +#if !MIN_VERSION_ghc(9,6,0) + newOrData +#endif cxt Nothing Nothing +#if MIN_VERSION_ghc(9,6,0) + (case newOrData of + NewType -> case conDecls of + [decl] -> NewTypeCon $ mkLocated decl + _ -> error "NewTypeCon with more than one decl" + DataType -> DataTypeCons False (map mkLocated conDecls) + ) +#else (map mkLocated conDecls) +#endif #if MIN_VERSION_ghc(9,4,0) (toHsDeriving $ map mkLocated derivs) #else diff --git a/src/GHC/SourceGen/Expr.hs b/src/GHC/SourceGen/Expr.hs index 6cded38..e506bcf 100644 --- a/src/GHC/SourceGen/Expr.hs +++ b/src/GHC/SourceGen/Expr.hs @@ -29,7 +29,11 @@ module GHC.SourceGen.Expr ) where import GHC.Hs.Expr -import GHC.Hs.Extension (GhcPs) +import GHC.Hs.Extension (GhcPs +#if MIN_VERSION_ghc(9,6,0) + , noHsTok +#endif + ) #if MIN_VERSION_ghc(9,4,0) import GHC.Hs.Pat (HsFieldBind(..), HsRecFields(..)) #else @@ -58,6 +62,7 @@ import GHC.SourceGen.Type.Internal , sigWcType , wcType ) +import GHC.Types.SourceText (SourceText(NoSourceText)) -- | An overloaded label, as used with the @OverloadedLabels@ extension. -- @@ -67,7 +72,9 @@ import GHC.SourceGen.Type.Internal overLabel :: String -> HsExpr' overLabel = hsOverLabel . fromString where -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,6,0) + hsOverLabel = withEpAnnNotUsed HsOverLabel NoSourceText +#elif MIN_VERSION_ghc(9,2,0) hsOverLabel = withEpAnnNotUsed HsOverLabel #else hsOverLabel = noExt HsOverLabel Nothing @@ -198,7 +205,9 @@ e @::@ t = ExprWithTySig (builtLoc e) (sigWcType t) -- > ===== -- > var "f" @@ var "Int" tyApp :: HsExpr' -> HsType' -> HsExpr' -#if MIN_VERSION_ghc(9,2,0) +#if MIN_VERSION_ghc(9,6,0) +tyApp e t = noExt HsAppType e' noHsTok t' +#elif MIN_VERSION_ghc(9,2,0) tyApp e t = HsAppType builtSpan e' t' #elif MIN_VERSION_ghc(8,8,0) tyApp e t = noExt HsAppType e' t' diff --git a/src/GHC/SourceGen/Module.hs b/src/GHC/SourceGen/Module.hs index 7745b6b..a2e09d3 100644 --- a/src/GHC/SourceGen/Module.hs +++ b/src/GHC/SourceGen/Module.hs @@ -26,7 +26,12 @@ module GHC.SourceGen.Module , moduleContents ) where -import GHC.Hs.ImpExp (LIEWrappedName, IEWildcard(..), IEWrappedName(..), IE(..)) +import GHC.Hs.ImpExp + ( LIEWrappedName, IEWildcard(..), IEWrappedName(..), IE(..) +#if MIN_VERSION_ghc(9,6,0) + , ImportListInterpretation (EverythingBut, Exactly), XImportDeclPass (ideclSourceText, ideclImplicit) +#endif + ) import GHC.Hs ( HsModule(..) , ImportDecl(..) @@ -35,10 +40,15 @@ import GHC.Hs #endif #if MIN_VERSION_ghc(9,2,0) , EpAnn(..) +#endif +#if MIN_VERSION_ghc(9,6,0) + , hsmodDeprecMessage, hsmodHaddockModHeader, hsmodAnn, AnnKeywordId, XModulePs (XModulePs, hsmodLayout), noAnn, LayoutInfo (NoLayoutInfo), GhcPs, XImportDeclPass (XImportDeclPass, ideclAnn), SrcSpanAnnA, noExtField #endif ) -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,6,0) import GHC.Types.SrcLoc (LayoutInfo(..)) +#endif +#if MIN_VERSION_ghc(9,0,0) import GHC.Unit.Module (IsBootInterface(..)) import GHC.Types.Name.Reader (RdrName) #else @@ -50,8 +60,11 @@ import GHC.Types.PkgQual (RawPkgQual(..)) import GHC.SourceGen.Syntax.Internal import GHC.SourceGen.Name + ( RdrNameStr, ModuleNameStr(unModuleNameStr), OccNameStr, unqual ) import GHC.SourceGen.Name.Internal import GHC.SourceGen.Lit.Internal (noSourceText) +import GHC.Types.SourceText (SourceText(NoSourceText)) +import GHC.Types.SrcLoc (GenLocated) module' :: Maybe ModuleNameStr @@ -64,13 +77,21 @@ module' name exports imports decls = HsModule , hsmodExports = fmap (mkLocated . map mkLocated) exports , hsmodImports = map mkLocated imports , hsmodDecls = fmap mkLocated decls +#if MIN_VERSION_ghc(9,6,0) + , hsmodExt = XModulePs + { hsmodAnn = noAnn + , hsmodLayout = NoLayoutInfo + , hsmodDeprecMessage = Nothing + , hsmodHaddockModHeader = Nothing } +#else , hsmodDeprecMessage = Nothing , hsmodHaddockModHeader = Nothing -#if MIN_VERSION_ghc(9,0,0) +# if MIN_VERSION_ghc(9,0,0) , hsmodLayout = NoLayoutInfo -#endif -#if MIN_VERSION_ghc(9,2,0) +# endif +# if MIN_VERSION_ghc(9,2,0) , hsmodAnn = EpAnnNotUsed +# endif #endif } @@ -87,7 +108,7 @@ as' :: ImportDecl' -> ModuleNameStr -> ImportDecl' as' d m = d { ideclAs = Just (mkLocated $ unModuleNameStr m) } import' :: ModuleNameStr -> ImportDecl' -import' m = noSourceText (withEpAnnNotUsed ImportDecl) +import' m = importDecl (mkLocated $ unModuleNameStr m) #if MIN_VERSION_ghc(9,4,0) NoRawPkgQual @@ -105,15 +126,36 @@ import' m = noSourceText (withEpAnnNotUsed ImportDecl) #else False #endif - False Nothing Nothing +#if !MIN_VERSION_ghc(9,6,0) + False +#endif + Nothing Nothing + where +#if MIN_VERSION_ghc(9,6,0) + importDecl = ImportDecl + (XImportDeclPass{ ideclAnn = EpAnnNotUsed + , ideclSourceText = NoSourceText + , ideclImplicit = False + }) +#else + importDecl = noSourceText (withEpAnnNotUsed ImportDecl) +#endif exposing :: ImportDecl' -> [IE'] -> ImportDecl' exposing d ies = d +#if MIN_VERSION_ghc(9,6,0) + { ideclImportList = Just (Exactly, mkLocated $ map mkLocated ies) } +#else { ideclHiding = Just (False, mkLocated $ map mkLocated ies) } +#endif hiding :: ImportDecl' -> [IE'] -> ImportDecl' hiding d ies = d +#if MIN_VERSION_ghc(9,6,0) + { ideclImportList = Just (EverythingBut, mkLocated $ map mkLocated ies) } +#else { ideclHiding = Just (True, mkLocated $ map mkLocated ies) } +#endif -- | Adds the @{-# SOURCE #-}@ pragma to an import. source :: ImportDecl' -> ImportDecl' @@ -150,8 +192,13 @@ thingWith n cs = withEpAnnNotUsed IEThingWith (wrappedName n) NoIEWildcard -- TODO: support "mixed" syntax with both ".." and explicit names. +#if MIN_VERSION_ghc(9,6,0) +wrappedName :: RdrNameStr -> GenLocated SrcSpanAnnA (IEWrappedName GhcPs) +wrappedName rNameStr = mkLocated (IEName noExtField $ exportRdrName rNameStr) +#else wrappedName :: RdrNameStr -> LIEWrappedName RdrName wrappedName = mkLocated . IEName . exportRdrName +#endif -- | Exports an entire module. -- diff --git a/src/GHC/SourceGen/Overloaded.hs b/src/GHC/SourceGen/Overloaded.hs index 7d3a1d5..ef486dd 100644 --- a/src/GHC/SourceGen/Overloaded.hs +++ b/src/GHC/SourceGen/Overloaded.hs @@ -22,7 +22,7 @@ import GHC.Hs.Type ( HsType(..) , HsTyVarBndr(..) ) -import GHC.Hs (IE(..), IEWrappedName(..)) +import GHC.Hs (IE(..), IEWrappedName(..), noExtField) #if !MIN_VERSION_ghc(8,6,0) import PlaceHolder(PlaceHolder(..)) #endif @@ -286,7 +286,14 @@ instance BVar HsTyVarBndr' where #endif instance Var IE' where - var n = noExt IEVar $ mkLocated $ IEName $ exportRdrName n + var n = + noExt IEVar $ mkLocated $ +#if MIN_VERSION_ghc(9,6,0) + (IEName noExtField) +#else + IEName +#endif + $ exportRdrName n instance BVar IE' where bvar = var . UnqualStr diff --git a/src/GHC/SourceGen/Pat.hs b/src/GHC/SourceGen/Pat.hs index 5f74595..9f82370 100644 --- a/src/GHC/SourceGen/Pat.hs +++ b/src/GHC/SourceGen/Pat.hs @@ -29,6 +29,9 @@ import GHC.SourceGen.Type.Internal (patSigType) #if MIN_VERSION_ghc(9,2,0) import GHC.Parser.Annotation (EpAnn(..)) #endif +#if MIN_VERSION_ghc(9,6,0) +import GHC (noHsTok) +#endif -- | A wild pattern (@_@). wildP :: Pat' @@ -40,7 +43,12 @@ wildP = noExtOrPlaceHolder WildPat -- > ===== -- > asP "a" (var "B") asP :: RdrNameStr -> Pat' -> Pat' -v `asP` p = withEpAnnNotUsed AsPat (valueRdrName v) $ builtPat $ parenthesize p +v `asP` p = + withEpAnnNotUsed AsPat (valueRdrName v) +#if MIN_VERSION_ghc(9,6,0) + noHsTok +#endif + (builtPat $ parenthesize p) -- | A pattern constructor. -- diff --git a/src/GHC/SourceGen/Syntax/Internal.hs b/src/GHC/SourceGen/Syntax/Internal.hs index a5bc7f5..e5cc569 100644 --- a/src/GHC/SourceGen/Syntax/Internal.hs +++ b/src/GHC/SourceGen/Syntax/Internal.hs @@ -290,7 +290,7 @@ type HsTyVarBndrS' = HsTyVarBndr GhcPs #endif type HsLit' = HsLit GhcPs -#if MIN_VERSION_ghc(9,0,0) +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,6,0) type HsModule' = HsModule #else type HsModule' = HsModule GhcPs