diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs index 19414b9598..29808db583 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/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" diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index f9cd09201c..ae27917920 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/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 diff --git a/plugins/hls-class-plugin/test/testdata/Ticket3942one.hs b/plugins/hls-class-plugin/test/testdata/Ticket3942one.hs new file mode 100644 index 0000000000..d620fc2ebb --- /dev/null +++ b/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 ()