Support GHC 9.6 [large-records]

Based on: well-typed#151

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:         [email protected]
 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

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,17 +232,27 @@ 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
 #else
     , 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

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,15 +619,22 @@ 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
           , dd_ctxt    = 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)

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 (:[]))

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 $