From dd1da841bd6e8a1e25693aaeb5e6a7a63543a40a Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 4 Aug 2023 23:10:19 +0300 Subject: [PATCH 1/6] Support resolve in type lenses --- .../src/Development/IDE/Plugin/TypeLenses.hs | 236 ++++++++++++------ ghcide/test/exe/CodeLensTests.hs | 36 ++- 2 files changed, 192 insertions(+), 80 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 84ee6f0c67..c755cc3185 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -15,24 +15,27 @@ module Development.IDE.Plugin.TypeLenses ( import Control.Concurrent.STM.Stats (atomically) import Control.DeepSeq (rwhnf) +import Control.Lens ((?~)) import Control.Monad (mzero) import Control.Monad.Extra (whenMaybe) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (MonadTrans (lift)) -import Data.Aeson.Types (Value, toJSON) +import Data.Aeson.Types (toJSON) import qualified Data.Aeson.Types as A -import Data.List (find) +import Data.List (find, intercalate) import qualified Data.Map as Map -import Data.Maybe (catMaybes, mapMaybe) +import Data.Maybe (catMaybes, fromMaybe, + maybeToList) import qualified Data.Text as T import Development.IDE (GhcSession (..), HscEnvEq (hscEnv), - RuleResult, Rules, + RuleResult, Rules, Uri, define, srcSpanToRange, usePropertyAction) import Development.IDE.Core.Compile (TcModuleResult (..)) import Development.IDE.Core.PluginUtils import Development.IDE.Core.PositionMapping (PositionMapping, + fromCurrentRange, toCurrentRange) import Development.IDE.Core.Rules (IdeState, runAction) import Development.IDE.Core.RuleTypes (GetBindings (GetBindings), @@ -60,17 +63,20 @@ import Ide.Types (CommandFunction, PluginDescriptor (..), PluginId, PluginMethodHandler, + ResolveFunction, configCustomConfig, defaultConfigDescriptor, defaultPluginDescriptor, mkCustomConfig, - mkPluginHandler) -import Language.LSP.Protocol.Message (Method (Method_TextDocumentCodeLens), + mkPluginHandler, + mkResolveHandler) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message (Method (Method_CodeLensResolve, Method_TextDocumentCodeLens), SMethod (..)) import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams (ApplyWorkspaceEditParams), - CodeLens (CodeLens), + CodeLens (..), CodeLensParams (CodeLensParams, _textDocument), - Diagnostic (..), + Command, Diagnostic (..), Null (Null), TextDocumentIdentifier (TextDocumentIdentifier), TextEdit (TextEdit), @@ -85,6 +91,7 @@ instance Pretty Log where pretty = \case LogShake log -> pretty log + typeLensCommandId :: T.Text typeLensCommandId = "typesignature.add" @@ -92,6 +99,7 @@ descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeSta descriptor recorder plId = (defaultPluginDescriptor plId) { pluginHandlers = mkPluginHandler SMethod_TextDocumentCodeLens codeLensProvider + <> mkResolveHandler SMethod_CodeLensResolve codeLensResolveProvider , pluginCommands = [PluginCommand (CommandId typeLensCommandId) "adds a signature" commandHandler] , pluginRules = rules recorder , pluginConfigDescriptor = defaultConfigDescriptor {configCustomConfig = mkCustomConfig properties} @@ -109,81 +117,154 @@ codeLensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties nfp <- getNormalizedFilePathE uri - env <- hscEnv . fst <$> - runActionE "codeLens.GhcSession" ideState - (useWithStaleE GhcSession nfp) - - (tmr, _) <- runActionE "codeLens.TypeCheck" ideState - (useWithStaleE TypeCheck nfp) - - (bindings, _) <- runActionE "codeLens.GetBindings" ideState - (useWithStaleE GetBindings nfp) - - (gblSigs@(GlobalBindingTypeSigsResult gblSigs'), gblSigsMp) <- - runActionE "codeLens.GetGlobalBindingTypeSigs" ideState - (useWithStaleE GetGlobalBindingTypeSigs nfp) - - diag <- liftIO $ atomically $ getDiagnostics ideState - hDiag <- liftIO $ atomically $ getHiddenDiagnostics ideState - - let toWorkSpaceEdit tedit = WorkspaceEdit (Just $ Map.singleton uri $ 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 - generateLensFromDiags f = - [ generateLens pId _range title edit - | (dFile, _, dDiag@Diagnostic{_range = _range}) <- diag ++ hDiag - , dFile == nfp - , (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 $ InL $ case mode of - Always -> - 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 = - let cId = mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON edit]) - in CodeLens _range (Just cId) Nothing - + -- We have three ways we can possibly generate code lenses for type lenses. + -- Different options are with different "modes" of the typelens plugin. + -- (Remember here, as the code lens is not resolved yet, we only really need + -- the range and any data that will help us resolve it later) + let -- The first option is to generate the lens from diagnostics about local + -- bindings. + -- TODO: We need the identifier, but not sure we need the _range. + -- One I get it to reliably work I can find out. + generateLensFromLocalDiags diags = + [ CodeLens _range Nothing (Just $ toJSON $ TypeLensesResolveLocal identifier _range) + | (dFile, _, Diagnostic{_range, _message}) <- diags + , dFile == nfp + , Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <- + [(T.unwords . T.words $ _message) + =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text)]] + -- The second option is to generate lens from diagnostics about + -- top level bindings. Even though we don't need any extra data besides + -- the range to resolve this later, we still need to put data in here + -- because code lenses without data are not resolvable with HLS + generateLensFromGlobalDiags diags = + -- We have different methods for generating global lenses depending on + -- the mode chosen, but all lenses are resolved the same way. + [ CodeLens _range Nothing (Just $ toJSON TypeLensesResolveGlobal) + | (dFile, _, Diagnostic{_range, _message}) <- diags + , dFile == nfp + , _message + =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text)] + -- The third option is to generate lenses from the GlobalBindingTypeSig + -- rule. This is the only type that needs to have the range adjusted + -- with PositionMapping + generateLensFromGlobal sigs mp = do + [ CodeLens newRange Nothing (Just $ toJSON TypeLensesResolveGlobal) + | sig <- sigs + , Just range <- [srcSpanToRange (gbSrcSpan sig)] + , Just newRange <- [toCurrentRange mp range]] + case mode of + Always -> do + -- This is sort of a hybrid method, where we get the global bindings + -- from the GlobalBindingTypeSigs rule, and the local bindings from + -- diagnostics. + diags <- liftIO $ atomically $ getDiagnostics ideState + hDiags <- liftIO $ atomically $ getHiddenDiagnostics ideState + (GlobalBindingTypeSigsResult gblSigs, gblSigsMp) <- + runActionE "codeLens.GetGlobalBindingTypeSigs" ideState + $ useWithStaleE GetGlobalBindingTypeSigs nfp + pure $ InL $ generateLensFromGlobal gblSigs gblSigsMp + <> generateLensFromLocalDiags (diags <> hDiags) -- we still need diagnostics for local bindings + Exported -> do + -- In this rule we only get bindings from the GlobalBindingTypeSigs + -- rule, and in addition we filter out the non exported symbols + (GlobalBindingTypeSigsResult gblSigs, gblSigsMp) <- + runActionE "codeLens.GetGlobalBindingTypeSigs" ideState + $ useWithStaleE GetGlobalBindingTypeSigs nfp + pure $ InL $ generateLensFromGlobal (filter gbExported gblSigs) gblSigsMp + Diagnostics -> do + -- For this mode we exclusively use diagnostics to create the lenses. + -- However we will still use the GlobalBindingTypeSigs to resolve them. + -- This is how it was done also before the changes to support resolve. + diags <- liftIO $ atomically $ getDiagnostics ideState + hDiags <- liftIO $ atomically $ getHiddenDiagnostics ideState + let allDiags = diags <> hDiags + pure $ InL $ generateLensFromLocalDiags allDiags <> generateLensFromGlobalDiags allDiags + +-- When resolving a type lens we only care whether it is local or global. +codeLensResolveProvider :: ResolveFunction IdeState TypeLensesResolveData Method_CodeLensResolve +codeLensResolveProvider ideState pId lens uri TypeLensesResolveLocal{identifier, range} = do + nfp <- getNormalizedFilePathE uri + (hscEnv -> env, _) <- runActionE "codeLens.GhcSession" ideState + (useWithStaleE GhcSession nfp) + (tmr, _) <- runActionE "codeLens.TypeCheck" ideState + (useWithStaleE TypeCheck nfp) + (bindings, _) <- runActionE "codeLens.GetBindings" ideState + (useWithStaleE GetBindings nfp) + -- To create a local signature, we need a lot more moving parts, as we don't + -- have any specific rule created for it. + (title, edit) <- handleMaybe PluginStaleResolve $ suggestLocalSignature' False (Just env) (Just tmr) (Just bindings) identifier range + pure $ lens & L.command ?~ generateLensCommand pId uri title edit +codeLensResolveProvider ideState pId lens@CodeLens{_range} uri TypeLensesResolveGlobal = do + nfp <- getNormalizedFilePathE uri + (gblSigs@(GlobalBindingTypeSigsResult _), gblSigsMp) <- + runActionE "codeLens.GetGlobalBindingTypeSigs" ideState + $ useWithStaleE GetGlobalBindingTypeSigs nfp + -- Resolving a global signature is by comparison much easier, as we have a + -- specific rule just for that. + (title, edit) <- handleMaybe PluginStaleResolve $ suggestGlobalSignature' False (Just gblSigs) (Just gblSigsMp) _range + pure $ lens & L.command ?~ generateLensCommand pId uri title edit + +generateLensCommand :: PluginId -> Uri -> T.Text -> TextEdit -> Command +generateLensCommand pId uri title edit = + let wEdit = WorkspaceEdit (Just $ Map.singleton uri $ [edit]) Nothing Nothing + in mkLspCommand pId (CommandId typeLensCommandId) title (Just [toJSON wEdit]) + +-- Since the lenses are created with diagnostics, and since the globalTypeSig +-- rule can't be changed as it is also used by the hls-refactor plugin, we can't +-- rely on actions. Because we can't rely on actions it doesn't make sense to +-- recompute the edit upon command. Hence the command here just takes a edit +-- and applies it. commandHandler :: CommandFunction IdeState WorkspaceEdit commandHandler _ideState wedit = do _ <- lift $ LSP.sendRequest SMethod_WorkspaceApplyEdit (ApplyWorkspaceEditParams Nothing wedit) (\_ -> pure ()) pure $ InR Null -------------------------------------------------------------------------------- - -suggestSignature :: Bool -> Maybe HscEnv -> Maybe GlobalBindingTypeSigsResult -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, [TextEdit])] +-- To give one an idea about how creative hls-refactor plugin is, the end type +-- here can be changed within certain parameters, and even though it is used by +-- the hls-refactor-plugin, the hls-refactor-plugin itself won't need adaptions +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])] + maybeToList (suggestGlobalSignature isQuickFix mGblSigs diag) <> maybeToList (suggestLocalSignature isQuickFix env mTmr mBindings diag) + +-- Both the suggestGlobalSignature and suggestLocalSignature functions have been +-- broken up. The main functions works with a diagnostic, which then calls the +-- secondary function with whatever pieces of the diagnostic it needs. This +-- allows the resolve function, which no longer has the Diagnostic, to still +-- call the secondary functions. +suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> Maybe (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 + | _message =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text) = + suggestGlobalSignature' isQuickFix mGblSigs Nothing _range + | otherwise = Nothing + +-- In addition, for suggestGlobalSignature, we added the option of having a +-- PositionMapping. In this case if there is no PositionMapping provided, it will +-- ignore it. However if a PositionMapping is supplied, it will assume that the +-- range provided is already converted with the PositionMapping, and will attempt +-- to convert it back before attempting to find the signature from the rule. +suggestGlobalSignature' :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe PositionMapping -> Range -> Maybe (T.Text, TextEdit) +suggestGlobalSignature' isQuickFix mGblSigs pm range + | Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs + , let newRange = fromMaybe range (pm >>= \x -> fromCurrentRange x range) + , Just sig <- find (\x -> sameThing (gbSrcSpan x) newRange) sigs , signature <- T.pack $ gbRendered sig , title <- if isQuickFix then "add signature: " <> signature else signature - , Just action <- gblBindingTypeSigToEdit sig Nothing = - [(title, [action])] - | otherwise = [] + , Just action <- gblBindingTypeSigToEdit sig pm = + Just (title, action) + | otherwise = Nothing -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 -> Diagnostic -> Maybe (T.Text, TextEdit) +suggestLocalSignature isQuickFix mEnv mTmr mBindings Diagnostic{_message, _range} | Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <- (T.unwords . T.words $ _message) - =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text) - , Just bindings <- mBindings + =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text)= + suggestLocalSignature' isQuickFix mEnv mTmr mBindings identifier _range + | otherwise = Nothing + +suggestLocalSignature' :: Bool -> Maybe HscEnv -> Maybe TcModuleResult -> Maybe Bindings -> T.Text -> Range -> Maybe (T.Text, TextEdit) +suggestLocalSignature' isQuickFix mEnv mTmr mBindings identifier Range {_start, _end} + | Just bindings <- mBindings , Just env <- mEnv , localScope <- getFuzzyScope bindings _start _end , -- we can't use srcspan to lookup scoped bindings, because the error message reported by GHC includes the entire binding, instead of simply the name @@ -198,8 +279,8 @@ suggestLocalSignature isQuickFix mEnv mTmr mBindings Diagnostic{_message, _range , beforeLine <- Range startOfLine startOfLine , title <- if isQuickFix then "add signature: " <> signature else signature , action <- TextEdit beforeLine $ signature <> "\n" <> T.replicate (fromIntegral startCharacter) " " = - [(title, [action])] - | otherwise = [] + Just (title, action) + | otherwise = Nothing sameThing :: SrcSpan -> Range -> Bool sameThing s1 s2 = (_start <$> srcSpanToRange s1) == (_start <$> Just s2) @@ -212,9 +293,18 @@ gblBindingTypeSigToEdit GlobalBindingTypeSig{..} mmp -- 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" + -- We need to flatten the signature, as otherwise long signatures are + -- rendered on multiple lines with invalid formatting. + , renderedFlat <- intercalate " " $ lines gbRendered + = Just $ TextEdit range $ T.pack renderedFlat <> "\n" | otherwise = Nothing +-- |What we need to resolve our lenses, the type of binding it is, and if it's +-- a local binding, it's identifier and range. +data TypeLensesResolveData = TypeLensesResolveLocal {identifier :: T.Text, range :: Range} + | TypeLensesResolveGlobal + deriving (Generic, A.FromJSON, A.ToJSON) + data Mode = -- | always displays type lenses of global bindings, no matter what GHC flags are set Always diff --git a/ghcide/test/exe/CodeLensTests.hs b/ghcide/test/exe/CodeLensTests.hs index 9ae3268c49..0ef6edcd6f 100644 --- a/ghcide/test/exe/CodeLensTests.hs +++ b/ghcide/test/exe/CodeLensTests.hs @@ -7,6 +7,7 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as A import Data.Maybe import qualified Data.Text as T +import Data.Traversable (for) import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -17,7 +18,9 @@ import Language.LSP.Protocol.Types hiding mkRange) import Language.LSP.Test -- import Test.QuickCheck.Instances () +import Control.Exception (throw) import Control.Lens ((^.)) +import Control.Monad (void) import Data.Tuple.Extra import Test.Tasty import Test.Tasty.HUnit @@ -46,13 +49,18 @@ addSigLensesTests = after' enableGHCWarnings exported (def, sig) others = T.unlines $ [pragmas | enableGHCWarnings] <> [moduleH exported] <> maybe [] pure sig <> [def] <> others createConfig mode = A.object ["haskell" A..= A.object ["plugin" A..= A.object ["ghcide-type-lenses" A..= A.object ["config" A..= A.object ["mode" A..= A.String mode]]]]] - sigSession testName enableGHCWarnings mode exported def others = testSession testName $ do + sigSession testName enableGHCWarnings waitForDiags mode exported def others = testSession testName $ do let originalCode = before enableGHCWarnings exported def others let expectedCode = after' enableGHCWarnings exported def others sendNotification SMethod_WorkspaceDidChangeConfiguration $ DidChangeConfigurationParams $ createConfig mode doc <- createDoc "Sigs.hs" "haskell" originalCode - waitForProgressDone - codeLenses <- getCodeLenses doc + -- Because the diagnostics mode is really relying only on diagnostics now + -- to generate the code lens we need to make sure we wait till the file + -- is parsed before asking for codelenses, otherwise we will get nothing. + if waitForDiags + then void waitForDiagnostics + else waitForProgressDone + codeLenses <- getAndResolveCodeLenses doc if not $ null $ snd def then do liftIO $ length codeLenses == 1 @? "Expected 1 code lens, but got: " <> show codeLenses @@ -87,12 +95,12 @@ addSigLensesTests = ] in testGroup "add signature" - [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False "always" "" (def, Just sig) [] | (def, sig) <- cases] - , sigSession "exported mode works" False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) + [ testGroup "signatures are correct" [sigSession (T.unpack $ T.replace "\n" "\\n" def) False False "always" "" (def, Just sig) [] | (def, sig) <- cases] + , sigSession "exported mode works" False False "exported" "xyz" ("xyz = True", Just "xyz :: Bool") (fst <$> take 3 cases) , testGroup "diagnostics mode works" - [ sigSession "with GHC warnings" True "diagnostics" "" (second Just $ head cases) [] - , sigSession "without GHC warnings" False "diagnostics" "" (second (const Nothing) $ head cases) [] + [ sigSession "with GHC warnings" True True "diagnostics" "" (second Just $ head cases) [] + , sigSession "without GHC warnings" False False "diagnostics" "" (second (const Nothing) $ head cases) [] ] , testSession "keep stale lens" $ do let content = T.unlines @@ -112,3 +120,17 @@ addSigLensesTests = listOfChar :: T.Text listOfChar | ghcVersion >= GHC90 = "String" | otherwise = "[Char]" + +-- TODO Replace with lsp-test function when updated to the latest release +getAndResolveCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] +getAndResolveCodeLenses tId = do + codeLenses <- getCodeLenses tId + for codeLenses $ \codeLens -> if isJust (codeLens ^. L.data_) then resolveCodeLens codeLens else pure codeLens + +-- |Resolves the provided code lens. +resolveCodeLens :: CodeLens -> Session CodeLens +resolveCodeLens cl = do + rsp <- request SMethod_CodeLensResolve cl + case rsp ^. L.result of + Right cl -> return cl + Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error) From 9d4b6f2fe6d129e61b58bc0adc08d6f4e31d7b3d Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Fri, 4 Aug 2023 23:41:27 +0300 Subject: [PATCH 2/6] Fix tests --- ghcide/test/exe/AsyncTests.hs | 4 ++-- ghcide/test/exe/CodeLensTests.hs | 13 ------------- ghcide/test/exe/InitializeResponseTests.hs | 2 +- ghcide/test/exe/TestUtils.hs | 19 ++++++++++++++++++- 4 files changed, 21 insertions(+), 17 deletions(-) diff --git a/ghcide/test/exe/AsyncTests.hs b/ghcide/test/exe/AsyncTests.hs index d8ed66c040..4f72a00f18 100644 --- a/ghcide/test/exe/AsyncTests.hs +++ b/ghcide/test/exe/AsyncTests.hs @@ -35,7 +35,7 @@ tests = testGroup "async" , "foo = id" ] void waitForDiagnostics - codeLenses <- getCodeLenses doc + codeLenses <- getAndResolveCodeLenses doc liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? [ "foo :: a -> a" ] , testSession "request" $ do @@ -47,7 +47,7 @@ tests = testGroup "async" , "foo = id" ] void waitForDiagnostics - codeLenses <- getCodeLenses doc + codeLenses <- getAndResolveCodeLenses doc liftIO $ [ _title | CodeLens{_command = Just Command{_title}} <- codeLenses] @=? [ "foo :: a -> a" ] ] diff --git a/ghcide/test/exe/CodeLensTests.hs b/ghcide/test/exe/CodeLensTests.hs index 0ef6edcd6f..e1969f6665 100644 --- a/ghcide/test/exe/CodeLensTests.hs +++ b/ghcide/test/exe/CodeLensTests.hs @@ -7,7 +7,6 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as A import Data.Maybe import qualified Data.Text as T -import Data.Traversable (for) import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -121,16 +120,4 @@ listOfChar :: T.Text listOfChar | ghcVersion >= GHC90 = "String" | otherwise = "[Char]" --- TODO Replace with lsp-test function when updated to the latest release -getAndResolveCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] -getAndResolveCodeLenses tId = do - codeLenses <- getCodeLenses tId - for codeLenses $ \codeLens -> if isJust (codeLens ^. L.data_) then resolveCodeLens codeLens else pure codeLens --- |Resolves the provided code lens. -resolveCodeLens :: CodeLens -> Session CodeLens -resolveCodeLens cl = do - rsp <- request SMethod_CodeLensResolve cl - case rsp ^. L.result of - Right cl -> return cl - Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error) diff --git a/ghcide/test/exe/InitializeResponseTests.hs b/ghcide/test/exe/InitializeResponseTests.hs index 681e214225..84e673ef8e 100644 --- a/ghcide/test/exe/InitializeResponseTests.hs +++ b/ghcide/test/exe/InitializeResponseTests.hs @@ -49,7 +49,7 @@ tests = withResource acquire release tests where , chk " doc symbol" _documentSymbolProvider (Just $ InL True) , chk " workspace symbol" _workspaceSymbolProvider (Just $ InL True) , chk " code action" _codeActionProvider (Just $ InL False) - , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just False)) + , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just True)) , chk "NO doc formatting" _documentFormattingProvider (Just $ InL False) , chk "NO doc range formatting" _documentRangeFormattingProvider (Just $ InL False) diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index 21d80cfb6e..6e211019d4 100644 --- a/ghcide/test/exe/TestUtils.hs +++ b/ghcide/test/exe/TestUtils.hs @@ -14,7 +14,8 @@ module TestUtils where import Control.Applicative.Combinators import Control.Concurrent -import Control.Exception (bracket_, catch, finally) +import Control.Exception (bracket_, catch, finally, + throw) import qualified Control.Lens as Lens import qualified Control.Lens.Extras as Lens import Control.Monad @@ -125,6 +126,8 @@ import Test.Tasty.QuickCheck import Text.Printf (printf) import Text.Regex.TDFA ((=~)) +import Data.Traversable (for) + -- | Wait for the next progress begin step waitForProgressBegin :: Session () waitForProgressBegin = skipManyTill anyMessage $ satisfyMaybe $ \case @@ -389,3 +392,17 @@ defToLocation (InR (InR Null)) = [] thDollarIdx :: UInt thDollarIdx | ghcVersion >= GHC90 = 1 | otherwise = 0 + +-- TODO Replace with lsp-test function when updated to the latest release +getAndResolveCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] +getAndResolveCodeLenses tId = do + codeLenses <- getCodeLenses tId + for codeLenses $ \codeLens -> if isJust (codeLens ^. L.data_) then resolveCodeLens codeLens else pure codeLens + +-- |Resolves the provided code lens. +resolveCodeLens :: CodeLens -> Session CodeLens +resolveCodeLens cl = do + rsp <- request SMethod_CodeLensResolve cl + case rsp ^. L.result of + Right cl -> return cl + Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error) From 6b794eef00063de0d01aa4f8fb00f450fb22bfb8 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Mon, 7 Aug 2023 16:53:56 +0300 Subject: [PATCH 3/6] Dump local signature code --- .../src/Development/IDE/Plugin/TypeLenses.hs | 165 ++++++------------ ghcide/test/exe/CodeLensTests.hs | 8 +- 2 files changed, 54 insertions(+), 119 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index c755cc3185..1bbfc1c5ad 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -22,7 +22,7 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Class (MonadTrans (lift)) import Data.Aeson.Types (toJSON) import qualified Data.Aeson.Types as A -import Data.List (find, intercalate) +import Data.List (find) import qualified Data.Map as Map import Data.Maybe (catMaybes, fromMaybe, maybeToList) @@ -38,8 +38,7 @@ import Development.IDE.Core.PositionMapping (PositionMapping, fromCurrentRange, toCurrentRange) import Development.IDE.Core.Rules (IdeState, runAction) -import Development.IDE.Core.RuleTypes (GetBindings (GetBindings), - TypeCheck (TypeCheck)) +import Development.IDE.Core.RuleTypes (TypeCheck (TypeCheck)) import Development.IDE.Core.Service (getDiagnostics) import Development.IDE.Core.Shake (getHiddenDiagnostics, use) @@ -47,8 +46,7 @@ import qualified Development.IDE.Core.Shake as Shake import Development.IDE.GHC.Compat 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), +import Development.IDE.Types.Location (Position (Position, _line), Range (Range, _end, _start)) import GHC.Generics (Generic) import Ide.Logger (Pretty (pretty), @@ -83,7 +81,7 @@ import Language.LSP.Protocol.Types (ApplyWorkspaceEditParams WorkspaceEdit (WorkspaceEdit), type (|?) (..)) import qualified Language.LSP.Server as LSP -import Text.Regex.TDFA ((=~), (=~~)) +import Text.Regex.TDFA ((=~)) data Log = LogShake Shake.Log deriving Show @@ -117,91 +115,60 @@ codeLensProvider :: PluginMethodHandler IdeState Method_TextDocumentCodeLens codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentifier uri} = do mode <- liftIO $ runAction "codeLens.config" ideState $ usePropertyAction #mode pId properties nfp <- getNormalizedFilePathE uri - -- We have three ways we can possibly generate code lenses for type lenses. - -- Different options are with different "modes" of the typelens plugin. + -- We have two ways we can possibly generate code lenses for type lenses. + -- Different options are with different "modes" of the type-lenses plugin. -- (Remember here, as the code lens is not resolved yet, we only really need -- the range and any data that will help us resolve it later) - let -- The first option is to generate the lens from diagnostics about local - -- bindings. - -- TODO: We need the identifier, but not sure we need the _range. - -- One I get it to reliably work I can find out. - generateLensFromLocalDiags diags = - [ CodeLens _range Nothing (Just $ toJSON $ TypeLensesResolveLocal identifier _range) - | (dFile, _, Diagnostic{_range, _message}) <- diags - , dFile == nfp - , Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <- - [(T.unwords . T.words $ _message) - =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text)]] - -- The second option is to generate lens from diagnostics about + let -- The first option is to generate lens from diagnostics about -- top level bindings. Even though we don't need any extra data besides -- the range to resolve this later, we still need to put data in here -- because code lenses without data are not resolvable with HLS generateLensFromGlobalDiags diags = - -- We have different methods for generating global lenses depending on - -- the mode chosen, but all lenses are resolved the same way. - [ CodeLens _range Nothing (Just $ toJSON TypeLensesResolveGlobal) - | (dFile, _, Diagnostic{_range, _message}) <- diags + -- We don't actually pass any data to resolve, however we need this + -- dummy type to make sure HLS resolves our lens + [ CodeLens _range Nothing (Just $ toJSON TypeLensesResolve) + | (dFile, _, diag@Diagnostic{_range}) <- diags , dFile == nfp - , _message - =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text)] - -- The third option is to generate lenses from the GlobalBindingTypeSig + , isGlobalDiagnostic diag] + -- The second option is to generate lenses from the GlobalBindingTypeSig -- rule. This is the only type that needs to have the range adjusted -- with PositionMapping generateLensFromGlobal sigs mp = do - [ CodeLens newRange Nothing (Just $ toJSON TypeLensesResolveGlobal) + [ CodeLens newRange Nothing (Just $ toJSON TypeLensesResolve) | sig <- sigs , Just range <- [srcSpanToRange (gbSrcSpan sig)] , Just newRange <- [toCurrentRange mp range]] - case mode of - Always -> do + if mode == Always || mode == Exported + then do -- This is sort of a hybrid method, where we get the global bindings -- from the GlobalBindingTypeSigs rule, and the local bindings from -- diagnostics. - diags <- liftIO $ atomically $ getDiagnostics ideState - hDiags <- liftIO $ atomically $ getHiddenDiagnostics ideState (GlobalBindingTypeSigsResult gblSigs, gblSigsMp) <- runActionE "codeLens.GetGlobalBindingTypeSigs" ideState $ useWithStaleE GetGlobalBindingTypeSigs nfp - pure $ InL $ generateLensFromGlobal gblSigs gblSigsMp - <> generateLensFromLocalDiags (diags <> hDiags) -- we still need diagnostics for local bindings - Exported -> do - -- In this rule we only get bindings from the GlobalBindingTypeSigs - -- rule, and in addition we filter out the non exported symbols - (GlobalBindingTypeSigsResult gblSigs, gblSigsMp) <- - runActionE "codeLens.GetGlobalBindingTypeSigs" ideState - $ useWithStaleE GetGlobalBindingTypeSigs nfp - pure $ InL $ generateLensFromGlobal (filter gbExported gblSigs) gblSigsMp - Diagnostics -> do + + let relevantGlobalSigs = + if mode == Exported + then filter gbExported gblSigs + else gblSigs + pure $ InL $ generateLensFromGlobal relevantGlobalSigs gblSigsMp + else do -- For this mode we exclusively use diagnostics to create the lenses. -- However we will still use the GlobalBindingTypeSigs to resolve them. -- This is how it was done also before the changes to support resolve. diags <- liftIO $ atomically $ getDiagnostics ideState hDiags <- liftIO $ atomically $ getHiddenDiagnostics ideState let allDiags = diags <> hDiags - pure $ InL $ generateLensFromLocalDiags allDiags <> generateLensFromGlobalDiags allDiags + pure $ InL $ generateLensFromGlobalDiags allDiags --- When resolving a type lens we only care whether it is local or global. -codeLensResolveProvider :: ResolveFunction IdeState TypeLensesResolveData Method_CodeLensResolve -codeLensResolveProvider ideState pId lens uri TypeLensesResolveLocal{identifier, range} = do - nfp <- getNormalizedFilePathE uri - (hscEnv -> env, _) <- runActionE "codeLens.GhcSession" ideState - (useWithStaleE GhcSession nfp) - (tmr, _) <- runActionE "codeLens.TypeCheck" ideState - (useWithStaleE TypeCheck nfp) - (bindings, _) <- runActionE "codeLens.GetBindings" ideState - (useWithStaleE GetBindings nfp) - -- To create a local signature, we need a lot more moving parts, as we don't - -- have any specific rule created for it. - (title, edit) <- handleMaybe PluginStaleResolve $ suggestLocalSignature' False (Just env) (Just tmr) (Just bindings) identifier range - pure $ lens & L.command ?~ generateLensCommand pId uri title edit -codeLensResolveProvider ideState pId lens@CodeLens{_range} uri TypeLensesResolveGlobal = do +codeLensResolveProvider :: ResolveFunction IdeState TypeLensesResolve Method_CodeLensResolve +codeLensResolveProvider ideState pId lens@CodeLens{_range} uri TypeLensesResolve = do nfp <- getNormalizedFilePathE uri - (gblSigs@(GlobalBindingTypeSigsResult _), gblSigsMp) <- + (gblSigs@(GlobalBindingTypeSigsResult _), pm) <- runActionE "codeLens.GetGlobalBindingTypeSigs" ideState $ useWithStaleE GetGlobalBindingTypeSigs nfp - -- Resolving a global signature is by comparison much easier, as we have a - -- specific rule just for that. - (title, edit) <- handleMaybe PluginStaleResolve $ suggestGlobalSignature' False (Just gblSigs) (Just gblSigsMp) _range + let newRange = fromMaybe _range (fromCurrentRange pm _range) + (title, edit) <- handleMaybe PluginStaleResolve $ suggestGlobalSignature' False (Just gblSigs) (Just pm) newRange pure $ lens & L.command ?~ generateLensCommand pId uri title edit generateLensCommand :: PluginId -> Uri -> T.Text -> TextEdit -> Command @@ -220,68 +187,39 @@ commandHandler _ideState wedit = do pure $ InR Null -------------------------------------------------------------------------------- --- To give one an idea about how creative hls-refactor plugin is, the end type --- here can be changed within certain parameters, and even though it is used by --- the hls-refactor-plugin, the hls-refactor-plugin itself won't need adaptions -suggestSignature :: Bool -> Maybe HscEnv -> Maybe GlobalBindingTypeSigsResult -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> [(T.Text, TextEdit)] -suggestSignature isQuickFix env mGblSigs mTmr mBindings diag = - maybeToList (suggestGlobalSignature isQuickFix mGblSigs diag) <> maybeToList (suggestLocalSignature isQuickFix env mTmr mBindings diag) - --- Both the suggestGlobalSignature and suggestLocalSignature functions have been --- broken up. The main functions works with a diagnostic, which then calls the --- secondary function with whatever pieces of the diagnostic it needs. This --- allows the resolve function, which no longer has the Diagnostic, to still --- call the secondary functions. +suggestSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> [(T.Text, TextEdit)] +suggestSignature isQuickFix mGblSigs diag = + maybeToList (suggestGlobalSignature isQuickFix mGblSigs diag) + +-- The suggestGlobalSignature is separated into two functions. The main function +-- works with a diagnostic, which then calls the secondary function with +-- whatever pieces of the diagnostic it needs. This allows the resolve function, +-- which no longer has the Diagnostic, to still call the secondary functions. suggestGlobalSignature :: Bool -> Maybe GlobalBindingTypeSigsResult -> Diagnostic -> Maybe (T.Text, TextEdit) -suggestGlobalSignature isQuickFix mGblSigs Diagnostic{_message, _range} - | _message =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text) = +suggestGlobalSignature isQuickFix mGblSigs diag@Diagnostic{_range} + | isGlobalDiagnostic diag = suggestGlobalSignature' isQuickFix mGblSigs Nothing _range | otherwise = Nothing --- In addition, for suggestGlobalSignature, we added the option of having a --- PositionMapping. In this case if there is no PositionMapping provided, it will --- ignore it. However if a PositionMapping is supplied, it will assume that the --- range provided is already converted with the PositionMapping, and will attempt --- to convert it back before attempting to find the signature from the rule. +isGlobalDiagnostic :: Diagnostic -> Bool +isGlobalDiagnostic Diagnostic{_message} = _message =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text) + +-- We have the option of calling this function with a PositionMapping. +-- If there is no PositionMapping provided, this function won't +-- convert ranges. However if a PositionMapping is supplied, it will assume +-- that the range provided is already converted with the PositionMapping, +-- and will attempt to convert it back before attempting to find the signature +-- from the rule. suggestGlobalSignature' :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe PositionMapping -> Range -> Maybe (T.Text, TextEdit) suggestGlobalSignature' isQuickFix mGblSigs pm range | Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs - , let newRange = fromMaybe range (pm >>= \x -> fromCurrentRange x range) - , Just sig <- find (\x -> sameThing (gbSrcSpan x) newRange) sigs + , 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 pm = Just (title, action) | otherwise = Nothing -suggestLocalSignature :: Bool -> Maybe HscEnv -> Maybe TcModuleResult -> Maybe Bindings -> Diagnostic -> Maybe (T.Text, TextEdit) -suggestLocalSignature isQuickFix mEnv mTmr mBindings Diagnostic{_message, _range} - | Just (_ :: T.Text, _ :: T.Text, _ :: T.Text, [identifier]) <- - (T.unwords . T.words $ _message) - =~~ ("Polymorphic local binding with no type signature: (.*) ::" :: T.Text)= - suggestLocalSignature' isQuickFix mEnv mTmr mBindings identifier _range - | otherwise = Nothing - -suggestLocalSignature' :: Bool -> Maybe HscEnv -> Maybe TcModuleResult -> Maybe Bindings -> T.Text -> Range -> Maybe (T.Text, TextEdit) -suggestLocalSignature' isQuickFix mEnv mTmr mBindings identifier Range {_start, _end} - | Just bindings <- mBindings - , Just env <- mEnv - , localScope <- getFuzzyScope bindings _start _end - , -- we can't use srcspan to lookup scoped bindings, because the error message reported by GHC includes the entire binding, instead of simply the name - Just (name, ty) <- find (\(x, _) -> printName x == T.unpack identifier) localScope >>= \(name, mTy) -> (name,) <$> mTy - , Just TcModuleResult{tmrTypechecked = TcGblEnv{tcg_rdr_env, tcg_sigs}} <- mTmr - , -- not a top-level thing, to avoid duplication - not $ name `elemNameSet` tcg_sigs - , tyMsg <- printSDocQualifiedUnsafe (mkPrintUnqualifiedDefault env tcg_rdr_env) $ pprSigmaType ty - , signature <- T.pack $ printName name <> " :: " <> tyMsg - , startCharacter <- _character _start - , 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) " " = - Just (title, action) - | otherwise = Nothing - sameThing :: SrcSpan -> Range -> Bool sameThing s1 s2 = (_start <$> srcSpanToRange s1) == (_start <$> Just s2) @@ -295,14 +233,13 @@ gblBindingTypeSigToEdit GlobalBindingTypeSig{..} mmp , Just range <- maybe (Just beforeLine) (flip toCurrentRange beforeLine) mmp -- We need to flatten the signature, as otherwise long signatures are -- rendered on multiple lines with invalid formatting. - , renderedFlat <- intercalate " " $ lines gbRendered + , renderedFlat <- unwords $ lines gbRendered = Just $ TextEdit range $ T.pack renderedFlat <> "\n" | otherwise = Nothing -- |What we need to resolve our lenses, the type of binding it is, and if it's -- a local binding, it's identifier and range. -data TypeLensesResolveData = TypeLensesResolveLocal {identifier :: T.Text, range :: Range} - | TypeLensesResolveGlobal +data TypeLensesResolve = TypeLensesResolve deriving (Generic, A.FromJSON, A.ToJSON) data Mode diff --git a/ghcide/test/exe/CodeLensTests.hs b/ghcide/test/exe/CodeLensTests.hs index e1969f6665..3d5da09310 100644 --- a/ghcide/test/exe/CodeLensTests.hs +++ b/ghcide/test/exe/CodeLensTests.hs @@ -3,10 +3,13 @@ module CodeLensTests (tests) where import Control.Applicative.Combinators +import Control.Lens ((^.)) +import Control.Monad (void) import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as A import Data.Maybe import qualified Data.Text as T +import Data.Tuple.Extra import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -16,11 +19,6 @@ import Language.LSP.Protocol.Types hiding SemanticTokensEdit (..), mkRange) import Language.LSP.Test --- import Test.QuickCheck.Instances () -import Control.Exception (throw) -import Control.Lens ((^.)) -import Control.Monad (void) -import Data.Tuple.Extra import Test.Tasty import Test.Tasty.HUnit import TestUtils From 52671abf84b838f292156acf545627fefa35e89c Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Tue, 8 Aug 2023 17:20:59 +0300 Subject: [PATCH 4/6] Update comments --- .../src/Development/IDE/Plugin/TypeLenses.hs | 21 +++++++------------ 1 file changed, 7 insertions(+), 14 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 1bbfc1c5ad..a35e0ee9ab 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -120,9 +120,7 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif -- (Remember here, as the code lens is not resolved yet, we only really need -- the range and any data that will help us resolve it later) let -- The first option is to generate lens from diagnostics about - -- top level bindings. Even though we don't need any extra data besides - -- the range to resolve this later, we still need to put data in here - -- because code lenses without data are not resolvable with HLS + -- top level bindings. generateLensFromGlobalDiags diags = -- We don't actually pass any data to resolve, however we need this -- dummy type to make sure HLS resolves our lens @@ -140,13 +138,13 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif , Just newRange <- [toCurrentRange mp range]] if mode == Always || mode == Exported then do - -- This is sort of a hybrid method, where we get the global bindings - -- from the GlobalBindingTypeSigs rule, and the local bindings from - -- diagnostics. + -- In this mode we get the global bindings from the + -- GlobalBindingTypeSigs rule. (GlobalBindingTypeSigsResult gblSigs, gblSigsMp) <- runActionE "codeLens.GetGlobalBindingTypeSigs" ideState $ useWithStaleE GetGlobalBindingTypeSigs nfp - + -- Depending on whether we only want exported or not we filter our list + -- of signatures to get what we want let relevantGlobalSigs = if mode == Exported then filter gbExported gblSigs @@ -155,7 +153,6 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif else do -- For this mode we exclusively use diagnostics to create the lenses. -- However we will still use the GlobalBindingTypeSigs to resolve them. - -- This is how it was done also before the changes to support resolve. diags <- liftIO $ atomically $ getDiagnostics ideState hDiags <- liftIO $ atomically $ getHiddenDiagnostics ideState let allDiags = diags <> hDiags @@ -204,12 +201,8 @@ suggestGlobalSignature isQuickFix mGblSigs diag@Diagnostic{_range} isGlobalDiagnostic :: Diagnostic -> Bool isGlobalDiagnostic Diagnostic{_message} = _message =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text) --- We have the option of calling this function with a PositionMapping. --- If there is no PositionMapping provided, this function won't --- convert ranges. However if a PositionMapping is supplied, it will assume --- that the range provided is already converted with the PositionMapping, --- and will attempt to convert it back before attempting to find the signature --- from the rule. +-- If a PositionMapping is supplied, this function will call +-- gblBindingTypeSigToEdit with it to create a TextEdit in the right location. suggestGlobalSignature' :: Bool -> Maybe GlobalBindingTypeSigsResult -> Maybe PositionMapping -> Range -> Maybe (T.Text, TextEdit) suggestGlobalSignature' isQuickFix mGblSigs pm range | Just (GlobalBindingTypeSigsResult sigs) <- mGblSigs From 33cac0baf0a55806ec12e938bb8d4f978b874586 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 9 Aug 2023 13:45:20 +0300 Subject: [PATCH 5/6] Address michealpj's suggestions --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 7 ++++++- ghcide/test/exe/CodeLensTests.hs | 1 + ghcide/test/exe/TestUtils.hs | 14 -------------- 3 files changed, 7 insertions(+), 15 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index a35e0ee9ab..3088588972 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -130,7 +130,12 @@ codeLensProvider ideState pId CodeLensParams{_textDocument = TextDocumentIdentif , isGlobalDiagnostic diag] -- The second option is to generate lenses from the GlobalBindingTypeSig -- rule. This is the only type that needs to have the range adjusted - -- with PositionMapping + -- with PositionMapping. + -- PositionMapping for diagnostics doesn't make sense, because we always + -- have fresh diagnostics even if current module parsed failed (the + -- diagnostic would then be parse failed). See + -- https://github.com/haskell/haskell-language-server/pull/3558 for this + -- discussion. generateLensFromGlobal sigs mp = do [ CodeLens newRange Nothing (Just $ toJSON TypeLensesResolve) | sig <- sigs diff --git a/ghcide/test/exe/CodeLensTests.hs b/ghcide/test/exe/CodeLensTests.hs index 3d5da09310..7af4de75ac 100644 --- a/ghcide/test/exe/CodeLensTests.hs +++ b/ghcide/test/exe/CodeLensTests.hs @@ -89,6 +89,7 @@ addSigLensesTests = , ("promotedKindTest = Proxy @Nothing", if ghcVersion >= GHC96 then "promotedKindTest :: Proxy Nothing" else "promotedKindTest :: Proxy 'Nothing") , ("typeOperatorTest = Refl", if ghcVersion >= GHC92 then "typeOperatorTest :: forall {k} {a :: k}. a :~: a" else "typeOperatorTest :: a :~: a") , ("notInScopeTest = mkCharType", "notInScopeTest :: String -> Data.Data.DataType") + , ("aVeryLongSignature a b c d e f g h i j k l m n = a && b && c && d && e && f && g && h && i && j && k && l && m && n", "aVeryLongSignature :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool") ] in testGroup "add signature" diff --git a/ghcide/test/exe/TestUtils.hs b/ghcide/test/exe/TestUtils.hs index 58e46c46f1..da94ce8c45 100644 --- a/ghcide/test/exe/TestUtils.hs +++ b/ghcide/test/exe/TestUtils.hs @@ -315,20 +315,6 @@ thDollarIdx :: UInt thDollarIdx | ghcVersion >= GHC90 = 1 | otherwise = 0 --- TODO Replace with lsp-test function when updated to the latest release -getAndResolveCodeLenses :: TextDocumentIdentifier -> Session [CodeLens] -getAndResolveCodeLenses tId = do - codeLenses <- getCodeLenses tId - for codeLenses $ \codeLens -> if isJust (codeLens ^. L.data_) then resolveCodeLens codeLens else pure codeLens - --- |Resolves the provided code lens. -resolveCodeLens :: CodeLens -> Session CodeLens -resolveCodeLens cl = do - rsp <- request SMethod_CodeLensResolve cl - case rsp ^. L.result of - Right cl -> return cl - Left error -> throw (UnexpectedResponseError (SomeLspId $ fromJust $ rsp ^. L.id) error) - testIde :: Recorder (WithPriority Log) -> IDE.Arguments -> Session () -> IO () testIde recorder arguments session = do config <- getConfigFromEnv From b412fdd4541004b3e1b372a08114a76838ab3302 Mon Sep 17 00:00:00 2001 From: Nathan Maxson Date: Wed, 9 Aug 2023 20:48:57 +0300 Subject: [PATCH 6/6] Always do position mapping --- ghcide/src/Development/IDE/Plugin/TypeLenses.hs | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs index 3088588972..0a6540bfe9 100644 --- a/ghcide/src/Development/IDE/Plugin/TypeLenses.hs +++ b/ghcide/src/Development/IDE/Plugin/TypeLenses.hs @@ -169,8 +169,15 @@ codeLensResolveProvider ideState pId lens@CodeLens{_range} uri TypeLensesResolve (gblSigs@(GlobalBindingTypeSigsResult _), pm) <- runActionE "codeLens.GetGlobalBindingTypeSigs" ideState $ useWithStaleE GetGlobalBindingTypeSigs nfp - let newRange = fromMaybe _range (fromCurrentRange pm _range) - (title, edit) <- handleMaybe PluginStaleResolve $ suggestGlobalSignature' False (Just gblSigs) (Just pm) newRange + -- regardless of how the original lens was generated, we want to get the range + -- that the global bindings rule would expect here, hence the need to reverse + -- position map the range, regardless of whether it was position mapped in the + -- beginning or freshly taken from diagnostics. + newRange <- handleMaybe PluginStaleResolve (fromCurrentRange pm _range) + -- We also pass on the PositionMapping so that the generated text edit can + -- have the range adjusted. + (title, edit) <- + handleMaybe PluginStaleResolve $ suggestGlobalSignature' False (Just gblSigs) (Just pm) newRange pure $ lens & L.command ?~ generateLensCommand pId uri title edit generateLensCommand :: PluginId -> Uri -> T.Text -> TextEdit -> Command @@ -226,7 +233,7 @@ gblBindingTypeSigToEdit GlobalBindingTypeSig{..} mmp | Just Range{..} <- srcSpanToRange $ getSrcSpan gbName , startOfLine <- Position (_line _start) 0 , beforeLine <- Range startOfLine startOfLine - -- If `mmp` is `Nothing`, return the original range, it used by lenses from diagnostic, + -- If `mmp` is `Nothing`, return the original range, -- otherwise we apply `toCurrentRange`, and the guard should fail if `toCurrentRange` failed. , Just range <- maybe (Just beforeLine) (flip toCurrentRange beforeLine) mmp -- We need to flatten the signature, as otherwise long signatures are @@ -235,8 +242,8 @@ gblBindingTypeSigToEdit GlobalBindingTypeSig{..} mmp = Just $ TextEdit range $ T.pack renderedFlat <> "\n" | otherwise = Nothing --- |What we need to resolve our lenses, the type of binding it is, and if it's --- a local binding, it's identifier and range. +-- |We don't need anything to resolve our lens, but a data field is mandatory +-- to get types resolved in HLS data TypeLensesResolve = TypeLensesResolve deriving (Generic, A.FromJSON, A.ToJSON)