Skip to content

Commit 41cd52e

Browse files
July541mergify[bot]
July541
and
mergify[bot]
authored
Keep type lenses stable (haskell#3558)
* Use stale type lens * Query position mapping if available * Remove redundant code * Generate from diag doesn't depend on position mapping * No stale diagnostic * Remove diagnostic chain * indent * Return Nothing if toCurrentRange failed * Comment some suspicious code * lens should work if mmp is Nothing --------- Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
1 parent c841c45 commit 41cd52e

File tree

2 files changed

+122
-94
lines changed

2 files changed

+122
-94
lines changed

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

Lines changed: 110 additions & 94 deletions
Original file line numberDiff line numberDiff line change
@@ -13,65 +13,68 @@ 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-
import Development.IDE.Core.Compile (TcModuleResult (..))
33-
import Development.IDE.Core.Rules (IdeState, runAction)
34-
import Development.IDE.Core.RuleTypes (GetBindings (GetBindings),
35-
TypeCheck (TypeCheck))
36-
import Development.IDE.Core.Service (getDiagnostics)
37-
import Development.IDE.Core.Shake (getHiddenDiagnostics, use)
38-
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, mapMaybe)
26+
import qualified Data.Text as T
27+
import Development.IDE (GhcSession (..),
28+
HscEnvEq (hscEnv),
29+
RuleResult, Rules,
30+
define, srcSpanToRange,
31+
usePropertyAction,
32+
useWithStale)
33+
import Development.IDE.Core.Compile (TcModuleResult (..))
34+
import Development.IDE.Core.PositionMapping (PositionMapping,
35+
toCurrentRange)
36+
import Development.IDE.Core.Rules (IdeState, runAction)
37+
import Development.IDE.Core.RuleTypes (GetBindings (GetBindings),
38+
TypeCheck (TypeCheck))
39+
import Development.IDE.Core.Service (getDiagnostics)
40+
import Development.IDE.Core.Shake (getHiddenDiagnostics,
41+
use)
42+
import qualified Development.IDE.Core.Shake as Shake
3943
import Development.IDE.GHC.Compat
40-
import Development.IDE.GHC.Util (printName)
44+
import Development.IDE.GHC.Util (printName)
4145
import Development.IDE.Graph.Classes
42-
import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope)
43-
import Development.IDE.Types.Location (Position (Position, _character, _line),
44-
Range (Range, _end, _start),
45-
toNormalizedFilePath',
46-
uriToFilePath')
47-
import Development.IDE.Types.Logger (Pretty (pretty), Recorder,
48-
WithPriority,
49-
cmapWithPrio)
50-
import GHC.Generics (Generic)
51-
import Ide.Plugin.Config (Config)
46+
import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope)
47+
import Development.IDE.Types.Location (Position (Position, _character, _line),
48+
Range (Range, _end, _start))
49+
import Development.IDE.Types.Logger (Pretty (pretty),
50+
Recorder, WithPriority,
51+
cmapWithPrio)
52+
import GHC.Generics (Generic)
5253
import Ide.Plugin.Properties
53-
import Ide.PluginUtils (mkLspCommand)
54-
import Ide.Types (CommandFunction,
55-
CommandId (CommandId),
56-
PluginCommand (PluginCommand),
57-
PluginDescriptor (..),
58-
PluginId,
59-
configCustomConfig,
60-
defaultConfigDescriptor,
61-
defaultPluginDescriptor,
62-
mkCustomConfig,
63-
mkPluginHandler)
64-
import qualified Language.LSP.Server as LSP
65-
import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
66-
CodeLens (CodeLens),
67-
CodeLensParams (CodeLensParams, _textDocument),
68-
Diagnostic (..),
69-
List (..), ResponseError,
70-
SMethod (..),
71-
TextDocumentIdentifier (TextDocumentIdentifier),
72-
TextEdit (TextEdit),
73-
WorkspaceEdit (WorkspaceEdit))
74-
import Text.Regex.TDFA ((=~), (=~~))
54+
import Ide.PluginUtils
55+
import Ide.Types (CommandFunction,
56+
CommandId (CommandId),
57+
PluginCommand (PluginCommand),
58+
PluginDescriptor (..),
59+
PluginId,
60+
PluginMethodHandler,
61+
configCustomConfig,
62+
defaultConfigDescriptor,
63+
defaultPluginDescriptor,
64+
mkCustomConfig,
65+
mkPluginHandler)
66+
import qualified Language.LSP.Server as LSP
67+
import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
68+
CodeLens (CodeLens),
69+
CodeLensParams (CodeLensParams, _textDocument),
70+
Diagnostic (..),
71+
List (..),
72+
Method (TextDocumentCodeLens),
73+
SMethod (..),
74+
TextDocumentIdentifier (TextDocumentIdentifier),
75+
TextEdit (TextEdit),
76+
WorkspaceEdit (WorkspaceEdit))
77+
import Text.Regex.TDFA ((=~), (=~~))
7578

