Fix hls-class-plugin on ghc-9.2

.github/workflows/test.yml

@@ -164,7 +164,7 @@ jobs:
         name: Test hls-floskell-plugin
         run: cabal test hls-floskell-plugin --test-options="$TEST_OPTS" || cabal test hls-floskell-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-floskell-plugin --test-options="$TEST_OPTS"
 
-      - if: matrix.test && matrix.ghc != '9.2.1'
+      - if: matrix.test
         name: Test hls-class-plugin
         run: cabal test hls-class-plugin --test-options="$TEST_OPTS" || cabal test hls-class-plugin --test-options="$TEST_OPTS" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-class-plugin --test-options="$TEST_OPTS"
 

cabal-ghc921.project

@@ -45,7 +45,6 @@ constraints:
   haskell-language-server
     +ignore-plugins-ghc-bounds
     -brittany
-    -class
     -haddockComments
     -hlint
     -retrie

plugins/hls-class-plugin/src/Ide/Plugin/Class.hs

@@ -24,7 +24,7 @@ import qualified Data.Text                               as T
 import           Development.IDE                         hiding (pluginHandlers)
 import           Development.IDE.Core.PositionMapping    (fromCurrentRange,
                                                           toCurrentRange)
-import           Development.IDE.GHC.Compat
+import           Development.IDE.GHC.Compat              as Compat hiding (locA)
 import           Development.IDE.GHC.Compat.Util
 import           Development.IDE.Spans.AtPoint
 import qualified GHC.Generics                            as Generics
@@ -38,6 +38,12 @@ import           Language.LSP.Server
 import           Language.LSP.Types
 import qualified Language.LSP.Types.Lens                 as J
 
+#if MIN_VERSION_ghc(9,2,0)
+import           GHC.Data.Maybe (rightToMaybe)
+import           GHC.Hs                                  (AnnsModule(AnnsModule))
+import           GHC.Parser.Annotation
+#endif
+
 descriptor :: PluginId -> PluginDescriptor IdeState
 descriptor plId = (defaultPluginDescriptor plId)
   { pluginCommands = commands
@@ -63,25 +69,69 @@ addMethodPlaceholders state AddMinimalMethodsParams{..} = do
   medit <- liftIO $ runMaybeT $ do
     docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri
     pm <- MaybeT . runAction "classplugin" state $ use GetParsedModule docPath
-    let
-      ps = pm_parsed_source pm
-      anns = relativiseApiAnns ps (pm_annotations pm)
-      old = T.pack $ exactPrint ps anns
-
     (hsc_dflags . hscEnv -> df) <- MaybeT . runAction "classplugin" state $ use GhcSessionDeps docPath
-    List (unzip -> (mAnns, mDecls)) <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup
-    let
-      (ps', (anns', _), _) = runTransform (mergeAnns (mergeAnnList mAnns) anns) (addMethodDecls ps mDecls)
-      new = T.pack $ exactPrint ps' anns'
-
+    (old, new) <- makeEditText pm df
     pure (workspaceEdit caps old new)
+
   forM_ medit $ \edit ->
     sendRequest SWorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing edit) (\_ -> pure ())
   pure (Right Null)
   where
-
     indent = 2
 
+    workspaceEdit caps old new
+      = diffText caps (uri, old) new IncludeDeletions
+
+    toMethodName n
+      | Just (h, _) <- T.uncons n
+      , not (isAlpha h || h == '_')
+      = "(" <> n <> ")"
+      | otherwise
+      = n
+
+#if MIN_VERSION_ghc(9,2,0)
+    makeEditText pm df = do
+      List mDecls <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup
+      let ps = makeDeltaAst $ pm_parsed_source pm
+          old = T.pack $ exactPrint ps
+          (ps', _, _) = runTransform (addMethodDecls ps mDecls)
+          new = T.pack $ exactPrint ps'
+      pure (old, new)
+
+    makeMethodDecl df mName =
+        rightToMaybe . parseDecl df (T.unpack mName) . T.unpack
+            $ toMethodName mName <> " = _"
+
+    addMethodDecls ps mDecls = do
+      allDecls <- hsDecls ps
+      let (before, ((L l inst): after)) = break (containRange range . getLoc) allDecls
+      replaceDecls ps (before ++ (L l (addWhere inst)): (map newLine mDecls ++ after))
+      where
+        addWhere (InstD xInstD (ClsInstD ext decl@ClsInstDecl{..})) =
+          let ((EpAnn entry anns comments), key) = cid_ext
+          in InstD xInstD (ClsInstD ext decl {
+            cid_ext = (EpAnn
+                        entry
+                        (AddEpAnn AnnWhere (EpaDelta (SameLine 1) []) : anns)
+                        comments
+                      , key)
+          })
+        addWhere decl = decl
+
+        newLine (L l e) =
+          let dp = deltaPos 1 (indent + 1) -- Not sure why there need one more space
+          in L (noAnnSrcSpanDP (locA l) dp <> l) e
+
+#else
+    makeEditText pm df = do
+      List (unzip -> (mAnns, mDecls)) <- MaybeT . pure $ traverse (makeMethodDecl df) methodGroup
+      let ps = pm_parsed_source pm
+          anns = relativiseApiAnns ps (pm_annotations pm)
+          old = T.pack $ exactPrint ps anns
+          (ps', (anns', _), _) = runTransform (mergeAnns (mergeAnnList mAnns) anns) (addMethodDecls ps mDecls)
+          new = T.pack $ exactPrint ps' anns'
+      pure (old, new)
+
     makeMethodDecl df mName =
       case parseDecl df (T.unpack mName) . T.unpack $ toMethodName mName <> " = _" of
         Right (ann, d) -> Just (setPrecedingLines d 1 indent ann, d)
