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 6 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
208 changes: 114 additions & 94 deletions ghcide/src/Development/IDE/Plugin/TypeLenses.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -15,37 +15,38 @@ 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 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),
TypeCheck (TypeCheck))
import Development.IDE.Core.RuleTypes (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.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),
Expand All @@ -60,38 +61,43 @@ 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),
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

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,97 +115,103 @@ 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 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 lens from diagnostics about
-- 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
[ CodeLens _range Nothing (Just $ toJSON TypeLensesResolve)
| (dFile, _, diag@Diagnostic{_range}) <- diags
, dFile == nfp
, 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 TypeLensesResolve)
| sig <- sigs
, Just range <- [srcSpanToRange (gbSrcSpan sig)]
, Just newRange <- [toCurrentRange mp range]]
if mode == Always || mode == Exported
then do
-- 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
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.
diags <- liftIO $ atomically $ getDiagnostics ideState
hDiags <- liftIO $ atomically $ getHiddenDiagnostics ideState
let allDiags = diags <> hDiags
pure $ InL $ generateLensFromGlobalDiags allDiags

codeLensResolveProvider :: ResolveFunction IdeState TypeLensesResolve Method_CodeLensResolve
codeLensResolveProvider ideState pId lens@CodeLens{_range} uri TypeLensesResolve = do
nfp <- getNormalizedFilePathE uri
(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
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 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 diag@Diagnostic{_range}
| isGlobalDiagnostic diag =
suggestGlobalSignature' isQuickFix mGblSigs Nothing _range
| otherwise = Nothing

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
isGlobalDiagnostic :: Diagnostic -> Bool
isGlobalDiagnostic Diagnostic{_message} = _message =~ ("(Top-level binding|Pattern synonym) with no type signature" :: T.Text)

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
-- If a PositionMapping is supplied, this function will call
Copy link
Collaborator

Choose a reason for hiding this comment

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

I think I made a comment about this and it got lost - why can't it be the caller's responsibility to map the Range?

Copy link
Collaborator Author

Choose a reason for hiding this comment

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

I marked your previous comment as resolved, because I did move the range position mapping stuff to the caller. However the position mapping is still sent to the function that generates lenses from the global signature

-- 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
, 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 Nothing =
[(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{..}}
| 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
, 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) " " =
[(title, [action])]
| otherwise = []
, Just action <- gblBindingTypeSigToEdit sig pm =
Just (title, action)
| otherwise = Nothing

sameThing :: SrcSpan -> Range -> Bool
sameThing s1 s2 = (_start <$> srcSpanToRange s1) == (_start <$> Just s2)
Expand All @@ -212,9 +224,17 @@ 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 <- 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 TypeLensesResolve = TypeLensesResolve
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
4 changes: 2 additions & 2 deletions ghcide/test/exe/AsyncTests.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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" ]
]
Loading