Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Keep type lenses stable #3558

Merged
merged 15 commits into from
May 5, 2023
Merged

Keep type lenses stable #3558

Show file tree
Hide file tree
Changes from 4 commits
Commits
Show all changes
15 commits
Select commit Hold shift + click to select a range
01f823c
Use stale type lens
July541 Apr 7, 2023
e83b282
Query position mapping if available
July541 Apr 16, 2023
d955cfa
Remove redundant code
July541 Apr 17, 2023
5b7ada6
Merge branch 'master' into stale-type-lens
July541 Apr 19, 2023
79d4965
Generate from diag doesn't depend on position mapping
July541 Apr 22, 2023
732864f
No stale diagnostic
July541 Apr 22, 2023
c40ea4e
Remove diagnostic chain
July541 Apr 22, 2023
b2270bc
indent
July541 Apr 22, 2023
87acc31
Merge branch 'master' into stale-type-lens
July541 Apr 22, 2023
3be1d46
Return Nothing if toCurrentRange failed
July541 Apr 22, 2023
5971783
Merge branch 'master' into stale-type-lens
July541 Apr 22, 2023
21d6836
Comment some suspicious code
July541 Apr 23, 2023
8210de5
Merge branch 'master' into stale-type-lens
mergify[bot] Apr 26, 2023
d41d06e
lens should work if mmp is Nothing
July541 May 4, 2023
c2fcf50
Merge branch 'master' into stale-type-lens
mergify[bot] May 5, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
231 changes: 129 additions & 102 deletions ghcide/src/Development/IDE/Plugin/TypeLenses.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -13,65 +13,69 @@ module Development.IDE.Plugin.TypeLenses (
Log(..)
) where