@@ -112,16 +162,7 @@ addMethodPlaceholders state AddMinimalMethodsParams{..} = do
 
     findInstDecl :: ParsedSource -> Transform (LHsDecl GhcPs)
     findInstDecl ps = head . filter (containRange range . getLoc) <$> hsDecls ps
-
-    workspaceEdit caps old new
-      = diffText caps (uri, old) new IncludeDeletions
-
-    toMethodName n
-      | Just (h, _) <- T.uncons n
-      , not (isAlpha h || h == '_')
-      = "(" <> n <> ")"
-      | otherwise
-      = n
+#endif
 
 -- |
 -- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is
@@ -168,13 +209,17 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr
         HAR {hieAst = hf} ->
           pure
             $ head . head
+#if MIN_VERSION_ghc(9,2,0)
+            $ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character +~ 1)
+              (Map.keys . Map.filter isClassNodeIdentifier . Compat.getNodeIds)
+#elif MIN_VERSION_ghc(9,0,0)
             $ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character -~ 1)
-#if !MIN_VERSION_ghc(9,0,0)
-              ( (Map.keys . Map.filter isClassNodeIdentifier . nodeIdentifiers . nodeInfo)
+              ( (Map.keys . Map.filter isClassNodeIdentifier . sourcedNodeIdents . sourcedNodeInfo)
                 <=< nodeChildren
               )
 #else
-              ( (Map.keys . Map.filter isClassNodeIdentifier . sourcedNodeIdents . sourcedNodeInfo)
+            $ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character -~ 1)
+              ( (Map.keys . Map.filter isClassNodeIdentifier . nodeIdentifiers . nodeInfo)
                 <=< nodeChildren
               )
 #endif
@@ -185,8 +230,12 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr
       MaybeT . fmap snd . initTcWithGbl hscenv thisMod ghostSpan $ do
         tcthing <- tcLookup name
         case tcthing of
+#if !MIN_VERSION_ghc(9,2,0)
           AGlobal (AConLike (RealDataCon con))
             | Just cls <- tyConClass_maybe (dataConOrigTyCon con) -> pure cls
+#else
+          AGlobal (ATyCon tycon) | Just cls <- tyConClass_maybe tycon -> pure cls
+#endif
           _ -> panic "Ide.Plugin.Class.findClassFromIdentifier"
     findClassFromIdentifier _ (Left _) = panic "Ide.Plugin.Class.findClassIdentifier"
 

plugins/hls-class-plugin/test/Main.hs

@@ -1,8 +1,10 @@
+{-# LANGUAGE CPP               #-}
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators     #-}
 
 {-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 module Main
   ( main
   ) where
@@ -45,6 +47,8 @@ tests = testGroup
       executeCodeAction mmAction
   , goldenWithClass "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do
       executeCodeAction _fAction
+  , goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do
+      executeCodeAction eqAction
   ]
 
 _CACodeAction :: Prism' (Command |? CodeAction) CodeAction

plugins/hls-class-plugin/test/testdata/T5.expected.hs

@@ -0,0 +1,8 @@
+module T1 where
+
+data X = X
+
+instance Eq X where
+  (==) = _
+
+x = ()

plugins/hls-class-plugin/test/testdata/T5.hs

@@ -0,0 +1,7 @@
+module T1 where
+
+data X = X
+
+instance Eq X where
+
+x = ()

stack-9.2.1.yaml

@@ -10,7 +10,7 @@ packages:
 - ./hls-test-utils
 - ./shake-bench
 - ./plugins/hls-call-hierarchy-plugin
-# - ./plugins/hls-class-plugin
+- ./plugins/hls-class-plugin
 # - ./plugins/hls-haddock-comments-plugin
 # - ./plugins/hls-eval-plugin
 - ./plugins/hls-explicit-imports-plugin