Skip to content

Commit 4ea5385

Browse files
dnikolovvdnikolovv
committed
Add hls-underlying-type-plugin - a plugin that generates a 'Go To Definition' action for a variable's underlying type.
1 parent 59b733f commit 4ea5385

File tree

3 files changed

+188
-2
lines changed

3 files changed

+188
-2
lines changed

‎haskell-language-server.cabal

Lines changed: 38 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -687,6 +687,43 @@ test-suite hls-retrie-plugin-tests
687687
, hls-test-utils == 2.11.0.0
688688
, text
689689

690+
-----------------------------
691+
-- underlying-type plugin
692+
-----------------------------
693+
694+
flag underlyingType
695+
description: Enable underlying-type plugin
696+
default: True
697+
manual: True
698+
699+
common underlying-type
700+
if flag(underlyingType) || flag(ignore-plugins-ghc-bounds)
701+
build-depends: haskell-language-server:hls-underlying-type-plugin
702+
cpp-options: -Dhls_underlyingType
703+
704+
library hls-underlying-type-plugin
705+
import: defaults, pedantic, warnings
706+
if !(flag(underlyingType) || flag(ignore-plugins-ghc-bounds))
707+
buildable: True
708+
exposed-modules: Ide.Plugin.UnderlyingType
709+
hs-source-dirs: plugins/hls-underlying-type-plugin/src
710+
build-depends:
711+
, directory
712+
, filepath
713+
, ghcide == 2.11.0.0
714+
, hls-plugin-api == 2.11.0.0
715+
, lens
716+
, lsp-types
717+
, mtl
718+
, process-extras
719+
, text
720+
, containers
721+
, ghc
722+
, aeson
723+
724+
default-extensions:
725+
DataKinds
726+
690727
-----------------------------
691728
-- hlint plugin
692729
-----------------------------
@@ -1870,6 +1907,7 @@ library
18701907
, overloadedRecordDot
18711908
, semanticTokens
18721909
, notes
1910+
, underlying-type
18731911

18741912
exposed-modules:
18751913
Ide.Arguments

‎plugins/hls-underlying-type-plugin/src/Ide/Plugin/UnderlyingType.hs

