Skip to content

Commit e83b282

Browse files
July541July541
committed
Query position mapping if available
1 parent 01f823c commit e83b282

File tree

1 file changed

+126
-70
lines changed

1 file changed

+126
-70
lines changed

‎ghcide/src/Development/IDE/Plugin/TypeLenses.hs

Lines changed: 126 additions & 70 deletions
Original file line numberDiff line numberDiff line change
@@ -13,66 +13,69 @@ module Development.IDE.Plugin.TypeLenses (
1313
Log(..)
1414
) where
1515

16-
import Control.Concurrent.STM.Stats (atomically)
17-
import Control.DeepSeq (rwhnf)
18-
import Control.Monad (mzero)
19-
import Control.Monad.Extra (whenMaybe)
20-
import Control.Monad.IO.Class (MonadIO (liftIO))
21-
import Data.Aeson.Types (Value (..), toJSON)
22-
import qualified Data.Aeson.Types as A
23-
import qualified Data.HashMap.Strict as Map
24-
import Data.List (find)
25-
import Data.Maybe (catMaybes)
26-
import qualified Data.Text as T
27-
import Development.IDE (GhcSession (..),
28-
HscEnvEq (hscEnv),
29-
RuleResult, Rules, define,
30-
srcSpanToRange,
31-
usePropertyAction,
32-
useWithStale)
33-
import Development.IDE.Core.Compile (TcModuleResult (..))
34-
import Development.IDE.Core.Rules (IdeState, runAction)
35-
import Development.IDE.Core.RuleTypes (GetBindings (GetBindings),
36-
TypeCheck (TypeCheck))
37-
import Development.IDE.Core.Service (getDiagnostics)
38-
import Development.IDE.Core.Shake (getHiddenDiagnostics, use)
39-
import qualified Development.IDE.Core.Shake as Shake
16+
import Control.Concurrent.STM.Stats (atomically)
17+
import Control.DeepSeq (rwhnf)
18+
import Control.Monad (mzero)
19+
import Control.Monad.Extra (whenMaybe)
20+
import Control.Monad.IO.Class (MonadIO (liftIO))
21+
import Data.Aeson.Types (Value (..), toJSON)
22+
import qualified Data.Aeson.Types as A
23+
import qualified Data.HashMap.Strict as Map
24+
import Data.List (find)
25+
import Data.Maybe (catMaybes, fromMaybe,
26+
mapMaybe)
27+
import qualified Data.Text as T
28+
import Development.IDE (GhcSession (..),
29+
HscEnvEq (hscEnv),
30+
RuleResult, Rules,
31+
define, srcSpanToRange,
32+
usePropertyAction,
33+
useWithStale)
34+
import Development.IDE.Core.Compile (TcModuleResult (..))
35+
import Development.IDE.Core.PositionMapping (PositionMapping,
36+
toCurrentRange)
37+
import Development.IDE.Core.Rules (IdeState, runAction)
38+
import Development.IDE.Core.RuleTypes (GetBindings (GetBindings),
39+
TypeCheck (TypeCheck))
40+
import Development.IDE.Core.Service (getDiagnostics)
41+
import Development.IDE.Core.Shake (getHiddenDiagnostics,
42+
use)
43+
import qualified Development.IDE.Core.Shake as Shake
4044
import Development.IDE.GHC.Compat
41-
import Development.IDE.GHC.Util (printName)
45+
import Development.IDE.GHC.Util (printName)
4246
import Development.IDE.Graph.Classes
43-
import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope)
44-
import Development.IDE.Types.Location (Position (Position, _character, _line),
45-
Range (Range, _end, _start),
46-
toNormalizedFilePath',
47-
uriToFilePath')
48-
import Development.IDE.Types.Logger (Pretty (pretty), Recorder,
49-
WithPriority,
50-
cmapWithPrio)
51-
import GHC.Generics (Generic)
52-
import Ide.Plugin.Config (Config)
47+
import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope)
48+
import Development.IDE.Types.Location (Position (Position, _character, _line),
49+
Range (Range, _end, _start))
50+
import Development.IDE.Types.Logger (Pretty (pretty),
51+
Recorder, WithPriority,
52+
cmapWithPrio)
53+
import GHC.Generics (Generic)
5354
import Ide.Plugin.Properties
54-
import Ide.PluginUtils (mkLspCommand)
55-
import Ide.Types (CommandFunction,
56-
CommandId (CommandId),
57-
PluginCommand (PluginCommand),
58-
PluginDescriptor (..),
59-
PluginId,
60-
configCustomConfig,
61-
defaultConfigDescriptor,
62-
defaultPluginDescriptor,
63-
mkCustomConfig,
64-
mkPluginHandler)
65-
import qualified Language.LSP.Server as LSP
66-
import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
67-
CodeLens (CodeLens),
68-
CodeLensParams (CodeLensParams, _textDocument),
69-
Diagnostic (..),
70-
List (..), ResponseError,
71-
SMethod (..),
72-
TextDocumentIdentifier (TextDocumentIdentifier),
73-
TextEdit (TextEdit),
74-
WorkspaceEdit (WorkspaceEdit))
75-
import Text.Regex.TDFA ((=~), (=~~))
55+
import Ide.PluginUtils
56+
import Ide.Types (CommandFunction,
57+
CommandId (CommandId),
58+
PluginCommand (PluginCommand),
59+
PluginDescriptor (..),
60+
PluginId,
61+
PluginMethodHandler,
62+
configCustomConfig,
63+
defaultConfigDescriptor,
64+
defaultPluginDescriptor,
65+
mkCustomConfig,
66+
mkPluginHandler)
67+
import qualified Language.LSP.Server as LSP
68+
import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
69+
CodeLens (CodeLens),
70+
CodeLensParams (CodeLensParams, _textDocument),
71+
Diagnostic (..),
72+
List (..),
73+
Method (TextDocumentCodeLens),
74+
SMethod (..),
75+
TextDocumentIdentifier (TextDocumentIdentifier),
76+
TextEdit (TextEdit),
77+
WorkspaceEdit (WorkspaceEdit))
78+
import Text.Regex.TDFA ((=~), (=~~))
7679

