fix isClassNodeIdentifier in hls-class-plugin (#4020)

Partially fix #3942, by handling isClassNodeIdentifier correctly.

---------

Co-authored-by: Michael Peyton Jones <[email protected]>

Author: soulomoon

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

@@ -159,7 +159,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do
                 $ listToMaybe
                 $ mapMaybe listToMaybe
                 $ pointCommand hf instancePosition
-                    ( (Map.keys . Map.filter isClassNodeIdentifier . getNodeIds)
+                    ( (Map.keys . Map.filterWithKey isClassNodeIdentifier . getNodeIds)
                         <=< nodeChildren
                     )
 
@@ -198,8 +198,10 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do
                         _ -> fail "Ide.Plugin.Class.findClassFromIdentifier"
         findClassFromIdentifier _ (Left _) = throwError (PluginInternalError "Ide.Plugin.Class.findClassIdentifier")
 
-isClassNodeIdentifier :: IdentifierDetails a -> Bool
-isClassNodeIdentifier ident = (isNothing . identType) ident && Use `Set.member` identInfo ident
+-- see https://hackage.haskell.org/package/ghc-9.8.1/docs/src/GHC.Types.Name.Occurrence.html#mkClassDataConOcc
+isClassNodeIdentifier :: Identifier -> IdentifierDetails a -> Bool
+isClassNodeIdentifier (Right i) ident  | 'C':':':_ <- unpackFS $ occNameFS $ occName i = (isNothing . identType) ident && Use `Set.member` identInfo ident
+isClassNodeIdentifier _ _ = False
 
 isClassMethodWarning :: T.Text -> Bool
 isClassMethodWarning = T.isPrefixOf "• No explicit implementation for"

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

@@ -9,6 +9,7 @@ module Main
   ( main
   ) where
 
+import           Control.Exception             (catch)
 import           Control.Lens                  (Prism', prism', view, (^.),
                                                 (^..), (^?))
 import           Control.Monad                 (void)
@@ -120,6 +121,17 @@ codeLensTests = testGroup
             doc <- openDoc "TH.hs" "haskell"
             lens <- getAndResolveCodeLenses doc
             liftIO $ length lens @?= 0
+    , testCase "Do not construct error action!, Ticket3942one" $ do
+        runSessionWithServer def classPlugin testDataDir $ do
+            doc <- openDoc "Ticket3942one.hs" "haskell"
+            _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck)
+            lens <- getAllCodeActions doc
+            -- should switch to `liftIO $ length lens @?= 2, when Ticket3942 is entirely fixed`
+            -- current fix is just to make sure the code does not throw an exception that would mess up
+            -- the client UI.
+            liftIO $ length lens > 0 @?= True
+        `catch` \(e :: SessionException) -> do
+          liftIO $ assertFailure $ "classPluginTestError: "++ show e
     , goldenCodeLens "Apply code lens" "CodeLensSimple" 1
     , goldenCodeLens "Apply code lens for local class" "LocalClassDefine" 0
     , goldenCodeLens "Apply code lens on the same line" "Inline" 0

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

@@ -0,0 +1,13 @@
+{-# LANGUAGE DeriveAnyClass #-}
+
+module Ticket3942one where
+
+class C a where
+  foo :: a -> Int
+
+newtype Foo = MkFoo Int deriving (C)
+instance Show Foo where
+
+
+main :: IO ()
+main = return ()