Lines changed: 141 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,141 @@
1+
{-# LANGUAGE GADTs #-}
2+
{-# LANGUAGE LambdaCase #-}
3+
{-# LANGUAGE OverloadedStrings #-}
4+
5+
module Ide.Plugin.UnderlyingType where
6+
7+
import Control.Lens ((^.))
8+
import Control.Monad (forM)
9+
import Control.Monad.IO.Class
10+
import Control.Monad.RWS (lift)
11+
import qualified Data.Aeson as Aeson
12+
import Data.Either (rights)
13+
import qualified Data.Map as M
14+
import Data.Maybe (catMaybes, fromMaybe)
15+
import qualified Data.Text as T
16+
import Development.IDE hiding (pluginHandlers)
17+
import Development.IDE.Core.PluginUtils
18+
import Development.IDE.Core.PositionMapping
19+
import Development.IDE.Core.Shake (getShakeExtras)
20+
import Development.IDE.GHC.Compat.Core (Name)
21+
import Development.IDE.Spans.AtPoint (pointCommand)
22+
import GHC.Iface.Ext.Types
23+
import GHC.Iface.Ext.Utils (nodeInfo)
24+
import Ide.Plugin.Error (getNormalizedFilePathE)
25+
import Ide.Types
26+
import qualified Language.LSP.Protocol.Lens as L
27+
import Language.LSP.Protocol.Message (Method (Method_TextDocumentCodeAction),
28+
SMethod (SMethod_TextDocumentCodeAction))
29+
import Language.LSP.Protocol.Types
30+
31+
data Log
32+
= LogPluginCalled Uri Range
33+
| LogIdentifiersFound Position [Name]
34+
| LogTypeLocationsFound [(Location, Identifier)]
35+
| LogProcessingLocation Location Identifier
36+
| LogActionCreated Name Name
37+
38+
instance Pretty Log where
39+
pretty = \case
40+
LogPluginCalled uri range ->
41+
"Plugin called for" <+> pretty (show uri) <+> "at range" <+> pretty (show range)
42+
LogIdentifiersFound pos identifiers ->
43+
"Found" <+> pretty (length identifiers) <+> "identifiers at" <+> pretty (show pos) <> ":" <+>
44+
pretty (T.intercalate ", " (map printOutputable identifiers))
45+
LogTypeLocationsFound locations ->
46+
"Found" <+> pretty (length locations) <+> "type locations"
47+
LogProcessingLocation loc identifier ->
48+
"Processing location" <+> pretty (show loc) <+> "for" <+> pretty (printOutputable identifier)
49+
LogActionCreated varName typeName ->
50+
"Created action for" <+> pretty (printOutputable varName) <+> "->" <+> pretty (printOutputable typeName)
51+
52+
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
53+
descriptor recorder plId =
54+
(defaultPluginDescriptor plId "Generates actions for going to the underlying type's definition.")
55+
{ pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeAction (provider recorder)
56+
}
57+
58+
provider :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'Method_TextDocumentCodeAction
59+
provider recorder state _ (CodeActionParams _ _ (TextDocumentIdentifier uri) range _) = do
60+
logWith recorder Debug $ LogPluginCalled uri range
61+
62+
nfp <- getNormalizedFilePathE uri
63+
64+
(HAR _ hieAst _ _ hieKind, posMapping) <-
65+
runActionE "GetHieAst" state $
66+
useWithStaleE GetHieAst nfp
67+
68+
let position = fromMaybe (range ^. L.start) $ fromCurrentPosition posMapping (range ^. L.start)
69+
namesAtPosition = mconcat $ pointCommand hieAst position (extractNamesAtPosition hieKind)
70+
71+
logWith recorder Debug $ LogIdentifiersFound position namesAtPosition
72+
73+
actions <- case namesAtPosition of
74+
[] -> pure []
75+
identifiers -> do
76+
typeActions <- forM identifiers $ \bindingName -> do
77+
locationForIdentifierType <- runActionE "TypeCheck" state $ do
78+
shakeExtras <- lift getShakeExtras
79+
result <- liftIO $ runIdeAction "Get Type Definition" shakeExtras $ getTypeDefinition nfp position
80+
pure $ fromMaybe [] result
81+
82+
logWith recorder Debug $ LogTypeLocationsFound locationForIdentifierType
83+
84+
typeDefActions <- forM locationForIdentifierType $ \(loc, identifier) -> do
85+
logWith recorder Debug $ LogProcessingLocation loc identifier
86+
87+
case identifier of
88+
Left _moduleName -> pure Nothing
89+
Right underlyingTypeName -> do
90+
logWith recorder Debug $ LogActionCreated bindingName underlyingTypeName
91+
pure $ Just $ createGoToTypeDefAction bindingName underlyingTypeName loc
92+
93+
pure $ catMaybes typeDefActions
94+
95+
pure $ mconcat typeActions
96+
97+
pure $ InL actions
98+
99+
extractNamesAtPosition :: HieKind a -> HieAST a -> [Name]
100+
extractNamesAtPosition hieKind ast =
101+
case hieKind of
102+
HieFresh -> rights $ map fst $ M.toList $ nodeIdentifiers $ nodeInfo ast
103+
HieFromDisk {} -> []
104+
105+
createGoToTypeDefAction :: Name -> Name -> Location -> (Command |? CodeAction)
106+
createGoToTypeDefAction boundVarName underlyingTypeName loc = do
107+
let defRange = loc ^. L.range
108+
InR $
109+
CodeAction
110+
("Go to definition of " <> printOutputable underlyingTypeName <> " (inferred from " <> printOutputable boundVarName <> "'s type)")
111+
(Just $ CodeActionKind_Custom "GoToUnderlyingTypeDefinition")
112+
Nothing
113+
Nothing
114+
Nothing
115+
Nothing
116+
( Just $
117+
Command
118+
"Go to definition"
119+
-- TODO: How to decouple this from VS code?
120+
"vscode.open"
121+
( Just
122+
[ Aeson.toJSON $ loc ^. L.uri,
123+
Aeson.object
124+
[ "selection"
125+
Aeson..= Aeson.object
126+
[ "start"
127+
Aeson..= Aeson.object
128+
[ "line" Aeson..= (defRange ^. L.start . L.line),
129+
"character" Aeson..= (defRange ^. L.start . L.character)
130+
],
131+
"end"
132+
Aeson..= Aeson.object
133+
[ "line" Aeson..= (defRange ^. L.end . L.line),
134+
"character" Aeson..= (defRange ^. L.end . L.character)
135+
]
136+
]
137+
]
138+
]
139+
)
140+
)
141+
Nothing

‎src/HlsPlugins.hs

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -45,9 +45,13 @@ import qualified Ide.Plugin.Rename as Rename
4545
import qualified Ide.Plugin.Retrie as Retrie
4646
#endif
4747

48-
#if hls_hlint
48+
-- #if hls_underlyingType
49+
import qualified Ide.Plugin.UnderlyingType as UnderlyingType
50+
-- #endif
51+
52+
-- #if hls_hlint
4953
import qualified Ide.Plugin.Hlint as Hlint
50-
#endif
54+
-- #endif
5155

5256
#if hls_stan
5357
import qualified Ide.Plugin.Stan as Stan
@@ -187,6 +191,9 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins
187191
#if hls_retrie
188192
let pId = "retrie" in Retrie.descriptor (pluginRecorder pId) pId :
189193
#endif
194+
#if hls_underlyingType
195+
let pId = "underlying-type" in UnderlyingType.descriptor (pluginRecorder pId) pId :
196+
#endif
190197
#if hls_callHierarchy
191198
CallHierarchy.descriptor "callHierarchy" :
192199
#endif

0 commit comments

Comments
 (0)