From 0c87468c35747febc129409439266e01b295cbfa Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 27 Jan 2024 21:58:11 +0800 Subject: [PATCH 1/5] fix isClassNodeIdentifier --- .../hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) 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..fd4ba825d2 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,9 @@ 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 +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" From 919d78a79380d49141ab3585ce4f567a7cca4afb Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 7 Feb 2024 14:30:27 +0800 Subject: [PATCH 2/5] add comment --- plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs | 1 + 1 file changed, 1 insertion(+) 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 fd4ba825d2..29808db583 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeAction.hs @@ -198,6 +198,7 @@ codeAction recorder state plId (CodeActionParams _ _ docId _ context) = do _ -> fail "Ide.Plugin.Class.findClassFromIdentifier" findClassFromIdentifier _ (Left _) = throwError (PluginInternalError "Ide.Plugin.Class.findClassIdentifier") +-- 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 From 7ab36465acf6b78e7ce52c6e111ef2548176e47b Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 7 Feb 2024 18:13:29 +0800 Subject: [PATCH 3/5] add test --- plugins/hls-class-plugin/test/Main.hs | 13 +++++++++++++ .../hls-class-plugin/test/testdata/Ticket3942one.hs | 13 +++++++++++++ 2 files changed, 26 insertions(+) create mode 100644 plugins/hls-class-plugin/test/testdata/Ticket3942one.hs diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index f9cd09201c..b67c6974c4 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -4,11 +4,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# LANGUAGE DataKinds #-} module Main ( main ) where +import Control.Exception (catch) import Control.Lens (Prism', prism', view, (^.), (^..), (^?)) import Control.Monad (void) @@ -120,6 +122,17 @@ codeLensTests = testGroup doc <- openDoc "TH.hs" "haskell" lens <- getAndResolveCodeLenses doc liftIO $ length lens @?= 0 + , testCase "Don 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 () From fc37c931e3f71999fd1243d4ce44ec3b5b6af13c Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 7 Feb 2024 18:56:25 +0800 Subject: [PATCH 4/5] cleanup --- plugins/hls-class-plugin/test/Main.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index b67c6974c4..53ed69c732 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -4,7 +4,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -{-# LANGUAGE DataKinds #-} module Main ( main From a25254207af0200899b7c4a629caa88f70eded04 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Wed, 7 Feb 2024 18:58:38 +0800 Subject: [PATCH 5/5] Update plugins/hls-class-plugin/test/Main.hs Co-authored-by: Michael Peyton Jones --- plugins/hls-class-plugin/test/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index 53ed69c732..ae27917920 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -121,7 +121,7 @@ codeLensTests = testGroup doc <- openDoc "TH.hs" "haskell" lens <- getAndResolveCodeLenses doc liftIO $ length lens @?= 0 - , testCase "Don not construct error action!, Ticket3942one" $ do + , testCase "Do not construct error action!, Ticket3942one" $ do runSessionWithServer def classPlugin testDataDir $ do doc <- openDoc "Ticket3942one.hs" "haskell" _ <- waitForDiagnosticsFromSource doc (T.unpack sourceTypecheck)