Skip to content

Commit 2121495

Browse files
akshaymankarakshaymankar
authored
hls-class-plugin: Only create placeholders for unimplemented methods (#2956)
* hls-class-plugin: Only create placeholders for unimplemented methods * hls-class-plugin: Add logs
1 parent dc45afc commit 2121495

File tree

7 files changed

+159
-43
lines changed

7 files changed

+159
-43
lines changed

‎exe/Plugins.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -160,7 +160,7 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
160160
CallHierarchy.descriptor :
161161
#endif
162162
#if class
163-
Class.descriptor "class" :
163+
Class.descriptor pluginRecorder "class" :
164164
#endif
165165
#if haddockComments
166166
HaddockComments.descriptor "haddockComments" :

‎plugins/hls-class-plugin/hls-class-plugin.cabal

+1
Original file line numberDiff line numberDiff line change
@@ -56,6 +56,7 @@ test-suite tests
5656
build-depends:
5757
, base
5858
, filepath
59+
, ghcide
5960
, hls-class-plugin
6061
, hls-test-utils ^>=1.3
6162
, lens

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

+62-22
Original file line numberDiff line numberDiff line change
@@ -1,12 +1,14 @@
11
{-# LANGUAGE CPP #-}
22
{-# LANGUAGE DeriveAnyClass #-}
33
{-# LANGUAGE DeriveGeneric #-}
4+
{-# LANGUAGE LambdaCase #-}
45
{-# LANGUAGE OverloadedStrings #-}
56
{-# LANGUAGE RecordWildCards #-}
67
{-# LANGUAGE TypeFamilies #-}
78
{-# LANGUAGE ViewPatterns #-}
89
module Ide.Plugin.Class
9-
( descriptor
10+
( descriptor,
11+
Log (..)
1012
) where
1113

1214
import Control.Applicative
@@ -17,15 +19,17 @@ import Control.Monad.Trans.Class
1719
import Control.Monad.Trans.Maybe
1820
import Data.Aeson
1921
import Data.Char
22+
import Data.Either (rights)
2023
import Data.List
2124
import qualified Data.Map.Strict as Map
2225
import Data.Maybe
23-
import qualified Data.Text as T
2426
import qualified Data.Set as Set
27+
import qualified Data.Text as T
2528
import Development.IDE hiding (pluginHandlers)
2629
import Development.IDE.Core.PositionMapping (fromCurrentRange,
2730
toCurrentRange)
28-
import Development.IDE.GHC.Compat as Compat hiding (locA)
31+
import Development.IDE.GHC.Compat as Compat hiding (locA,
32+
(<+>))
2933
import Development.IDE.GHC.Compat.Util
3034
import Development.IDE.Spans.AtPoint
3135
import qualified GHC.Generics as Generics
@@ -40,14 +44,24 @@ import Language.LSP.Types
4044
import qualified Language.LSP.Types.Lens as J
4145

4246
#if MIN_VERSION_ghc(9,2,0)
43-
import GHC.Hs (AnnsModule(AnnsModule))
47+
import GHC.Hs (AnnsModule (AnnsModule))
4448
import GHC.Parser.Annotation
4549
#endif
4650

47-
descriptor :: PluginId -> PluginDescriptor IdeState
48-
descriptor plId = (defaultPluginDescriptor plId)
51+
data Log
52+
= LogImplementedMethods Class [T.Text]
53+
54+
instance Pretty Log where
55+
pretty = \case
56+
LogImplementedMethods cls methods ->
57+
pretty ("Detected implmented methods for class" :: String)
58+
<+> pretty (show (getOccString cls) <> ":") -- 'show' is used here to add quotes around the class name
59+
<+> pretty methods
60+
61+
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
62+
descriptor recorder plId = (defaultPluginDescriptor plId)
4963
{ pluginCommands = commands
50-
, pluginHandlers = mkPluginHandler STextDocumentCodeAction codeAction
64+
, pluginHandlers = mkPluginHandler STextDocumentCodeAction (codeAction recorder)
5165
}
5266

5367
commands :: [PluginCommand IdeState]
@@ -176,8 +190,8 @@ addMethodPlaceholders state AddMinimalMethodsParams{..} = do
176190
-- |
177191
-- This implementation is ad-hoc in a sense that the diagnostic detection mechanism is
178192
-- sensitive to the format of diagnostic messages from GHC.
179-
codeAction :: PluginMethodHandler IdeState TextDocumentCodeAction
180-
codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fromMaybe errorResult) . runMaybeT $ do
193+
codeAction :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState TextDocumentCodeAction
194+
codeAction recorder state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fromMaybe errorResult) . runMaybeT $ do
181195
docPath <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri
182196
actions <- join <$> mapM (mkActions docPath) methodDiags
183197
pure . Right . List $ actions
@@ -190,9 +204,17 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr
190204
methodDiags = filter (\d -> isClassMethodWarning (d ^. J.message)) ghcDiags
191205

192206
mkActions docPath diag = do
193-
ident <- findClassIdentifier docPath range
207+
(HAR {hieAst = ast}, pmap) <-
208+
MaybeT . runAction "classplugin" state $ useWithStale GetHieAst docPath
209+
instancePosition <- MaybeT . pure $
210+
fromCurrentRange pmap range ^? _Just . J.start
211+
& fmap (J.character -~ 1)
212+
213+
ident <- findClassIdentifier ast instancePosition
194214
cls <- findClassFromIdentifier docPath ident
195-
lift . traverse mkAction . minDefToMethodGroups . classMinimalDef $ cls
215+
implemented <- findImplementedMethods ast instancePosition
216+
logWith recorder Info (LogImplementedMethods cls implemented)
217+
lift . traverse (mkAction . (\\ implemented)) . minDefToMethodGroups . classMinimalDef $ cls
196218
where
197219
range = diag ^. J.range
198220

@@ -212,16 +234,14 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr
212234
= InR
213235
$ CodeAction title (Just CodeActionQuickFix) (Just (List [])) Nothing Nothing Nothing (Just cmd) Nothing
214236

215-
findClassIdentifier docPath range = do
216-
(hieAstResult, pmap) <- MaybeT . runAction "classplugin" state $ useWithStale GetHieAst docPath
217-
case hieAstResult of
218-
HAR {hieAst = hf} ->
219-
pure
220-
$ head . head
221-
$ pointCommand hf (fromJust (fromCurrentRange pmap range) ^. J.start & J.character -~ 1)
222-
( (Map.keys . Map.filter isClassNodeIdentifier . Compat.getNodeIds)
223-
<=< nodeChildren
224-
)
237+
findClassIdentifier :: HieASTs a -> Position -> MaybeT IO (Either ModuleName Name)
238+
findClassIdentifier ast instancePosition =
239+
pure
240+
$ head . head
241+
$ pointCommand ast instancePosition
242+
( (Map.keys . Map.filter isClassNodeIdentifier . Compat.getNodeIds)
243+
<=< nodeChildren
244+
)
225245

226246
findClassFromIdentifier docPath (Right name) = do
227247
(hscEnv -> hscenv, _) <- MaybeT . runAction "classplugin" state $ useWithStale GhcSessionDeps docPath
@@ -234,18 +254,38 @@ codeAction state plId (CodeActionParams _ _ docId _ context) = liftIO $ fmap (fr
234254
_ -> panic "Ide.Plugin.Class.findClassFromIdentifier"
235255
findClassFromIdentifier _ (Left _) = panic "Ide.Plugin.Class.findClassIdentifier"
236256

257+
findImplementedMethods :: HieASTs a -> Position -> MaybeT IO [T.Text]
258+
findImplementedMethods asts instancePosition = do
259+
pure
260+
$ concat
261+
$ pointCommand asts instancePosition
262+
$ map (T.pack . getOccString) . rights . findInstanceValBindIdentifiers
263+
264+
-- | Recurses through the given AST to find identifiers which are
265+
-- 'InstanceValBind's.
266+
findInstanceValBindIdentifiers :: HieAST a -> [Identifier]
267+
findInstanceValBindIdentifiers ast =
268+
let valBindIds = Map.keys
269+
. Map.filter (any isInstanceValBind . identInfo)
270+
$ getNodeIds ast
271+
in valBindIds <> concatMap findInstanceValBindIdentifiers (nodeChildren ast)
272+
237273
ghostSpan :: RealSrcSpan
238274
ghostSpan = realSrcLocSpan $ mkRealSrcLoc (fsLit "<haskell-language-sever>") 1 1
239275

240276
containRange :: Range -> SrcSpan -> Bool
241277
containRange range x = isInsideSrcSpan (range ^. J.start) x || isInsideSrcSpan (range ^. J.end) x
242278

243279
isClassNodeIdentifier :: IdentifierDetails a -> Bool
244-
isClassNodeIdentifier ident = (isNothing . identType) ident && Use `Set.member` (identInfo ident)
280+
isClassNodeIdentifier ident = (isNothing . identType) ident && Use `Set.member` identInfo ident
245281

246282
isClassMethodWarning :: T.Text -> Bool
247283
isClassMethodWarning = T.isPrefixOf "• No explicit implementation for"
248284

285+
isInstanceValBind :: ContextInfo -> Bool
286+
isInstanceValBind (ValBind InstanceBind _ _) = True
287+
isInstanceValBind _ = False
288+
249289
minDefToMethodGroups :: BooleanFormula Name -> [[T.Text]]
250290
minDefToMethodGroups = go
251291
where

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

+29-20
Original file line numberDiff line numberDiff line change
@@ -8,24 +8,29 @@ module Main
88
( main
99
) where
1010

11-
import Control.Lens (Prism', prism', (^..), (^?))
12-
import Control.Monad (void)
13-
import qualified Ide.Plugin.Class as Class
14-
import qualified Language.LSP.Types.Lens as J
11+
import Control.Lens (Prism', prism', (^..), (^?))
12+
import Control.Monad (void)
13+
import Data.Functor.Contravariant (contramap)
14+
import Development.IDE.Types.Logger
15+
import qualified Ide.Plugin.Class as Class
16+
import qualified Language.LSP.Types.Lens as J
1517
import System.FilePath
1618
import Test.Hls
1719

20+
1821
main :: IO ()
19-
main = defaultTestRunner tests
22+
main = do
23+
recorder <- makeDefaultStderrRecorder Nothing Debug
24+
defaultTestRunner . tests $ contramap (fmap pretty) recorder
2025

21-
classPlugin :: PluginDescriptor IdeState
22-
classPlugin = Class.descriptor "class"
26+
classPlugin :: Recorder (WithPriority Class.Log) -> PluginDescriptor IdeState
27+
classPlugin recorder = Class.descriptor recorder "class"
2328

24-
tests :: TestTree
25-
tests = testGroup
29+
tests :: Recorder (WithPriority Class.Log) -> TestTree
30+
tests recorder = testGroup
2631
"class"
2732
[ testCase "Produces addMinimalMethodPlaceholders code actions for one instance" $ do
28-
runSessionWithServer classPlugin testDataDir $ do
33+
runSessionWithServer (classPlugin recorder) testDataDir $ do
2934
doc <- openDoc "T1.hs" "haskell"
3035
_ <- waitForDiagnosticsFromSource doc "typecheck"
3136
caResults <- getAllCodeActions doc
@@ -34,30 +39,34 @@ tests = testGroup
3439
[ Just "Add placeholders for '=='"
3540
, Just "Add placeholders for '/='"
3641
]
37-
, goldenWithClass "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do
42+
, goldenWithClass recorder "Creates a placeholder for '=='" "T1" "eq" $ \(eqAction:_) -> do
3843
executeCodeAction eqAction
39-
, goldenWithClass "Creates a placeholder for '/='" "T1" "ne" $ \(_:neAction:_) -> do
44+
, goldenWithClass recorder "Creates a placeholder for '/='" "T1" "ne" $ \(_:neAction:_) -> do
4045
executeCodeAction neAction
41-
, goldenWithClass "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:fmapAction:_) -> do
46+
, goldenWithClass recorder "Creates a placeholder for 'fmap'" "T2" "fmap" $ \(_:_:fmapAction:_) -> do
4247
executeCodeAction fmapAction
43-
, goldenWithClass "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do
48+
, goldenWithClass recorder "Creates a placeholder for multiple methods 1" "T3" "1" $ \(mmAction:_) -> do
4449
executeCodeAction mmAction
45-
, goldenWithClass "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:mmAction:_) -> do
50+
, goldenWithClass recorder "Creates a placeholder for multiple methods 2" "T3" "2" $ \(_:mmAction:_) -> do
4651
executeCodeAction mmAction
47-
, goldenWithClass "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do
52+
, goldenWithClass recorder "Creates a placeholder for a method starting with '_'" "T4" "" $ \(_fAction:_) -> do
4853
executeCodeAction _fAction
49-
, goldenWithClass "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do
54+
, goldenWithClass recorder "Creates a placeholder for '==' with extra lines" "T5" "" $ \(eqAction:_) -> do
5055
executeCodeAction eqAction
56+
, goldenWithClass recorder "Creates a placeholder for only the unimplemented methods of multiple methods" "T6" "1" $ \(gAction:_) -> do
57+
executeCodeAction gAction
58+
, goldenWithClass recorder "Creates a placeholder for other two methods" "T6" "2" $ \(_:ghAction:_) -> do
59+
executeCodeAction ghAction
5160
]
5261

5362
_CACodeAction :: Prism' (Command |? CodeAction) CodeAction
5463
_CACodeAction = prism' InR $ \case
5564
InR action -> Just action
5665
_ -> Nothing
5766

58-
goldenWithClass :: TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree
59-
goldenWithClass title path desc act =
60-
goldenWithHaskellDoc classPlugin title testDataDir path (desc <.> "expected") "hs" $ \doc -> do
67+
goldenWithClass :: Recorder (WithPriority Class.Log) -> TestName -> FilePath -> FilePath -> ([CodeAction] -> Session ()) -> TestTree
68+
goldenWithClass recorder title path desc act =
69+
goldenWithHaskellDoc (classPlugin recorder) title testDataDir path (desc <.> "expected") "hs" $ \doc -> do
6170
_ <- waitForDiagnosticsFromSource doc "typecheck"
6271
actions <- concatMap (^.. _CACodeAction) <$> getAllCodeActions doc
6372
act actions

‎plugins/hls-class-plugin/test/testdata/T6.1.expected.hs

+22
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,22 @@
1+
module T6 where
2+
3+
data X = X | Y
4+
5+
class Test a where
6+
f :: a -> a
7+
f = h
8+
9+
g :: a
10+
11+
h :: a -> a
12+
h = f
13+
14+
i :: a
15+
16+
{-# MINIMAL f, g, i | g, h #-}
17+
18+
instance Test X where
19+
f X = X
20+
f Y = Y
21+
i = undefined
22+
g = _

‎plugins/hls-class-plugin/test/testdata/T6.2.expected.hs

+23
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,23 @@
1+
module T6 where
2+
3+
data X = X | Y
4+
5+
class Test a where
6+
f :: a -> a
7+
f = h
8+
9+
g :: a
10+
11+
h :: a -> a
12+
h = f
13+
14+
i :: a
15+
16+
{-# MINIMAL f, g, i | g, h #-}
17+
18+
instance Test X where
19+
f X = X
20+
f Y = Y
21+
i = undefined
22+
g = _
23+
h = _

‎plugins/hls-class-plugin/test/testdata/T6.hs

+21
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,21 @@
1+
module T6 where
2+
3+
data X = X | Y
4+
5+
class Test a where
6+
f :: a -> a
7+
f = h
8+
9+
g :: a
10+
11+
h :: a -> a
12+
h = f
13+
14+
i :: a
15+
16+
{-# MINIMAL f, g, i | g, h #-}
17+
18+
instance Test X where
19+
f X = X
20+
f Y = Y
21+
i = undefined

0 commit comments

Comments
 (0)