Add back-compat for GHC 9.0

Author: eddiejessup

plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs

@@ -476,7 +476,17 @@ graftDeclsWithM dst toDecls = Graft $ \dflags a -> do
     modifyDeclsT (fmap DL.toList . go) a
 
 
-class (Data ast, Default l, Typeable l, Outputable l, Outputable ast) => ASTElement l ast | ast -> l where
+-- In 9.2+, we need `Default l` to do `setPrecedingLines` on annotated elements.
+-- In older versions, we pass around annotations explicitly, so the instance isn't needed.
+class
+    ( Data ast
+    , Typeable l
+    , Outputable l
+    , Outputable ast
+#if MIN_VERSION_ghc(9,2,0)
+    , Default l
+#endif
+    ) => ASTElement l ast | ast -> l where
     parseAST :: Parser (LocatedAn l ast)
     maybeParensAST :: LocatedAn l ast -> LocatedAn l ast
     {- | Construct a 'Graft', replacing the node at the given 'SrcSpan' with

plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs

@@ -15,6 +15,7 @@
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE ViewPatterns          #-}
+{-# LANGUAGE PatternSynonyms       #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
 
@@ -51,15 +52,18 @@ import           Development.IDE.GHC.Compat.ExactPrint
 import qualified Development.IDE.GHC.Compat.Util as Util
 import           Development.IDE.GHC.ExactPrint
 import           GHC.Exts
+import           GHC.Types.SrcLoc (isRealSubspanOf)
+#if __GLASGOW_HASKELL__ >= 902
+import           GHC.Parser.Annotation (SrcSpanAnn'(..))
+import qualified GHC.Types.Error as Error
+#endif
 import           Ide.Plugin.Splice.Types
 import           Ide.Types
 import           Language.Haskell.GHC.ExactPrint (uniqueSrcSpanT)
 import           Language.LSP.Server
 import           Language.LSP.Types
 import           Language.LSP.Types.Capabilities
 import qualified Language.LSP.Types.Lens         as J
-import GHC.Hs (SrcSpanAnn'(..))
-import qualified GHC.Types.Error as Error
 
 descriptor :: PluginId -> PluginDescriptor IdeState
 descriptor plId =
@@ -264,11 +268,23 @@ adjustToRange uri ran (WorkspaceEdit mhult mlt x) =
             J.range %~ \r ->
                 if r == bad then ran else bad
 
+-- Define a pattern to get hold of a `SrcSpan` from the location part of a
+-- `GenLocated`. In GHC >= 9.2 this will be a SrcSpanAnn', with annotations;
+-- earlier it will just be a plain `SrcSpan`.
+{-# COMPLETE AsSrcSpan #-}
+#if __GLASGOW_HASKELL__ >= 902
+pattern AsSrcSpan :: SrcSpan -> SrcSpanAnn' a
+pattern AsSrcSpan locA <- SrcSpanAnn {locA}
+#else
+pattern AsSrcSpan :: SrcSpan -> SrcSpan
+pattern AsSrcSpan loc <- loc
+#endif
+
 findSubSpansDesc :: SrcSpan -> [(LHsExpr GhcTc, a)] -> [(SrcSpan, a)]
 findSubSpansDesc srcSpan =
     sortOn (Down . SubSpan . fst)
         . mapMaybe
-            ( \(L (SrcSpanAnn {locA = spn}) _, e) -> do
+            ( \(L (AsSrcSpan spn) _, e) -> do
                 guard (spn `isSubspanOf` srcSpan)
                 pure (spn, e)
             )
@@ -354,11 +370,11 @@ manualCalcEdit clientCapabilities reportEditor ran ps hscEnv typechkd srcSpan _e
                                             Right y -> unRenamedE dflags y
                                     _ -> pure Nothing
             let (warns, errs) =
-            #if __GLASGOW_HASKELL__ >= 902
+#if __GLASGOW_HASKELL__ >= 902
                                 (Error.getWarningMessages msgs, Error.getErrorMessages msgs)
-            #else
+#else
                                 msgs
-            #endif
+#endif
             pure $ (warns,) <$> fromMaybe (Left $ show errs) eresl
 
     unless
@@ -382,9 +398,15 @@ unRenamedE ::
     TransformT m (LocatedAn l (ast GhcPs))
 unRenamedE dflags expr = do
     uniq <- show <$> uniqueSrcSpanT
-    either (fail . show) pure $
+#if __GLASGOW_HASKELL__ >= 902
+    expr' <-
+#else
+    (_anns, expr') <-
+#endif
+        either (fail . show) pure $
         parseAST @_ @(ast GhcPs) dflags uniq $
             showSDoc dflags $ ppr expr
+    pure expr'
 
 data SearchResult r =
     Continue | Stop | Here r
@@ -423,13 +445,13 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $
             GenericQ (SearchResult (RealSrcSpan, SpliceContext))
         detectSplice spn =
           let
-            spanIsRelevant x = RealSrcSpan spn Nothing `isSubspanOf` x
+            realSpanIsRelevant x = spn `isRealSubspanOf` x
           in
             mkQ
                 Continue
                 ( \case
-                    (L (SrcSpanAnn {locA = l@(RealSrcSpan spLoc _)}) expr :: LHsExpr GhcPs)
-                        | spanIsRelevant l ->
+                    (L (AsSrcSpan (RealSrcSpan spLoc _)) expr :: LHsExpr GhcPs)
+                        | realSpanIsRelevant spLoc ->
                             case expr of
                                 HsSpliceE {} -> Here (spLoc, Expr)
                                 _            -> Continue
@@ -439,23 +461,23 @@ codeAction state plId (CodeActionParams _ _ docId ran _) = liftIO $
 #if __GLASGOW_HASKELL__ == 808
                     (dL @(Pat GhcPs) -> L l@(RealSrcSpan spLoc _) pat :: Located (Pat GhcPs))
 #else
-                    (L (SrcSpanAnn {locA = l@(RealSrcSpan spLoc _)}) pat :: LPat GhcPs)
+                    (L (AsSrcSpan (RealSrcSpan spLoc _)) pat :: LPat GhcPs)
 #endif
-                        | spanIsRelevant l ->
+                        | realSpanIsRelevant spLoc ->
                             case pat of
                                 SplicePat{} -> Here (spLoc, Pat)
                                 _           -> Continue
                     _ -> Stop
                 `extQ` \case
-                    (L (SrcSpanAnn {locA = l@(RealSrcSpan spLoc _)}) ty :: LHsType GhcPs)
-                        | spanIsRelevant l ->
+                    (L (AsSrcSpan (RealSrcSpan spLoc _)) ty :: LHsType GhcPs)
+                        | realSpanIsRelevant spLoc ->
                             case ty of
                                 HsSpliceTy {} -> Here (spLoc, HsType)
                                 _             -> Continue
                     _ -> Stop
                 `extQ` \case
-                    (L (SrcSpanAnn {locA = l@(RealSrcSpan spLoc _)}) decl :: LHsDecl GhcPs)
-                        | spanIsRelevant l ->
+                    (L (AsSrcSpan (RealSrcSpan spLoc _)) decl :: LHsDecl GhcPs)
+                        | realSpanIsRelevant spLoc ->
                             case decl of
                                 SpliceD {} -> Here (spLoc, HsDecl)
                                 _          -> Continue