import Control.Concurrent.STM.Stats (atomically)
import Control.DeepSeq (rwhnf)
import Control.Monad (mzero)
import Control.Monad.Extra (whenMaybe)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Aeson.Types (Value (..), toJSON)
import qualified Data.Aeson.Types as A
import qualified Data.HashMap.Strict as Map
import Data.List (find)
import Data.Maybe (catMaybes)
import qualified Data.Text as T
import Development.IDE (GhcSession (..),
HscEnvEq (hscEnv),
RuleResult, Rules, define,
srcSpanToRange,
usePropertyAction)
import Development.IDE.Core.Compile (TcModuleResult (..))
import Development.IDE.Core.Rules (IdeState, runAction)
import Development.IDE.Core.RuleTypes (GetBindings (GetBindings),
TypeCheck (TypeCheck))
import Development.IDE.Core.Service (getDiagnostics)
import Development.IDE.Core.Shake (getHiddenDiagnostics, use)
import qualified Development.IDE.Core.Shake as Shake
import Control.Concurrent.STM.Stats (atomically)
import Control.DeepSeq (rwhnf)
import Control.Monad (mzero)
import Control.Monad.Extra (whenMaybe)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Aeson.Types (Value (..), toJSON)
import qualified Data.Aeson.Types as A
import qualified Data.HashMap.Strict as Map
import Data.List (find)
import Data.Maybe (catMaybes, fromMaybe,
mapMaybe)
import qualified Data.Text as T
import Development.IDE (GhcSession (..),
HscEnvEq (hscEnv),
RuleResult, Rules,
define, srcSpanToRange,
usePropertyAction,
useWithStale)
import Development.IDE.Core.Compile (TcModuleResult (..))
import Development.IDE.Core.PositionMapping (PositionMapping,
toCurrentRange)
import Development.IDE.Core.Rules (IdeState, runAction)
import Development.IDE.Core.RuleTypes (GetBindings (GetBindings),
TypeCheck (TypeCheck))
import Development.IDE.Core.Service (getDiagnostics)
import Development.IDE.Core.Shake (getHiddenDiagnostics,
use)
import qualified Development.IDE.Core.Shake as Shake
import Development.IDE.GHC.Compat
import Development.IDE.GHC.Util (printName)
import Development.IDE.GHC.Util (printName)
import Development.IDE.Graph.Classes
import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope)
import Development.IDE.Types.Location (Position (Position, _character, _line),
Range (Range, _end, _start),
toNormalizedFilePath',
uriToFilePath')
import Development.IDE.Types.Logger (Pretty (pretty), Recorder,
WithPriority,
cmapWithPrio)
import GHC.Generics (Generic)
import Ide.Plugin.Config (Config)
import Development.IDE.Spans.LocalBindings (Bindings, getFuzzyScope)
import Development.IDE.Types.Location (Position (Position, _character, _line),
Range (Range, _end, _start))
import Development.IDE.Types.Logger (Pretty (pretty),
Recorder, WithPriority,
cmapWithPrio)
import GHC.Generics (Generic)
import Ide.Plugin.Properties
import Ide.PluginUtils (mkLspCommand)
import Ide.Types (CommandFunction,
CommandId (CommandId),
PluginCommand (PluginCommand),
PluginDescriptor (..),
PluginId,
configCustomConfig,
defaultConfigDescriptor,
defaultPluginDescriptor,
mkCustomConfig,
mkPluginHandler)
import qualified Language.LSP.Server as LSP
import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
CodeLens (CodeLens),
CodeLensParams (CodeLensParams, _textDocument),
Diagnostic (..),
List (..), ResponseError,
SMethod (..),
TextDocumentIdentifier (TextDocumentIdentifier),
TextEdit (TextEdit),
WorkspaceEdit (WorkspaceEdit))
import Text.Regex.TDFA ((=~), (=~~))
import Ide.PluginUtils
import Ide.Types (CommandFunction,
CommandId (CommandId),
PluginCommand (PluginCommand),
PluginDescriptor (..),
PluginId,
PluginMethodHandler,
configCustomConfig,
defaultConfigDescriptor,
defaultPluginDescriptor,
mkCustomConfig,
mkPluginHandler)
import qualified Language.LSP.Server as LSP
import Language.LSP.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams),
CodeLens (CodeLens),
CodeLensParams (CodeLensParams, _textDocument),
Diagnostic (..),
List (..),
Method (TextDocumentCodeLens),
SMethod (..),
TextDocumentIdentifier (TextDocumentIdentifier),
TextEdit (TextEdit),
WorkspaceEdit (WorkspaceEdit))
import Text.Regex.TDFA ((=~), (=~~))

data Log = LogShake Shake.Log deriving Show

Expand Down Expand Up @@ -99,46 +103,55 @@ properties = emptyProperties
, (Diagnostics, "Follows error messages produced by GHC about missing signatures")
] Always