7780
data Log = LogShake Shake.Log deriving Show
7881

@@ -86,7 +89,7 @@ typeLensCommandId = "typesignature.add"
8689
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
8790
descriptor recorder plId =
8891
(defaultPluginDescriptor plId)
89-
{ pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider
92+
{ pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider'
9093
, pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler]
9194
, pluginRules = rules recorder
9295
, pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties}
@@ -100,6 +103,43 @@ properties = emptyProperties
100103
, (Diagnostics, "Follows error messages produced by GHC about missing signatures")
101104
] Always
102105

106+
codeLensProvider' :: PluginMethodHandler IdeState TextDocumentCodeLens
107+
codeLensProvider' ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = pluginResponse $ do
108+
mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties
109+
nfp <- getNormalizedFilePath uri
110+
(env', _) <- handleMaybeM "Unable to get GhcSession" $ liftIO $ runAction "codeLens.GhcSession" ideState (useWithStale GhcSession nfp)
111+
let env = hscEnv env'
112+
(tmr, tmrMp) <- handleMaybeM "Unable to TypeCheck" $ liftIO $ runAction "codeLens.TypeCheck" ideState (useWithStale TypeCheck nfp)
113+
(bindings, bindingsMp) <- handleMaybeM "Unable to GetBindings" $ liftIO $ runAction "codeLens.GetBindings" ideState (useWithStale GetBindings nfp)
114+
(gblSigs@(GlobalBindingTypeSigsResult gblSigs'), gblSigsMp) <- handleMaybeM "Unable to GetGlobalBindingTypeSigs" $ liftIO $ runAction "codeLens.GetGlobalBindingTypeSigs" ideState (useWithStale GetGlobalBindingTypeSigs nfp)
115+
116+
diag <- liftIO $ atomically $ getDiagnostics ideState
117+
hDiag <- liftIO $ atomically $ getHiddenDiagnostics ideState
118+
119+
let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing
120+
generateLensForGlobal mp sig@GlobalBindingTypeSig{..} = do
121+
range <- toCurrentRange mp =<< srcSpanToRange (gbSrcSpan sig)
122+
tedit <- gblBindingTypeSigToEdit sig (Just gblSigsMp)
123+
let wedit = toWorkSpaceEdit [tedit]
124+
pure $ generateLens pId range (T.pack gbRendered) wedit
125+
generateLensFromDiags mp f =
126+
catMaybes
127+
[ fmap (\range -> generateLens pId range title edit) mrange
128+
| (dFile, _, dDiag@Diagnostic{_range = _range}) <- diag ++ hDiag
129+
, dFile == nfp
130+
, (title, tedit) <- f dDiag
131+
, let edit = toWorkSpaceEdit tedit
132+
, let mrange = toCurrentRange mp _range
133+
]
134+
pure $ List $ case mode of
135+
Always ->
136+
mapMaybe (generateLensForGlobal gblSigsMp) gblSigs'
137+
<> generateLensFromDiags bindingsMp (suggestLocalSignature False (Just env) (Just tmr) (Just bindings) (Just bindingsMp)) -- we still need diagnostics for local bindings
138+
Exported -> mapMaybe (generateLensForGlobal gblSigsMp) (filter gbExported gblSigs')
139+
Diagnostics -> generateLensFromDiags bindingsMp
140+
$ suggestSignature' False (Just env) (Just gblSigs) (Just tmr) (Just bindings) (Just gblSigsMp) (Just bindingsMp)
141+
142+
{-
103143
codeLensProvider ::
104144
IdeState ->
105145
PluginId ->
@@ -142,6 +182,7 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif
142182
Exported -> pure $ catMaybes $ generateLensForGlobal <$> filter gbExported gblSigs'
143183
Diagnostics -> generateLensFromDiags $ suggestSignature False env gblSigs tmr bindings
144184
Nothing -> pure []
185+
-}
145186

146187
generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens
147188
generateLens pId _range title edit =
@@ -157,22 +198,35 @@ commandHandler _ideState wedit = do
157198

158199
suggestSignature :: Bool -> Maybe HscEnv -> Maybe GlobalBindingTypeSigsResult -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])]
159200
suggestSignature isQuickFix env mGblSigs mTmr mBindings diag =
160-
suggestGlobalSignature isQuickFix mGblSigs diag <> suggestLocalSignature isQuickFix env mTmr mBindings diag
161-
162-
suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, [TextEdit])]
163-
suggestGlobalSignature isQuickFix mGblSigs Diagnostic{_message, _range}
201+
suggestGlobalSignature isQuickFix mGblSigs Nothing diag <> suggestLocalSignature isQuickFix env mTmr mBindings Nothing diag
202+
203+
suggestSignature' ::
204+
Bool
205+
-> Maybe HscEnv
206+
-> Maybe GlobalBindingTypeSigsResult
207+
-> Maybe TcModuleResult
208+
-> Maybe Bindings
209+
-> Maybe PositionMapping
210+
-> Maybe PositionMapping
211+
-> Diagnostic
212+
-> [(T.Text, [TextEdit])]
213+
suggestSignature' isQuickFix env mGblSigs mTmr mBindings gblMp bindingMp diag =
214+
suggestGlobalSignature isQuickFix mGblSigs gblMp diag <> suggestLocalSignature isQuickFix env mTmr mBindings bindingMp diag
215+
216+
suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe PositionMapping -> Diagnostic -> [(T.Text, [TextEdit])]
217+
suggestGlobalSignature isQuickFix mGblSigs mmp Diagnostic{_message, _range}
164218
| _message
165219
=~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text)
166220
, Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs
167221
, Just sig <- find (\x -> sameThing (gbSrcSpan x) _range) sigs
168222
, signature <- T.pack $ gbRendered sig
169223
, title <- if isQuickFix then "add signature: " <> signature else signature
170-
, Just action <- gblBindingTypeSigToEdit sig =
224+
, Just action <- gblBindingTypeSigToEdit sig mmp =
171225
[(title, [action])]
172226
| otherwise = []
173227