7679
data Log = LogShake Shake.Log deriving Show
7780

@@ -99,46 +102,56 @@ properties = emptyProperties
99102
, (Diagnostics, "Follows error messages produced by GHC about missing signatures")
100103
] Always
101104

102-
codeLensProvider ::
103-
IdeState ->
104-
PluginId ->
105-
CodeLensParams ->
106-
LSP.LspM Config (Either ResponseError (List CodeLens))
107-
codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do
108-
mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties
109-
fmap (Right . List) $ case uriToFilePath' uri of
110-
Just (toNormalizedFilePath' -> filePath) -> liftIO $ do
111-
env <- fmap hscEnv <$> runAction "codeLens.GhcSession" ideState (use GhcSession filePath)
112-
tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath)
113-
bindings <- runAction "codeLens.GetBindings" ideState (use GetBindings filePath)
114-
gblSigs <- runAction "codeLens.GetGlobalBindingTypeSigs" ideState (use GetGlobalBindingTypeSigs filePath)
115-
116-
diag <- atomically $ getDiagnostics ideState
117-
hDiag <- atomically $ getHiddenDiagnostics ideState
118-
119-
let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing
120-
generateLensForGlobal sig@GlobalBindingTypeSig{..} = do
121-
range <- srcSpanToRange $ gbSrcSpan sig
122-
tedit <- gblBindingTypeSigToEdit sig
105+
codeLensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens
106+
codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = pluginResponse $ do
107+
mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties
108+
nfp <- getNormalizedFilePath uri
109+
env <- hscEnv . fst
110+
<$> (handleMaybeM "Unable to get GhcSession"
111+
$ liftIO
112+
$ runAction "codeLens.GhcSession" ideState (useWithStale GhcSession nfp)
113+
)
114+
tmr <- fst <$> (
115+
handleMaybeM "Unable to TypeCheck"
116+
$ liftIO
117+
$ runAction "codeLens.TypeCheck" ideState (useWithStale TypeCheck nfp)
118+
)
119+
bindings <- fst <$> (
120+
handleMaybeM "Unable to GetBindings"
121+
$ liftIO
122+
$ runAction "codeLens.GetBindings" ideState (useWithStale GetBindings nfp)
123+
)
124+
(gblSigs@(GlobalBindingTypeSigsResult gblSigs'), gblSigsMp) <-
125+
handleMaybeM "Unable to GetGlobalBindingTypeSigs"
126+
$ liftIO
127+
$ runAction "codeLens.GetGlobalBindingTypeSigs" ideState (useWithStale GetGlobalBindingTypeSigs nfp)
128+
129+
diag <- liftIO $ atomically $ getDiagnostics ideState
130+
hDiag <- liftIO $ atomically $ getHiddenDiagnostics ideState
131+
132+
let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing
133+
generateLensForGlobal mp sig@GlobalBindingTypeSig{gbRendered} = do
134+
range <- toCurrentRange mp =<< srcSpanToRange (gbSrcSpan sig)
135+
tedit <- gblBindingTypeSigToEdit sig (Just gblSigsMp)
123136
let wedit = toWorkSpaceEdit [tedit]
124137
pure $ generateLens pId range (T.pack gbRendered) wedit
125-
gblSigs' = maybe [] (\(GlobalBindingTypeSigsResult x) -> x) gblSigs
126-
generateLensFromDiags f =
127-
sequence
128-
[ pure $ generateLens pId _range title edit
138+
generateLensFromDiags f =
139+
[ generateLens pId _range title edit
129140
| (dFile, _, dDiag@Diagnostic{_range = _range}) <- diag ++ hDiag
130-
, dFile == filePath
141+
, dFile == nfp
131142
, (title, tedit) <- f dDiag
132143
, let edit = toWorkSpaceEdit tedit
133144
]
134-
135-
case mode of
145+
-- `suggestLocalSignature` relies on diagnostic, if diagnostics don't have the local signature warning,
146+
-- the `bindings` is useless, and if diagnostic has, that means we parsed success, and the `bindings` is fresh.
147+
pure $ List $ case mode of
136148
Always ->
137-
pure (catMaybes $ generateLensForGlobal <$> gblSigs')
138-
<> generateLensFromDiags (suggestLocalSignature False env tmr bindings) -- we still need diagnostics for local bindings
139-
Exported -> pure $ catMaybes $ generateLensForGlobal <$> filter gbExported gblSigs'
140-
Diagnostics -> generateLensFromDiags $ suggestSignature False env gblSigs tmr bindings
141-
Nothing -> pure []
149+
mapMaybe (generateLensForGlobal gblSigsMp) gblSigs'
150+
<> generateLensFromDiags
151+
(suggestLocalSignature False (Just env) (Just tmr) (Just bindings)) -- we still need diagnostics for local bindings
152+
Exported -> mapMaybe (generateLensForGlobal gblSigsMp) (filter gbExported gblSigs')
153+
Diagnostics -> generateLensFromDiags
154+
$ suggestSignature False (Just env) (Just gblSigs) (Just tmr) (Just bindings)
142155

143156
generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens
144157
generateLens pId _range title edit =
@@ -164,7 +177,7 @@ suggestGlobalSignature isQuickFix mGblSigs Diagnostic{_message, _range}
164177
, Just sig <- find (\x -> sameThing (gbSrcSpan x) _range) sigs
165178
, signature <- T.pack $ gbRendered sig
166179
, title <- if isQuickFix then "add signature: " <> signature else signature
167-
, Just action <- gblBindingTypeSigToEdit sig =
180+
, Just action <- gblBindingTypeSigToEdit sig Nothing =
168181
[(title, [action])]
169182
| otherwise = []
170183

@@ -194,12 +207,15 @@ suggestLocalSignature isQuickFix mEnv mTmr mBindings Diagnostic{_message, _range
194207
sameThing :: SrcSpan -> Range -> Bool
195208
sameThing s1 s2 = (_start <$> srcSpanToRange s1) == (_start <$> Just s2)
196209

197-
gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe TextEdit
198-
gblBindingTypeSigToEdit GlobalBindingTypeSig{..}
210+
gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe PositionMapping -> Maybe TextEdit
211+
gblBindingTypeSigToEdit GlobalBindingTypeSig{..} mmp
199212
| Just Range{..} <- srcSpanToRange $ getSrcSpan gbName
200213
, startOfLine <- Position (_line _start) 0
201-
, beforeLine <- Range startOfLine startOfLine =
202-
Just $ TextEdit beforeLine $ T.pack gbRendered <> "\n"
214+
, beforeLine <- Range startOfLine startOfLine
215+
-- If `mmp` is `Nothing`, return the original range, it used by lenses from diagnostic,
216+
-- otherwise we apply `toCurrentRange`, and the guard should fail if `toCurrentRange` failed.
217+
, Just range <- maybe (Just beforeLine) (flip toCurrentRange beforeLine) mmp
218+
= Just $ TextEdit range $ T.pack gbRendered <> "\n"
203219
| otherwise = Nothing
204220

205221
data Mode

‎ghcide/test/exe/Main.hs‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -969,6 +969,18 @@ addSigLensesTests =
969969
[ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) []
970970
, sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) []
971971
]
972+
, testSession "keep stale lens" $ do
973+
let content = T.unlines
974+
[ "module Stale where"
975+
, "f = _"
976+
]
977+
doc <- createDoc "Stale.hs" "haskell" content
978+
oldLens <- getCodeLenses doc
979+
liftIO $ length oldLens @?= 1
980+
let edit = TextEdit (mkRange 0 4 0 5) "" -- Remove the `_`
981+
_ <- applyEdit doc edit
982+
newLens <- getCodeLenses doc
983+
liftIO $ newLens @?= oldLens
972984
]
973985

974986
linkToLocation :: [LocationLink] -> [Location]

0 commit comments

Comments
 (0)