codeLensProvider ::
IdeState ->
PluginId ->
CodeLensParams ->
LSP.LspM Config (Either ResponseError (List CodeLens))
codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do
mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties
fmap (Right . List) $ case uriToFilePath' uri of
Just (toNormalizedFilePath' -> filePath) -> liftIO $ do
env <- fmap hscEnv <$> runAction "codeLens.GhcSession" ideState (use GhcSession filePath)
tmr <- runAction "codeLens.TypeCheck" ideState (use TypeCheck filePath)
bindings <- runAction "codeLens.GetBindings" ideState (use GetBindings filePath)
gblSigs <- runAction "codeLens.GetGlobalBindingTypeSigs" ideState (use GetGlobalBindingTypeSigs filePath)

diag <- atomically $ getDiagnostics ideState
hDiag <- atomically $ getHiddenDiagnostics ideState

let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing
generateLensForGlobal sig@GlobalBindingTypeSig{..} = do
range <- srcSpanToRange $ gbSrcSpan sig
tedit <- gblBindingTypeSigToEdit sig
codeLensProvider :: PluginMethodHandler IdeState TextDocumentCodeLens
codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = pluginResponse $ do
mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties
nfp <- getNormalizedFilePath uri
env <- hscEnv . fst
<$> (handleMaybeM "Unable to get GhcSession"
$ liftIO
$ runAction "codeLens.GhcSession" ideState (useWithStale GhcSession nfp)
)
tmr <- fst <$> (
handleMaybeM "Unable to TypeCheck"
$ liftIO
$ runAction "codeLens.TypeCheck" ideState (useWithStale TypeCheck nfp)
)
(bindings, bindingsMp) <-
handleMaybeM "Unable to GetBindings"
$ liftIO
$ runAction "codeLens.GetBindings" ideState (useWithStale GetBindings nfp)
(gblSigs@(GlobalBindingTypeSigsResult gblSigs'), gblSigsMp) <-
handleMaybeM "Unable to GetGlobalBindingTypeSigs"
$ liftIO
$ runAction "codeLens.GetGlobalBindingTypeSigs" ideState (useWithStale GetGlobalBindingTypeSigs nfp)

diag <- liftIO $ atomically $ getDiagnostics ideState
hDiag <- liftIO $ atomically $ getHiddenDiagnostics ideState

let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing
generateLensForGlobal mp sig@GlobalBindingTypeSig{..} = do
July541 marked this conversation as resolved.
Show resolved Hide resolved
range <- toCurrentRange mp =<< srcSpanToRange (gbSrcSpan sig)
tedit <- gblBindingTypeSigToEdit sig (Just gblSigsMp)
let wedit = toWorkSpaceEdit [tedit]
pure $ generateLens pId range (T.pack gbRendered) wedit
gblSigs' = maybe [] (\(GlobalBindingTypeSigsResult x) -> x) gblSigs
generateLensFromDiags f =
sequence
[ pure $ generateLens pId _range title edit
generateLensFromDiags mp f =
July541 marked this conversation as resolved.
Show resolved Hide resolved
catMaybes
[ fmap (\range -> generateLens pId range title edit) mrange
| (dFile, _, dDiag@Diagnostic{_range = _range}) <- diag ++ hDiag
, dFile == filePath
, dFile == nfp
, (title, tedit) <- f dDiag
, let edit = toWorkSpaceEdit tedit
, let mrange = toCurrentRange mp _range
]

case mode of
pure $ List $ case mode of
Always ->
pure (catMaybes $ generateLensForGlobal <$> gblSigs')
<> generateLensFromDiags (suggestLocalSignature False env tmr bindings) -- we still need diagnostics for local bindings
Exported -> pure $ catMaybes $ generateLensForGlobal <$> filter gbExported gblSigs'
Diagnostics -> generateLensFromDiags $ suggestSignature False env gblSigs tmr bindings
Nothing -> pure []
mapMaybe (generateLensForGlobal gblSigsMp) gblSigs'
<> generateLensFromDiags bindingsMp
(suggestLocalSignature False (Just env) (Just tmr) (Just bindings) (Just bindingsMp)) -- we still need diagnostics for local bindings
Exported -> mapMaybe (generateLensForGlobal gblSigsMp) (filter gbExported gblSigs')
Diagnostics -> generateLensFromDiags bindingsMp
$ suggestSignature' False (Just env) (Just gblSigs) (Just tmr) (Just bindings) (Just gblSigsMp) (Just bindingsMp)

generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens
generateLens pId _range title edit =
Expand All @@ -153,23 +166,35 @@ commandHandler _ideState wedit = do
--------------------------------------------------------------------------------

suggestSignature :: Bool -> Maybe HscEnv -> Maybe GlobalBindingTypeSigsResult -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])]
suggestSignature isQuickFix env mGblSigs mTmr mBindings diag =
suggestGlobalSignature isQuickFix mGblSigs diag <> suggestLocalSignature isQuickFix env mTmr mBindings diag

suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, [TextEdit])]
suggestGlobalSignature isQuickFix mGblSigs Diagnostic{_message, _range}
suggestSignature isQuickFix env mGblSigs mTmr mBindings diag = suggestSignature' isQuickFix env mGblSigs mTmr mBindings Nothing Nothing diag

suggestSignature' ::
Bool
-> Maybe HscEnv
-> Maybe GlobalBindingTypeSigsResult
-> Maybe TcModuleResult
-> Maybe Bindings
-> Maybe PositionMapping
-> Maybe PositionMapping
-> Diagnostic
-> [(T.Text, [TextEdit])]
suggestSignature' isQuickFix env mGblSigs mTmr mBindings gblMp bindingMp diag =
suggestGlobalSignature isQuickFix mGblSigs gblMp diag <> suggestLocalSignature isQuickFix env mTmr mBindings bindingMp diag

suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe PositionMapping -> Diagnostic -> [(T.Text, [TextEdit])]
suggestGlobalSignature isQuickFix mGblSigs mmp Diagnostic{_message, _range}
| _message
=~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text)
, Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs
, Just sig <- find (\x -> sameThing (gbSrcSpan x) _range) sigs
, signature <- T.pack $ gbRendered sig
, title <- if isQuickFix then "add signature: " <> signature else signature
, Just action <- gblBindingTypeSigToEdit sig =
, Just action <- gblBindingTypeSigToEdit sig mmp =
[(title, [action])]
| otherwise = []

