From 01f823c8ced71a262332689ea61ec63c274caa8d Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Fri, 7 Apr 2023 22:51:15 +0800 Subject: [PATCH 01/10] Use stale type lens --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 13 ++++++++----- ghcide/test/exe/Main.hs | 12 ++++++++++++ 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 81cef1b053..7342dab30b 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -28,7 +28,8 @@ import Development.IDE (GhcSession (..), HscEnvEq (hscEnv), RuleResult, Rules, define, srcSpanToRange, - usePropertyAction) + usePropertyAction, + useWithStale) import Development.IDE.Core.Compile (TcModuleResult (..)) import Development.IDE.Core.Rules (IdeState, runAction) import Development.IDE.Core.RuleTypes (GetBindings (GetBindings), @@ -108,10 +109,12 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif 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) + -- Using stale results means that we can almost always return a value. In practice + -- this means the lenses don't 'flicker' + env <- fmap (hscEnv . fst) <$> runAction "codeLens.GhcSession" ideState (useWithStale GhcSession filePath) + tmr <- fmap fst <$> runAction "codeLens.TypeCheck" ideState (useWithStale TypeCheck filePath) + bindings <- fmap fst <$> runAction "codeLens.GetBindings" ideState (useWithStale GetBindings filePath) + gblSigs <- fmap fst <$> runAction "codeLens.GetGlobalBindingTypeSigs" ideState (useWithStale GetGlobalBindingTypeSigs filePath) diag <- atomically $ getDiagnostics ideState hDiag <- atomically $ getHiddenDiagnostics ideState diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index 231014a071..7c58112b26 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -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] From e83b282846698cdc0c6f3640743fd82443504c1a Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Sun, 16 Apr 2023 17:22:39 +0800 Subject: [PATCH 02/10] Query position mapping if available --- .../src/Development/IDE/Plugin/TypeLenses.hs | 196 +++++++++++------- 1 file changed, 126 insertions(+), 70 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 7342dab30b..ae85ff4dc7 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -13,66 +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, - useWithStale) -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 @@ -86,7 +89,7 @@ typeLensCommandId = "typesignature.add" descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider + { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider' , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] , pluginRules = rules recorder , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} @@ -100,6 +103,43 @@ properties = emptyProperties , (Diagnostics, "Follows error messages produced by GHC about missing signatures") ] Always +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', _) <- handleMaybeM "Unable to get GhcSession" $ liftIO $ runAction "codeLens.GhcSession" ideState (useWithStale GhcSession nfp) + let env = hscEnv env' + (tmr, tmrMp) <- 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 + range <- toCurrentRange mp =<< srcSpanToRange (gbSrcSpan sig) + tedit <- gblBindingTypeSigToEdit sig (Just gblSigsMp) + let wedit = toWorkSpaceEdit [tedit] + pure $ generateLens pId range (T.pack gbRendered) wedit + generateLensFromDiags mp f = + catMaybes + [ fmap (\range -> generateLens pId range title edit) mrange + | (dFile, _, dDiag@Diagnostic{_range = _range}) <- diag ++ hDiag + , dFile == nfp + , (title, tedit) <- f dDiag + , let edit = toWorkSpaceEdit tedit + , let mrange = toCurrentRange mp _range + ] + pure $ List $ case mode of + Always -> + 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) + +{- codeLensProvider :: IdeState -> PluginId -> @@ -142,6 +182,7 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif Exported -> pure $ catMaybes $ generateLensForGlobal <$> filter gbExported gblSigs' Diagnostics -> generateLensFromDiags $ suggestSignature False env gblSigs tmr bindings Nothing -> pure [] +-} generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens generateLens pId _range title edit = @@ -157,22 +198,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} + suggestGlobalSignature isQuickFix mGblSigs Nothing diag <> suggestLocalSignature isQuickFix env mTmr mBindings 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) @@ -190,19 +244,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) + , 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) + = Just $ TextEdit range' $ T.pack gbRendered <> "\n" | otherwise = Nothing data Mode From d955cfaa90b1bef189f87f4c1f1389b8998aa885 Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Mon, 17 Apr 2023 22:28:24 +0800 Subject: [PATCH 03/10] Remove redundant code --- .../src/Development/IDE/Plugin/TypeLenses.hs | 80 ++++++------------- 1 file changed, 24 insertions(+), 56 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index ae85ff4dc7..1aa68f51e8 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -89,7 +89,7 @@ typeLensCommandId = "typesignature.add" descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState descriptor recorder plId = (defaultPluginDescriptor plId) - { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider' + { pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLensProvider , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] , pluginRules = rules recorder , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} @@ -103,15 +103,28 @@ properties = emptyProperties , (Diagnostics, "Follows error messages produced by GHC about missing signatures") ] Always -codeLensProvider' :: PluginMethodHandler IdeState TextDocumentCodeLens -codeLensProvider' ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = pluginResponse $ do +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', _) <- handleMaybeM "Unable to get GhcSession" $ liftIO $ runAction "codeLens.GhcSession" ideState (useWithStale GhcSession nfp) - let env = hscEnv env' - (tmr, tmrMp) <- 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) + 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 @@ -134,56 +147,12 @@ codeLensProvider' ideState pId CodeLensParams{_textDocument = TextDocumentIdenti pure $ List $ case mode of Always -> mapMaybe (generateLensForGlobal gblSigsMp) gblSigs' - <> generateLensFromDiags bindingsMp (suggestLocalSignature False (Just env) (Just tmr) (Just bindings) (Just bindingsMp)) -- we still need diagnostics for local bindings + <> 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) -{- -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 - -- Using stale results means that we can almost always return a value. In practice - -- this means the lenses don't 'flicker' - env <- fmap (hscEnv . fst) <$> runAction "codeLens.GhcSession" ideState (useWithStale GhcSession filePath) - tmr <- fmap fst <$> runAction "codeLens.TypeCheck" ideState (useWithStale TypeCheck filePath) - bindings <- fmap fst <$> runAction "codeLens.GetBindings" ideState (useWithStale GetBindings filePath) - gblSigs <- fmap fst <$> runAction "codeLens.GetGlobalBindingTypeSigs" ideState (useWithStale 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 - 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 - | (dFile, _, dDiag@Diagnostic{_range = _range}) <- diag ++ hDiag - , dFile == filePath - , (title, tedit) <- f dDiag - , let edit = toWorkSpaceEdit tedit - ] - - 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 [] --} - generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens generateLens pId _range title edit = let cId = mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit]) @@ -197,8 +166,7 @@ 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 Nothing diag <> suggestLocalSignature isQuickFix env mTmr mBindings Nothing diag +suggestSignature isQuickFix env mGblSigs mTmr mBindings diag = suggestSignature' isQuickFix env mGblSigs mTmr mBindings Nothing Nothing diag suggestSignature' :: Bool From 79d4965bcc3b1da07152fd237d163e748dce0bf5 Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Sat, 22 Apr 2023 18:52:37 +0800 Subject: [PATCH 04/10] Generate from diag doesn't depend on position mapping --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 1aa68f51e8..696dccc6df 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -130,27 +130,25 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif hDiag <- liftIO $ atomically $ getHiddenDiagnostics ideState let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing Nothing - generateLensForGlobal mp sig@GlobalBindingTypeSig{..} = do + 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 - generateLensFromDiags mp f = - catMaybes - [ fmap (\range -> generateLens pId range title edit) mrange + generateLensFromDiags f = + [ generateLens pId _range title edit | (dFile, _, dDiag@Diagnostic{_range = _range}) <- diag ++ hDiag , dFile == nfp , (title, tedit) <- f dDiag , let edit = toWorkSpaceEdit tedit - , let mrange = toCurrentRange mp _range ] pure $ List $ case mode of Always -> mapMaybe (generateLensForGlobal gblSigsMp) gblSigs' - <> generateLensFromDiags bindingsMp + <> generateLensFromDiags (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 + Diagnostics -> generateLensFromDiags $ suggestSignature' False (Just env) (Just gblSigs) (Just tmr) (Just bindings) (Just gblSigsMp) (Just bindingsMp) generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens From 732864faf4c94cf1cf4161e9129dc1e880c68916 Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Sat, 22 Apr 2023 20:22:22 +0800 Subject: [PATCH 05/10] No stale diagnostic --- .../src/Development/IDE/Plugin/TypeLenses.hs | 35 ++++++------------- 1 file changed, 11 insertions(+), 24 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 696dccc6df..c76ac4cc67 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -117,10 +117,11 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif $ liftIO $ runAction "codeLens.TypeCheck" ideState (useWithStale TypeCheck nfp) ) - (bindings, bindingsMp) <- - handleMaybeM "Unable to GetBindings" - $ liftIO - $ runAction "codeLens.GetBindings" ideState (useWithStale GetBindings nfp) + bindings <- fst <$> ( + handleMaybeM "Unable to GetBindings" + $ liftIO + $ runAction "codeLens.GetBindings" ideState (useWithStale GetBindings nfp) + ) (gblSigs@(GlobalBindingTypeSigsResult gblSigs'), gblSigsMp) <- handleMaybeM "Unable to GetGlobalBindingTypeSigs" $ liftIO @@ -146,10 +147,10 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif Always -> mapMaybe (generateLensForGlobal gblSigsMp) gblSigs' <> generateLensFromDiags - (suggestLocalSignature False (Just env) (Just tmr) (Just bindings) (Just bindingsMp)) -- we still need diagnostics for local bindings + (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) (Just gblSigsMp) (Just bindingsMp) + $ suggestSignature False (Just env) (Just gblSigs) (Just tmr) (Just bindings) generateLens :: PluginId -> Range -> T.Text -> WorkspaceEdit -> CodeLens generateLens pId _range title edit = @@ -164,20 +165,7 @@ 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 = 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 +suggestSignature isQuickFix env mGblSigs mTmr mBindings diag = suggestGlobalSignature isQuickFix mGblSigs Nothing diag <> suggestLocalSignature isQuickFix env mTmr mBindings diag suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe PositionMapping -> Diagnostic -> [(T.Text, [TextEdit])] suggestGlobalSignature isQuickFix mGblSigs mmp Diagnostic{_message, _range} @@ -191,8 +179,8 @@ suggestGlobalSignature isQuickFix mGblSigs mmp Diagnostic{_message, _range} [(title, [action])] | otherwise = [] -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{..}} +suggestLocalSignature :: Bool -> Maybe HscEnv -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] +suggestLocalSignature isQuickFix mEnv mTmr mBindings 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) @@ -210,8 +198,7 @@ suggestLocalSignature isQuickFix mEnv mTmr mBindings mmp Diagnostic{_message, _r , startOfLine <- Position (_line _start) startCharacter , beforeLine <- Range startOfLine startOfLine , title <- if isQuickFix then "add signature: " <> signature else signature - , range' <- fromMaybe beforeLine (flip toCurrentRange beforeLine =<< mmp) - , action <- TextEdit range' $ signature <> "\n" <> T.replicate (fromIntegral startCharacter) " " = + , action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate (fromIntegral startCharacter) " " = [(title, [action])] | otherwise = [] From c40ea4ed8a6340baeb0c81f641228d86fefba86c Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Sat, 22 Apr 2023 20:26:44 +0800 Subject: [PATCH 06/10] Remove diagnostic chain --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index c76ac4cc67..493e1ff3f5 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -165,17 +165,17 @@ 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 Nothing diag <> suggestLocalSignature isQuickFix env mTmr mBindings diag +suggestSignature isQuickFix env mGblSigs mTmr mBindings diag = suggestGlobalSignature isQuickFix mGblSigs diag <> suggestLocalSignature isQuickFix env mTmr mBindings diag -suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe PositionMapping -> Diagnostic -> [(T.Text, [TextEdit])] -suggestGlobalSignature isQuickFix mGblSigs mmp Diagnostic{_message, _range} +suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, [TextEdit])] +suggestGlobalSignature isQuickFix mGblSigs 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 mmp = + , Just action <- gblBindingTypeSigToEdit sig Nothing = [(title, [action])] | otherwise = [] From b2270bc41c7e8e241aabd8a37fecd9694f10f5ac Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Sat, 22 Apr 2023 20:27:58 +0800 Subject: [PATCH 07/10] indent --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 493e1ff3f5..33ef402a28 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -165,7 +165,8 @@ 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 +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} From 3be1d469805594179ff6df6c2fe177ed2dd1e53e Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Sat, 22 Apr 2023 23:41:09 +0800 Subject: [PATCH 08/10] Return Nothing if toCurrentRange failed --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 33ef402a28..a11b710a8f 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -22,8 +22,7 @@ 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 Data.Maybe (catMaybes, mapMaybe) import qualified Data.Text as T import Development.IDE (GhcSession (..), HscEnvEq (hscEnv), @@ -211,8 +210,9 @@ gblBindingTypeSigToEdit GlobalBindingTypeSig{..} mmp | Just Range{..} <- srcSpanToRange $ getSrcSpan gbName , startOfLine <- Position (_line _start) 0 , beforeLine <- Range startOfLine startOfLine - , range' <- fromMaybe beforeLine (flip toCurrentRange beforeLine =<< mmp) - = Just $ TextEdit range' $ T.pack gbRendered <> "\n" + , Just mp <- mmp + , Just range <- toCurrentRange mp beforeLine + = Just $ TextEdit range $ T.pack gbRendered <> "\n" | otherwise = Nothing data Mode From 21d6836706fa8504d352ea09b78ab4d4404d1f70 Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Sun, 23 Apr 2023 20:25:39 +0800 Subject: [PATCH 09/10] Comment some suspicious code --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index a11b710a8f..068f6c4485 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -142,6 +142,8 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif , (title, tedit) <- f dDiag , let edit = toWorkSpaceEdit tedit ] + -- `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 -> mapMaybe (generateLensForGlobal gblSigsMp) gblSigs' From d41d06e6ad3dafd31d153e89eb33d749e121ccb8 Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Thu, 4 May 2023 23:03:45 +0800 Subject: [PATCH 10/10] lens should work if mmp is Nothing --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 068f6c4485..806dca3969 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -212,8 +212,9 @@ gblBindingTypeSigToEdit GlobalBindingTypeSig{..} mmp | Just Range{..} <- srcSpanToRange $ getSrcSpan gbName , startOfLine <- Position (_line _start) 0 , beforeLine <- Range startOfLine startOfLine - , Just mp <- mmp - , Just range <- toCurrentRange mp beforeLine + -- 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 = Just $ TextEdit range $ T.pack gbRendered <> "\n" | otherwise = Nothing