174-
suggestLocalSignature :: Bool -> Maybe HscEnv -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])]
175-
suggestLocalSignature isQuickFix mEnv mTmr mBindings Diagnostic{_message, _range = _range@Range{..}}
228+
suggestLocalSignature :: Bool -> Maybe HscEnv -> Maybe TcModuleResult -> Maybe Bindings -> Maybe PositionMapping -> Diagnostic -> [(T.Text, [TextEdit])]
229+
suggestLocalSignature isQuickFix mEnv mTmr mBindings mmp Diagnostic{_message, _range = _range@Range{..}}
176230
| Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <-
177231
(T.unwords . T.words $ _message)
178232
=~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text)
@@ -190,19 +244,21 @@ suggestLocalSignature isQuickFix mEnv mTmr mBindings Diagnostic{_message, _range
190244
, startOfLine <- Position (_line _start) startCharacter
191245
, beforeLine <- Range startOfLine startOfLine
192246
, title <- if isQuickFix then "add signature: " <> signature else signature
193-
, action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate (fromIntegral startCharacter) " " =
247+
, range' <- fromMaybe beforeLine (flip toCurrentRange beforeLine =<< mmp)
248+
, action <- TextEdit range' $ signature <> "\n" <> T.replicate (fromIntegral startCharacter) " " =
194249
[(title, [action])]
195250
| otherwise = []
196251

197252
sameThing :: SrcSpan -> Range -> Bool
198253
sameThing s1 s2 = (_start <$> srcSpanToRange s1) == (_start <$> Just s2)
199254

200-
gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe TextEdit
201-
gblBindingTypeSigToEdit GlobalBindingTypeSig{..}
255+
gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe PositionMapping -> Maybe TextEdit
256+
gblBindingTypeSigToEdit GlobalBindingTypeSig{..} mmp
202257
| Just Range{..} <- srcSpanToRange $ getSrcSpan gbName
203258
, startOfLine <- Position (_line _start) 0
204-
, beforeLine <- Range startOfLine startOfLine =
205-
Just $ TextEdit beforeLine $ T.pack gbRendered <> "\n"
259+
, beforeLine <- Range startOfLine startOfLine
260+
, range' <- fromMaybe beforeLine (flip toCurrentRange beforeLine =<< mmp)
261+
= Just $ TextEdit range' $ T.pack gbRendered <> "\n"
206262
| otherwise = Nothing
207263

208264
data Mode

0 commit comments

Comments
 (0)