Make it compile with all supported GHC versions

Author: ozkutuk

ghcide/src/Development/IDE/GHC/Compat/Core.hs

@@ -253,6 +253,7 @@ module Development.IDE.GHC.Compat.Core (
     SrcLoc.noSrcSpan,
     SrcLoc.noSrcLoc,
     SrcLoc.noLoc,
+    SrcLoc.mapLoc,
     -- * Finder
     FindResult(..),
     mkHomeModLocation,
@@ -461,6 +462,18 @@ module Development.IDE.GHC.Compat.Core (
     module GHC.Unit.Finder.Types,
     module GHC.Unit.Env,
     module GHC.Driver.Phases,
+#endif
+# if !MIN_VERSION_ghc(9,4,0)
+    pattern HsFieldBind,
+    hfbAnn,
+    hfbLHS,
+    hfbRHS,
+    hfbPun,
+#endif
+#if !MIN_VERSION_ghc_boot_th(9,4,1)
+    Extension(.., NamedFieldPuns),
+#else
+    Extension(..)
 #endif
     ) where
 
@@ -710,12 +723,12 @@ import           TcRnMonad                    hiding (Applicative (..), IORef,
                                                allM, anyM, concatMapM, foldrM,
                                                mapMaybeM, (<$>))
 import           TcRnTypes
-import           TcType                       
+import           TcType
 import qualified TcType
 import           TidyPgm                     as GHC
 import qualified TyCoRep
 import           TyCon
-import           Type                         
+import           Type
 import           TysPrim
 import           TysWiredIn
 import           Unify
@@ -755,6 +768,11 @@ import qualified GHC.Driver.Finder as GHC
 import qualified Finder as GHC
 #endif
 
+-- NOTE(ozkutuk): Cpp clashes Phase.Cpp, so we hide it.
+-- Not the greatest solution, but gets the job done
+-- (until the CPP extension is actually needed).
+import GHC.LanguageExtensions.Type hiding (Cpp)
+
 
 mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO Module.ModLocation
 #if MIN_VERSION_ghc(9,3,0)
@@ -1101,3 +1119,21 @@ driverNoStop =
 hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
 hscUpdateHPT k session = session { hsc_HPT = k (hsc_HPT session) }
 #endif
+
+#if !MIN_VERSION_ghc(9,2,0)
+match :: HsRecField' id arg -> ((), id, arg, Bool)
+match (HsRecField lhs rhs pun) = ((), SrcLoc.unLoc lhs, rhs, pun)
+
+pattern HsFieldBind :: () -> id -> arg -> Bool -> HsRecField' id arg
+pattern HsFieldBind {hfbAnn, hfbLHS, hfbRHS, hfbPun} <- (match -> (hfbAnn, hfbLHS, hfbRHS, hfbPun)) where
+  HsFieldBind _ lhs rhs pun = HsRecField (SrcLoc.noLoc lhs) rhs pun
+#elif !MIN_VERSION_ghc(9,4,0)
+pattern HsFieldBind :: XHsRecField id -> id -> arg -> Bool -> HsRecField' id arg
+pattern HsFieldBind {hfbAnn, hfbLHS, hfbRHS, hfbPun} <- HsRecField hfbAnn (SrcLoc.unLoc -> hfbLHS) hfbRHS hfbPun where
+  HsFieldBind ann lhs rhs pun = HsRecField ann (SrcLoc.noLoc lhs) rhs pun
+#endif
+
+#if !MIN_VERSION_ghc_boot_th(9,4,1)
+pattern NamedFieldPuns :: Extension
+pattern NamedFieldPuns = RecordPuns
+#endif

plugins/hls-explicit-record-fields-plugin/src/Ide/Plugin/ExplicitFields.hs

@@ -38,12 +38,13 @@ import           Development.IDE.GHC.Compat      (HasSrcSpan (..),
                                                   HsRecFields (..), HscEnv (..),
                                                   LPat, Outputable, SrcSpan,
                                                   pm_mod_summary, unLoc)
-import           Development.IDE.GHC.Compat.Core (GenLocated (..), GhcPass (..),
+import           Development.IDE.GHC.Compat.Core (Extension (NamedFieldPuns),
+                                                  GhcPass (..),
                                                   HsExpr (RecordCon, rcon_flds),
-                                                  HsRecField' (..), LHsExpr,
-                                                  ModSummary (..), Pass (..),
-                                                  Pat (..), extensionFlags,
-                                                  hs_valds)
+                                                  LHsExpr, ModSummary (..),
+                                                  Pass (..), Pat (..),
+                                                  extensionFlags, hfbPun,
+                                                  hs_valds, mapLoc)
 import           Development.IDE.GHC.Compat.Util (toList)
 import           Development.IDE.GHC.Util        (printOutputable)
 import           Development.IDE.Graph           (RuleResult)
@@ -53,7 +54,6 @@ import           Development.IDE.Spans.Pragmas   (NextPragmaInfo (..),
                                                   insertNewPragma)
 import           Development.IDE.Types.Logger    (cmapWithPrio)
 import           GHC.Generics                    (Generic)
-import           GHC.LanguageExtensions.Type     (Extension (..))
 import           Ide.PluginUtils                 (getNormalizedFilePath,
                                                   handleMaybeM, pluginResponse,
                                                   subRange)
@@ -79,31 +79,26 @@ import qualified Language.LSP.Types.Lens         as L
 -- the records that originally had wildcards with dots, even after they
 -- are removed by the renamer pass. Here `rec_dotdot` is set to
 -- `Nothing` so that fields are printed without such post-processing.
-preprocessRecord :: HsRecFields p arg -> HsRecFields p arg
+preprocessRecord :: HsRecFields (GhcPass c) arg -> HsRecFields (GhcPass c) arg
 preprocessRecord flds = flds { rec_dotdot = Nothing , rec_flds = rec_flds' }
   where
-    -- TODO(ozkutuk): HsRecField' is renamed to HsFieldBind in GHC 9.4
-    -- Add it as a pattern synonym to the ghcide compat module, so it would
-    -- work on all HLS builds.
-    -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5757
-
     no_pun_count = maybe (length (rec_flds flds)) unLoc (rec_dotdot flds)
     -- Field binds of the explicit form (e.g. `{ a = a' }`) should be
     -- left as is, hence the split.
     (no_puns, puns) = splitAt no_pun_count (rec_flds flds)
     -- `hsRecPun` is set to `True` in order to pretty-print the fields as field
     -- puns (since there is similar mechanism in the `Outputable` instance as
     -- explained above).
-    puns' = map (\(L ss fld) -> L ss (fld { hsRecPun = True })) puns
+    puns' = map (mapLoc (\fld -> fld { hfbPun = True })) puns
     rec_flds' = no_puns <> puns'
 
-showRecordPat :: Outputable (Pat p) => Pat p -> Maybe Text
+showRecordPat :: Outputable (Pat (GhcPass c)) => Pat (GhcPass c) -> Maybe Text
 showRecordPat pat@(ConPat _ _ (RecCon flds)) =
   Just $ printOutputable $
     pat { pat_args = RecCon (preprocessRecord flds) }
 showRecordPat _ = Nothing
 
-showRecordCon :: Outputable (HsExpr p) => HsExpr p -> Maybe Text
+showRecordCon :: Outputable (HsExpr (GhcPass c)) => HsExpr (GhcPass c) -> Maybe Text
 showRecordCon expr@(RecordCon _ _ flds) =
   Just $ printOutputable $
     expr { rcon_flds = preprocessRecord flds }
@@ -239,14 +234,14 @@ codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = pluginRes
         mkTextEdit :: RenderedRecordInfo -> Maybe TextEdit
         mkTextEdit (RenderedRecordInfo ss r) = TextEdit <$> srcSpanToRange ss <*> pure r
 
-        -- TODO(ozkutuk): `RecordPuns` extension is renamed to `NamedFieldPuns`
-        -- in GHC 9.4, so I probably need to add this to the compat module as
-        -- well.
+        -- NOTE(ozkutuk): `RecordPuns` extension is renamed to `NamedFieldPuns`
+        -- in GHC 9.4, but we still want to insert `NamedFieldPuns` in pre-9.4
+        -- GHC as well, hence the replacement.
         -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6156
         pragmaEdit :: Maybe TextEdit
-        pragmaEdit = if RecordPuns `elem` exts
+        pragmaEdit = if NamedFieldPuns `elem` exts
                        then Nothing
-                       else Just $ patchExtName $ insertNewPragma pragma RecordPuns
+                       else Just $ patchExtName $ insertNewPragma pragma NamedFieldPuns
           where
             patchExtName = L.newText %~ T.replace "Record" "NamedField"
 
@@ -257,7 +252,7 @@ codeActionProvider ideState pId (CodeActionParams _ _ docId range _) = pluginRes
 
 mkCodeActionTitle :: [Extension] -> Text
 mkCodeActionTitle exts =
-  if RecordPuns `elem` exts
+  if NamedFieldPuns `elem` exts
     then title
     else title <> " (needs extension: NamedFieldPuns)"
     where

plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction.hs

@@ -42,7 +42,8 @@ import           Development.IDE.Core.Rules
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Service
 import           Development.IDE.Core.Shake                        hiding (Log)
-import           Development.IDE.GHC.Compat
+import           Development.IDE.GHC.Compat                        hiding
+                                                                   (ImplicitPrelude)
 import           Development.IDE.GHC.Compat.ExactPrint
 import           Development.IDE.GHC.Compat.Util
 import           Development.IDE.GHC.Error

plugins/hls-tactics-plugin/src/Wingman/EmptyCase.hs

@@ -21,7 +21,7 @@ import           Development.IDE (hscEnv, realSrcSpanToRange)
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake (IdeState (..))
 import           Development.IDE.Core.UseStale
-import           Development.IDE.GHC.Compat hiding (empty)
+import           Development.IDE.GHC.Compat hiding (empty, EmptyCase)
 import           Development.IDE.GHC.ExactPrint
 import           Development.IDE.Spans.LocalBindings (getLocalScope)
 import           Ide.Types