Skip to content

Support resolve in type lenses #3743

New issue

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

Sign up for GitHub

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

Already on GitHub? Sign in to your account

Merged
merged 8 commits into from
Aug 10, 2023
Merged

Support resolve in type lenses #3743

Show file tree
Hide file tree
Changes from 2 commits
Commits
Show all changes
8 commits
Select commit Hold shift + click to select a range
dd1da84
Support resolve in type lenses
joyfulmantis Aug 4, 2023
9d4b6f2
Fix tests
joyfulmantis Aug 4, 2023
6b794ee
Dump local signature code
joyfulmantis Aug 7, 2023
b1c73dd
merge upstream/master
joyfulmantis Aug 7, 2023
52671ab
Update comments
joyfulmantis Aug 8, 2023
33c4b36
Merge remote-tracking branch 'upstream/master' into typelenses-resolve
joyfulmantis Aug 8, 2023
33cac0b
Address michealpj's suggestions
joyfulmantis Aug 9, 2023
b412fdd
Always do position mapping
joyfulmantis Aug 9, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
236 changes: 163 additions & 73 deletions ghcide/src/Development/IDE/Plugin/TypeLenses.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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),
Expand Down Expand Up @@ -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),
Expand All @@ -85,13 +91,15 @@ instance Pretty Log where
pretty = \case
LogShake log -> pretty log


typeLensCommandId :: T.Text
typeLensCommandId = "typesignature.add"

descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
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}
Expand All @@ -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
Expand All @@ -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)
Expand All @@ -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
Expand Down
Loading