Start work on GHC 9.4 compat

Author: 9999years

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

@@ -2,9 +2,6 @@
 --   multiple ghc-exactprint versions, accepting that anything more ambitious is
 --   pretty much impossible with the GHC 9.2 redesign of ghc-exactprint
 module Development.IDE.GHC.Compat.ExactPrint
-#if MIN_VERSION_ghc(9,3,0)
-    ( ) where
-#else
     ( ExactPrint
     , exactPrint
     , makeDeltaAst
@@ -34,5 +31,3 @@ pattern Annotated {astA, annsA} <- (Retrie.astA &&& Retrie.annsA -> (astA, annsA
 pattern Annotated :: ast -> ApiAnns -> Retrie.Annotated ast
 pattern Annotated {astA, annsA} <- ((,()) . Retrie.astA -> (astA, annsA))
 #endif
-
-#endif

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

@@ -8,10 +8,10 @@ import           GHC.Hs.Dump
 import qualified Data.ByteString                       as B
 import           Development.IDE.GHC.Compat.Util
 import           Generics.SYB                          (ext1Q, ext2Q, extQ)
-import           GHC.Hs
+import           GHC.Hs                                hiding (AnnLet)
 #endif
 #if MIN_VERSION_ghc(9,0,1)
-import           GHC.Plugins
+import           GHC.Plugins                           hiding (AnnLet)
 #else
 import           GhcPlugins
 #endif
@@ -231,8 +231,13 @@ showAstDataHtml a0 = html $
             annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc
             annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase")
 
+#if MIN_VERSION_ghc(9,4,0)
+            annotationEpAnnHsLet :: EpAnn NoEpAnns -> SDoc
+            annotationEpAnnHsLet = annotation' (text "EpAnn NoEpAnns")
+#else
             annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc
             annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet")
+#endif
 
             annotationAnnList :: EpAnn AnnList -> SDoc
             annotationAnnList = annotation' (text "EpAnn AnnList")

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

@@ -3,9 +3,6 @@
 
 -- | This module hosts various abstractions and utility functions to work with ghc-exactprint.
 module Development.IDE.GHC.ExactPrint
-#if MIN_VERSION_ghc(9,3,0)
-   (  ) where
-#else
     ( Graft(..),
       graftDecls,
       graftDeclsWithM,
@@ -86,11 +83,14 @@ import           Ide.PluginUtils
 import           Language.Haskell.GHC.ExactPrint.Parsers
 import           Language.LSP.Types
 import           Language.LSP.Types.Capabilities         (ClientCapabilities)
-import           Retrie.ExactPrint                       hiding (Annotated (..),
-                                                          parseDecl, parseExpr,
+import           Retrie.ExactPrint                       hiding (parseDecl,
+                                                          parseExpr,
                                                           parsePattern,
                                                           parseType)
-#if MIN_VERSION_ghc(9,2,0)
+#if MIN_VERSION_ghc(9,9,0)
+import           GHC.Plugins                             (showSDoc)
+import           GHC.Utils.Outputable                    (Outputable (ppr))
+#elif MIN_VERSION_ghc(9,2,0)
 import           GHC                                     (EpAnn (..),
                                                           NameAdornment (NameParens),
                                                           NameAnn (..),
@@ -531,7 +531,10 @@ annotate :: (ASTElement l ast, Outputable l)
 annotate dflags needs_space ast = do
     uniq <- show <$> uniqueSrcSpanT
     let rendered = render dflags ast
-#if MIN_VERSION_ghc(9,2,0)
+#if MIN_VERSION_ghc(9,4,0)
+    expr' <- lift $ mapLeft (showSDoc dflags . ppr) $ parseAST dflags uniq rendered
+    pure expr'
+#elif MIN_VERSION_ghc(9,2,0)
     expr' <- lift $ mapLeft show $ parseAST dflags uniq rendered
     pure expr'
 #else
@@ -558,7 +561,11 @@ annotateDecl dflags
     alts' <- for alts $ \alt -> do
       uniq <- show <$> uniqueSrcSpanT
       let rendered = render dflags $ set_matches [alt]
+#if MIN_VERSION_ghc(9,4,0)
+      lift (mapLeft (showSDoc dflags . ppr) $ parseDecl dflags uniq rendered) >>= \case
+#elif MIN_VERSION_ghc(9,2,0)
       lift (mapLeft show $ parseDecl dflags uniq rendered) >>= \case
+#endif
         (L _ (ValD _ FunBind { fun_matches = MG { mg_alts = L _ [alt']}}))
            -> pure alt'
         _ ->  lift $ Left "annotateDecl: didn't parse a single FunBind match"
@@ -579,7 +586,9 @@ annotateDecl dflags
 annotateDecl dflags ast = do
     uniq <- show <$> uniqueSrcSpanT
     let rendered = render dflags ast
-#if MIN_VERSION_ghc(9,2,0)
+#if MIN_VERSION_ghc(9,4,0)
+    lift $ mapLeft (showSDoc dflags . ppr) $ parseDecl dflags uniq rendered
+#elif MIN_VERSION_ghc(9,2,0)
     lift $ mapLeft show $ parseDecl dflags uniq rendered
 #else
     (anns, expr') <- lift $ mapLeft show $ parseDecl dflags uniq rendered
@@ -663,5 +672,3 @@ isCommaAnn :: TrailingAnn -> Bool
 isCommaAnn AddCommaAnn{} = True
 isCommaAnn _             = False
 #endif
-
-#endif

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

@@ -136,12 +136,10 @@ iePluginDescriptor recorder plId =
             wrap suggestExportUnusedTopBinding
           , wrap suggestModuleTypo
           , wrap suggestFixConstructorImport
-#if !MIN_VERSION_ghc(9,3,0)
           , wrap suggestExtendImport
           , wrap suggestImportDisambiguation
           , wrap suggestNewOrExtendImportForClassMethod
           , wrap suggestHideShadow
-#endif
           , wrap suggestNewImport
           ]
           plId
@@ -153,20 +151,16 @@ typeSigsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $
       wrap $ suggestSignature True
     , wrap suggestFillTypeWildcard
     , wrap suggestAddTypeAnnotationToSatisfyContraints
-#if !MIN_VERSION_ghc(9,3,0)
     , wrap removeRedundantConstraints
     , wrap suggestConstraint
-#endif
     ]
     plId
 
 bindingsPluginDescriptor :: Recorder (WithPriority E.Log) ->  PluginId -> PluginDescriptor IdeState
 bindingsPluginDescriptor recorder plId = mkExactprintPluginDescriptor recorder $
   mkGhcideCAsPlugin [
       wrap suggestReplaceIdentifier
-#if !MIN_VERSION_ghc(9,3,0)
     , wrap suggestImplicitParameter
-#endif
     , wrap suggestNewDefinition
     , wrap suggestDeleteUnusedBinding
     ]
@@ -1030,7 +1024,6 @@ getIndentedGroupsBy pred inp = case dropWhile (not.pred) inp of
 indentation :: T.Text -> Int
 indentation = T.length . T.takeWhile isSpace
 
-#if !MIN_VERSION_ghc(9,3,0)
 suggestExtendImport :: ExportsMap -> ParsedSource -> Diagnostic -> [(T.Text, CodeActionKind, Rewrite)]
 suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_range,..}
     | Just [binding, mod, srcspan] <-
@@ -1078,7 +1071,6 @@ suggestExtendImport exportsMap (L _ HsModule {hsmodImports}) Diagnostic{_range=_
                 , parent = Nothing
                 , isDatacon = False
                 , moduleNameText = mod}
-#endif
 
 data HidingMode
     = HideOthers [ModuleTarget]

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

@@ -196,26 +196,30 @@ removeConstraint ::
 removeConstraint toRemove = go . traceAst "REMOVE_CONSTRAINT_input"
   where
     go :: LHsType GhcPs -> Rewrite
-#if !MIN_VERSION_ghc(9,2,0)
-    go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA l) $ \_ -> do
-#else
+#if MIN_VERSION_ghc(9,2,0) && !MIN_VERSION_ghc(9,4,0)
     go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt), hst_body}) = Rewrite (locA l) $ \_ -> do
+#else
+    go (L l it@HsQualTy{hst_ctxt = L l' ctxt, hst_body}) = Rewrite (locA l) $ \_ -> do
 #endif
       let ctxt' = filter (not . toRemove) ctxt
           removeStuff = (toRemove <$> headMaybe ctxt) == Just True
-#if !MIN_VERSION_ghc(9,2,0)
-      when removeStuff  $
-        setEntryDPT hst_body (DP (0, 0))
-      return $ L l $ it{hst_ctxt =  L l' ctxt'}
-#else
+#if MIN_VERSION_ghc(9,2,0)
       let hst_body' = if removeStuff then resetEntryDP hst_body else hst_body
       return $ case ctxt' of
           [] -> hst_body'
           _ -> do
             let ctxt'' = over _last (first removeComma) ctxt'
+#if MIN_VERSION_ghc(9,4,0)
+            L l $ it{ hst_ctxt = L l' ctxt''
+#else
             L l $ it{ hst_ctxt = Just $ L l' ctxt''
+#endif
                     , hst_body = hst_body'
                     }
+#else
+      when removeStuff  $
+        setEntryDPT hst_body (DP (0, 0))
+      return $ L l $ it{hst_ctxt =  L l' ctxt'}
 #endif
     go (L _ (HsParTy _ ty)) = go ty
     go (L _ HsForAllTy{hst_body}) = go hst_body
@@ -231,10 +235,12 @@ appendConstraint ::
   Rewrite
 appendConstraint constraintT = go . traceAst "appendConstraint"
  where
-#if !MIN_VERSION_ghc(9,2,0)
+#if MIN_VERSION_ghc(9,4,0)
   go (L l it@HsQualTy{hst_ctxt = L l' ctxt}) = Rewrite (locA l) $ \df -> do
-#else
+#elif MIN_VERSION_ghc(9,2,0)
   go (L l it@HsQualTy{hst_ctxt = Just (L l' ctxt)}) = Rewrite (locA l) $ \df -> do
+#else
+  go (L l it@HsQualTy{hst_ctxt = L l' ctxt}) = Rewrite (locA l) $ \df -> do
 #endif
     constraint <- liftParseAST df constraintT
 #if !MIN_VERSION_ghc(9,2,0)
@@ -258,7 +264,11 @@ appendConstraint constraintT = go . traceAst "appendConstraint"
             [L _ (HsParTy EpAnn{anns=AnnParen{ap_close}} _)] -> Just ap_close
             _ -> Nothing
         ctxt' = over _last (first addComma) $ map dropHsParTy ctxt
+#if MIN_VERSION_ghc(9,4,0)
+    return $ L l $ it{hst_ctxt = L l'' $ ctxt' ++ [constraint]}
+#else
     return $ L l $ it{hst_ctxt = Just $ L l'' $ ctxt' ++ [constraint]}
+#endif
 #endif
   go (L _ HsForAllTy{hst_body}) = go hst_body
   go (L _ (HsParTy _ ty)) = go ty
@@ -267,7 +277,16 @@ appendConstraint constraintT = go . traceAst "appendConstraint"
     constraint <- liftParseAST df constraintT
     lContext <- uniqueSrcSpanT
     lTop <- uniqueSrcSpanT
-#if !MIN_VERSION_ghc(9,2,0)
+#if MIN_VERSION_ghc(9,2,0)
+#if MIN_VERSION_ghc(9,4,0)
+    let context = reAnnL annCtxt emptyComments $ L lContext [resetEntryDP constraint]
+#else
+    let context = Just $ reAnnL annCtxt emptyComments $ L lContext [resetEntryDP constraint]
+#endif
+        annCtxt = AnnContext (Just (NormalSyntax, epl 1)) [epl 0 | needsParens] [epl 0 | needsParens]
+        needsParens = hsTypeNeedsParens sigPrec $ unLoc constraint
+    ast <- pure $ setEntryDP ast (SameLine 1)
+#else
     let context = L lContext [constraint]
     addSimpleAnnT context dp00 $
       (G AnnDarrow, DP (0, 1)) :
@@ -277,11 +296,6 @@ appendConstraint constraintT = go . traceAst "appendConstraint"
           ]
         | hsTypeNeedsParens sigPrec $ unLoc constraint
         ]
-#else
-    let context = Just $ reAnnL annCtxt emptyComments $ L lContext [resetEntryDP constraint]
-        annCtxt = AnnContext (Just (NormalSyntax, epl 1)) [epl 0 | needsParens] [epl 0 | needsParens]
-        needsParens = hsTypeNeedsParens sigPrec $ unLoc constraint
-    ast <- pure $ setEntryDP ast (SameLine 1)
 #endif
 
     return $ reLocA $ L lTop $ HsQualTy noExtField context ast