From 26baf8a9255f2c6e2172c7bb2695db025361697b Mon Sep 17 00:00:00 2001 From: Gabriele Sales Date: Mon, 20 May 2024 22:30:55 +0200 Subject: [PATCH] Support GHC 9.6 [large-records] Based on: https://github.com/well-typed/large-records/pull/151 --- large-records/large-records.cabal | 15 +++--- .../src/Data/Record/Internal/GHC/Shim.hs | 34 ++++++++++++- .../Internal/GHC/TemplateHaskellStyle.hs | 50 ++++++++++++++++--- .../Data/Record/Internal/Plugin/Options.hs | 5 ++ large-records/src/Data/Record/Plugin.hs | 23 ++++++++- 5 files changed, 112 insertions(+), 15 deletions(-) diff --git a/large-records/large-records.cabal b/large-records/large-records.cabal index 1409ecef..79f88360 100644 --- a/large-records/large-records.cabal +++ b/large-records/large-records.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: large-records -version: 0.4 +version: 0.5 synopsis: Efficient compilation for large records, linear in the size of the record description: For many reasons, the internal code generated for modules that contain records is quadratic in the number of record @@ -16,7 +16,8 @@ author: Edsko de Vries maintainer: edsko@well-typed.com category: Generics extra-source-files: CHANGELOG.md -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.5 +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.5 || + ==9.6.5 source-repository head type: git @@ -44,15 +45,15 @@ library Data.Record.Internal.Plugin.Record build-depends: - base >= 4.13 && < 4.18 - , containers >= 0.6.2 && < 0.7 - , mtl >= 2.2.1 && < 2.3 - , primitive >= 0.8 && < 0.9 + base >= 4.13 && < 4.19 + , containers >= 0.6.2 && < 0.8 + , mtl >= 2.2.1 && < 2.4 + , primitive >= 0.8 && < 0.10 , syb >= 0.7 && < 0.8 , record-hasfield >= 1.0 && < 1.1 -- large-generics 0.2 starts using 'SmallArray' instead of 'Vector' - , large-generics >= 0.2 && < 0.3 + , large-generics >= 0.3 && < 0.4 -- transformers 0.5.6 introduces Writer.CPS , transformers >= 0.5.6 && < 0.7 diff --git a/large-records/src/Data/Record/Internal/GHC/Shim.hs b/large-records/src/Data/Record/Internal/GHC/Shim.hs index c6b555ea..e0db355e 100644 --- a/large-records/src/Data/Record/Internal/GHC/Shim.hs +++ b/large-records/src/Data/Record/Internal/GHC/Shim.hs @@ -165,6 +165,11 @@ import GHC.Types.Name.Cache (NameCache, takeUniqFromNameCache) #endif +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +import Language.Haskell.Syntax.Basic (FieldLabelString (..)) +import qualified GHC.Types.Basic +#endif + {------------------------------------------------------------------------------- Name resolution -------------------------------------------------------------------------------} @@ -227,7 +232,10 @@ lookupOrigIO env modl occ = lookupNameCache (hsc_NC env) modl occ importDecl :: ModuleName -> Bool -> LImportDecl GhcPs importDecl name qualified = noLocA $ ImportDecl { ideclExt = defExt +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +#else , ideclSourceSrc = NoSourceText +#endif , ideclName = noLocA name #if __GLASGOW_HASKELL__ >= 904 , ideclPkgQual = NoRawPkgQual @@ -235,9 +243,16 @@ importDecl name qualified = noLocA $ ImportDecl { , ideclPkgQual = Nothing #endif , ideclSafe = False +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + , ideclImportList = Nothing +#else , ideclImplicit = False +#endif , ideclAs = Nothing +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +#else , ideclHiding = Nothing +#endif #if __GLASGOW_HASKELL__ < 810 , ideclQualified = qualified #else @@ -270,7 +285,11 @@ type HsModule = GHC.HsModule GhcPs type HsModule = GHC.HsModule #endif +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +type LHsModule = Located (HsModule GhcPs) +#else type LHsModule = Located HsModule +#endif type LRdrName = Located RdrName {------------------------------------------------------------------------------- @@ -331,7 +350,16 @@ instance HasDefaultExt NoExtField where defExt = noExtField #endif -#if __GLASGOW_HASKELL__ >= 900 +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +instance HasDefaultExt (LayoutInfo GhcPs) where + defExt = NoLayoutInfo +instance HasDefaultExt XImportDeclPass where + defExt = XImportDeclPass EpAnnNotUsed NoSourceText True {- implicit -} +instance HasDefaultExt GHC.Types.Basic.Origin where + defExt = Generated +instance HasDefaultExt SourceText where + defExt = NoSourceText +#elif __GLASGOW_HASKELL__ >= 900 instance HasDefaultExt LayoutInfo where defExt = NoLayoutInfo #endif @@ -559,7 +587,11 @@ simpleRecordUpdates = isSingleLabel :: FieldLabelStrings GhcPs -> Maybe LRdrName isSingleLabel (FieldLabelStrings labels) = case labels of +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + [L _ (DotFieldOcc _ (L l (FieldLabelString label)))] -> +#else [L _ (DotFieldOcc _ (L l label))] -> +#endif Just $ reLoc $ L l (Unqual $ mkVarOccFS label) _otherwise -> Nothing diff --git a/large-records/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs b/large-records/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs index ea2a1d79..5d7f4dc9 100644 --- a/large-records/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs +++ b/large-records/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs @@ -289,7 +289,11 @@ listE es = inheritLoc es $ ExplicitList defExt lamE :: NonEmpty (LPat GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs lamE pats body = inheritLoc body $ HsLam defExt $ +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + MG defExt (inheritLoc body [inheritLoc body match]) +#else MG defExt (inheritLoc body [inheritLoc body match]) Generated +#endif where match :: Match GhcPs (LHsExpr GhcPs) match = Match defExt LambdaExpr (NE.toList pats) (simpleGHRSs body) @@ -301,7 +305,11 @@ lamE1 p = lamE (p :| []) -- | Equivalent of 'Language.Haskell.TH.Lib.caseE' caseE :: LHsExpr GhcPs -> [(LPat GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs caseE x alts = inheritLoc x $ +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + HsCase defExt x (MG defExt (inheritLoc x (map mkAlt alts))) +#else HsCase defExt x (MG defExt (inheritLoc x (map mkAlt alts)) Generated) +#endif where mkAlt :: (LPat GhcPs, LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs) mkAlt (pat, body) = inheritLoc x $ @@ -314,6 +322,9 @@ appsE = foldl' appE -- | Equivalent of 'Language.Haskell.TH.Lib.appT' appTypeE :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs appTypeE expr typ = inheritLoc expr $ +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + HsAppType noExtField expr noHsTok (HsWC defExt typ) +#else HsAppType #if __GLASGOW_HASKELL__ >= 902 (toSrcSpan expr) @@ -322,7 +333,7 @@ appTypeE expr typ = inheritLoc expr $ #endif expr (HsWC defExt typ) - +#endif -- | Equivalent of 'Language.Haskell.TH.Lib.tupE' tupE :: NonEmpty (LHsExpr GhcPs) -> LHsExpr GhcPs tupE xs = inheritLoc xs $ @@ -353,7 +364,11 @@ parensT :: LHsType GhcPs -> LHsType GhcPs parensT = noLocA . HsParTy defExt -- | Equivalent of 'Language.Haskell.TH.Lib.litT' +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +litT :: HsTyLit GhcPs -> LHsType GhcPs +#else litT :: HsTyLit -> LHsType GhcPs +#endif litT = noLocA . HsTyLit defExt -- | Equivalent of 'Language.Haskell.TH.Lib.varT' @@ -604,7 +619,10 @@ dataD typeName tyVars cons derivs = inheritLoc typeName $ , tcdFixity = Prefix , tcdDataDefn = HsDataDefn { dd_ext = defExt +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +#else , dd_ND = DataType +#endif #if __GLASGOW_HASKELL__ >= 902 , dd_ctxt = Nothing #else @@ -612,7 +630,11 @@ dataD typeName tyVars cons derivs = inheritLoc typeName $ #endif , dd_cType = Nothing , dd_kindSig = Nothing +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + , dd_cons = DataTypeCons False cons +#else , dd_cons = cons +#endif , dd_derivs = inheritLoc typeName derivs } } @@ -635,15 +657,22 @@ viewDataD , tcdTyVars = HsQTvs {hsq_explicit = tyVars} , tcdFixity = Prefix , tcdDataDefn = HsDataDefn { - dd_ND = DataType +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +#else + dd_ND = DataType, +#endif #if __GLASGOW_HASKELL__ >= 902 - , dd_ctxt = Nothing + dd_ctxt = Nothing #else , dd_ctxt = L _ [] #endif , dd_cType = Nothing , dd_kindSig = Nothing +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + , dd_cons = DataTypeCons False cons +#else , dd_cons = cons +#endif #if __GLASGOW_HASKELL__ >= 902 , dd_derivs = derivs #else @@ -746,6 +775,9 @@ classD :: classD = \ctx name clsVars sigs -> inheritLoc name $ TyClD defExt $ ClassDecl { tcdCExt = defExt +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + , tcdLayout = NoLayoutInfo +#endif #if __GLASGOW_HASKELL__ >= 902 , tcdCtxt = Just (inheritLoc name ctx) #else @@ -821,14 +853,22 @@ pattern TypeAnnotation name <- (viewTypeAnnotation -> Just name) -- | Equivalent of 'Language.Haskell.TH.Lib.pragAnnD' pragAnnD :: AnnProvenancePs -> LHsExpr GhcPs -> AnnDecl GhcPs pragAnnD prov value = +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + HsAnnotation defExt prov value +#else HsAnnotation defExt NoSourceText prov value +#endif viewPragAnnD :: AnnDecl GhcPs -> (AnnProvenancePs, LHsExpr GhcPs) +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +viewPragAnnD (HsAnnotation _ prov value) = (prov, value) +#else viewPragAnnD (HsAnnotation _ _ prov value) = (prov, value) +#endif #if __GLASGOW_HASKELL__ < 900 viewPragAnnD _ = panic "viewPragAnnD" #endif @@ -880,6 +920,4 @@ simpleGHRSs :: LHsExpr GhcPs -> GRHSs GhcPs (LHsExpr GhcPs) simpleGHRSs body = GRHSs defExt [inheritLoc body $ GRHS defExt [] body] - (inheritLoc body $ EmptyLocalBinds defExt) - - + (inheritLoc body $ EmptyLocalBinds defExt) \ No newline at end of file diff --git a/large-records/src/Data/Record/Internal/Plugin/Options.hs b/large-records/src/Data/Record/Internal/Plugin/Options.hs index c62e55dd..6b6945a9 100644 --- a/large-records/src/Data/Record/Internal/Plugin/Options.hs +++ b/large-records/src/Data/Record/Internal/Plugin/Options.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DerivingStrategies #-} @@ -67,7 +68,11 @@ instance HasField "debugLargeRecords" LargeRecordOptions Bool where -- | Extract all 'LargeRecordOptions' in a module -- -- Additionally returns the location of the ANN pragma. +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +getLargeRecordOptions :: HsModule GhcPs -> Map String [(SrcSpan, LargeRecordOptions)] +#else getLargeRecordOptions :: HsModule -> Map String [(SrcSpan, LargeRecordOptions)] +#endif getLargeRecordOptions = Map.fromListWith (++) . map (second (:[])) diff --git a/large-records/src/Data/Record/Plugin.hs b/large-records/src/Data/Record/Plugin.hs index 7ae35da3..90fecce0 100644 --- a/large-records/src/Data/Record/Plugin.hs +++ b/large-records/src/Data/Record/Plugin.hs @@ -39,6 +39,8 @@ module Data.Record.Plugin ( , plugin ) where +import Control.Monad +import Control.Monad.Trans.Class (lift) import Control.Monad.Except import Control.Monad.Trans.Writer.CPS import Data.List (intersperse) @@ -75,7 +77,10 @@ import GHC.Driver.Errors.Types (GhcMessage(GhcUnknownMessage)) import GHC.Types.Error (mkPlainError, mkMessages, mkPlainDiagnostic) import GHC.Utils.Error (mkMsgEnvelope, mkErrorMsgEnvelope) #endif - +#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) +import GHC.Types.Error (UnknownDiagnostic(..)) +import GHC.Driver.Config.Diagnostic (initPrintConfig) +#endif {------------------------------------------------------------------------------- Top-level: the plugin proper -------------------------------------------------------------------------------} @@ -213,6 +218,12 @@ issueError l errMsg = do #if __GLASGOW_HASKELL__ == 902 throwOneError $ mkErr l neverQualify (mkDecorated [errMsg]) +#elif MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + throwOneError $ + mkErrorMsgEnvelope + l + neverQualify + (GhcUnknownMessage $ UnknownDiagnostic $ mkPlainError [] errMsg) #elif __GLASGOW_HASKELL__ >= 904 throwOneError $ mkErrorMsgEnvelope @@ -232,6 +243,16 @@ issueWarning l errMsg = do logger <- getLogger liftIO $ printOrThrowWarnings logger dynFlags . bag $ mkWarnMsg l neverQualify errMsg +#elif MIN_VERSION_GLASGOW_HASKELL(9,6,0,0) + logger <- getLogger + dflags <- getDynFlags + let print_config = initPrintConfig dflags + liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dynFlags) . mkMessages . bag $ + mkMsgEnvelope + (initDiagOpts dynFlags) + l + neverQualify + (GhcUnknownMessage $ UnknownDiagnostic $ mkPlainDiagnostic WarningWithoutFlag [] errMsg) #elif __GLASGOW_HASKELL__ >= 904 logger <- getLogger liftIO $ printOrThrowDiagnostics logger (initDiagOpts dynFlags) . mkMessages . bag $