Skip to content

Keep type lenses stable #3558

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

Merged
merged 15 commits into from
May 5, 2023
Merged

Keep type lenses stable #3558

Show file tree
Hide file tree
Changes from all 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
204 changes: 110 additions & 94 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,68 @@ 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, 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 +102,56 @@ 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 <- fst <$> (
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{gbRendered} = do
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 f =
[ generateLens pId _range title edit
| (dFile, _, dDiag@Diagnostic{_range = _range}) <- diag ++ hDiag
, dFile == filePath
, dFile == nfp
, (title, tedit) <- f dDiag
, let edit = toWorkSpaceEdit tedit
]

case mode of
-- `suggestLocalSignature` relies on diagnostic, if diagnostics don't have the local signature warning,
-- the `bindings` is useless, and if diagnostic has, that means we parsed success, and the `bindings` is fresh.
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
(suggestLocalSignature False (Just env) (Just tmr) (Just bindings)) -- we still need diagnostics for local bindings
Exported -> mapMaybe (generateLensForGlobal gblSigsMp) (filter gbExported gblSigs')
Diagnostics -> generateLensFromDiags
$ suggestSignature False (Just env) (Just gblSigs) (Just tmr) (Just bindings)

generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens
generateLens pId _range title edit =
Expand All @@ -164,7 +177,7 @@ suggestGlobalSignature isQuickFix mGblSigs Diagnostic{_message, _range}
, 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 Nothing =
[(title, [action])]
| otherwise = []

Expand Down Expand Up @@ -194,12 +207,15 @@ suggestLocalSignature isQuickFix mEnv mTmr mBindings Diagnostic{_message, _range
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
-- If `mmp` is `Nothing`, return the original range, it used by lenses from diagnostic,
-- otherwise we apply `toCurrentRange`, and the guard should fail if `toCurrentRange` failed.
, Just range <- maybe (Just beforeLine) (flip toCurrentRange beforeLine) mmp
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I mixed the scene if mmp is Nothing, thanks ci halt this 😅

= 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