suggestLocalSignature :: Bool -> Maybe HscEnv -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])]
suggestLocalSignature isQuickFix mEnv mTmr mBindings Diagnostic{_message, _range = _range@Range{..}}
suggestLocalSignature :: Bool -> Maybe HscEnv -> Maybe TcModuleResult -> Maybe Bindings -> Maybe PositionMapping -> Diagnostic -> [(T.Text, [TextEdit])]
suggestLocalSignature isQuickFix mEnv mTmr mBindings mmp Diagnostic{_message, _range = _range@Range{..}}
| Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <-
(T.unwords . T.words $ _message)
=~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text)
Expand All @@ -187,19 +212,21 @@ suggestLocalSignature isQuickFix mEnv mTmr mBindings Diagnostic{_message, _range
, startOfLine <- Position (_line _start) startCharacter
, beforeLine <- Range startOfLine startOfLine
, title <- if isQuickFix then "add signature: " <> signature else signature
, action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate (fromIntegral startCharacter) " " =
, range' <- fromMaybe beforeLine (flip toCurrentRange beforeLine =<< mmp)
July541 marked this conversation as resolved.
Show resolved Hide resolved
, action <- TextEdit range' $ signature <> "\n" <> T.replicate (fromIntegral startCharacter) " " =
[(title, [action])]
| otherwise = []

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

gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe TextEdit
gblBindingTypeSigToEdit GlobalBindingTypeSig{..}
gblBindingTypeSigToEdit :: GlobalBindingTypeSig -> Maybe PositionMapping -> Maybe TextEdit
gblBindingTypeSigToEdit GlobalBindingTypeSig{..} mmp
| Just Range{..} <- srcSpanToRange $ getSrcSpan gbName
, startOfLine <- Position (_line _start) 0
, beforeLine <- Range startOfLine startOfLine =
Just $ TextEdit beforeLine $ T.pack gbRendered <> "\n"
, beforeLine <- Range startOfLine startOfLine
, range' <- fromMaybe beforeLine (flip toCurrentRange beforeLine =<< mmp)
July541 marked this conversation as resolved.
Show resolved Hide resolved
= Just $ TextEdit range' $ T.pack gbRendered <> "\n"
| otherwise = Nothing

data Mode
Expand Down
12 changes: 12 additions & 0 deletions ghcide/test/exe/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -969,6 +969,18 @@ addSigLensesTests =
[ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) []
, sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) []
]
, testSession "keep stale lens" $ do
let content = T.unlines
[ "module Stale where"
, "f = _"
]
doc <- createDoc "Stale.hs" "haskell" content
oldLens <- getCodeLenses doc
liftIO $ length oldLens @?= 1
let edit = TextEdit (mkRange 0 4 0 5) "" -- Remove the `_`
_ <- applyEdit doc edit
newLens <- getCodeLenses doc
liftIO $ newLens @?= oldLens
]

linkToLocation :: [LocationLink] -> [Location]
Expand Down