diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 81cef1b053..806dca3969 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -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 @@ -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 = @@ -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 = [] @@ -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 + = Just $ TextEdit range $ T.pack gbRendered <> "\n" | otherwise = Nothing data Mode 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]