Skip to content

Keep instance lenses stable even if parsed results are unavailable #3545

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 5 commits into from
Apr 8, 2023
Merged

Keep instance lenses stable even if parsed results are unavailable #3545

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
49aae6d
Keep stale class lens
July541 Apr 1, 2023
1f154a5
Comment why we use useWithStale
July541 Apr 7, 2023
6f4c1e4
Remove cpp to compat package to make pre-commit happy
July541 Apr 7, 2023
bbc365e
Merge remote-tracking branch 'origin' into stale-class-lens
July541 Apr 7, 2023
b496ff7
Merge branch 'master' into stale-class-lens
July541 Apr 7, 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
3 changes: 3 additions & 0 deletions ghcide/src/Development/IDE/GHC/Compat/Core.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -496,6 +496,7 @@ module Development.IDE.GHC.Compat.Core (
# if !MIN_VERSION_ghc(9,5,0)
field_label,
#endif
groupOrigin,
) where

import qualified GHC
Expand Down Expand Up @@ -1197,9 +1198,11 @@ type UniqFM k = UniqFM.UniqFM
mkVisFunTys = mkScaledFunctionTys
mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b
mapLoc = fmap
groupOrigin = mg_ext
#else
mapLoc :: (a -> b) -> SrcLoc.GenLocated l a -> SrcLoc.GenLocated l b
mapLoc = SrcLoc.mapLoc
groupOrigin = mg_origin
#endif


Expand Down
46 changes: 24 additions & 22 deletions plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,42 +1,46 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-overlapping-patterns #-}

module Ide.Plugin.Class.CodeLens where

import Control.Lens ((^.))
import Control.Monad.IO.Class (liftIO)
import Control.Lens ((^.))
import Control.Monad.IO.Class (liftIO)
import Data.Aeson
import Data.Maybe (mapMaybe, maybeToList)
import qualified Data.Text as T
import Data.Maybe (mapMaybe, maybeToList)
import qualified Data.Text as T
import Development.IDE
import Development.IDE.Core.PositionMapping
import Development.IDE.GHC.Compat
import Development.IDE.GHC.Compat.Util
import GHC.LanguageExtensions.Type
import Ide.Plugin.Class.Types
import Ide.Plugin.Class.Utils
import Ide.PluginUtils
import Ide.Types
import Language.LSP.Server (sendRequest)
import Language.LSP.Server (sendRequest)
import Language.LSP.Types
import qualified Language.LSP.Types.Lens as J
import qualified Language.LSP.Types.Lens as J

codeLens :: PluginMethodHandler IdeState TextDocumentCodeLens
codeLens state plId CodeLensParams{..} = pluginResponse $ do
nfp <- getNormalizedFilePath uri
tmr <- handleMaybeM "Unable to typecheck"
(tmr, _) <- handleMaybeM "Unable to typecheck"
$ liftIO
$ runAction "classplugin.TypeCheck" state
$ use TypeCheck nfp
-- Using stale results means that we can almost always return a value. In practice
-- this means the lenses don't 'flicker'
$ useWithStale TypeCheck nfp

-- All instance binds
InstanceBindTypeSigsResult allBinds <-
(InstanceBindTypeSigsResult allBinds, mp) <-
handleMaybeM "Unable to get InstanceBindTypeSigsResult"
$ liftIO
$ runAction "classplugin.GetInstanceBindTypeSigs" state
$ use GetInstanceBindTypeSigs nfp
-- Using stale results means that we can almost always return a value. In practice
-- this means the lenses don't 'flicker'
$ useWithStale GetInstanceBindTypeSigs nfp

pragmaInsertion <- insertPragmaIfNotPresent state nfp InstanceSigs

Expand All @@ -53,7 +57,7 @@ codeLens state plId CodeLensParams{..} = pluginResponse $ do
makeLens (range, title) =
generateLens plId range title
$ workspaceEdit pragmaInsertion
$ makeEdit range title
$ makeEdit range title mp
codeLens = makeLens <$> mapMaybe getRangeWithSig targetSigs

pure $ List codeLens
Expand Down Expand Up @@ -97,13 +101,9 @@ codeLens state plId CodeLensParams{..} = pluginResponse $ do
-- that are nonsense for displaying code lenses.
--
-- See https://github.com/haskell/haskell-language-server/issues/3319
#if MIN_VERSION_ghc(9,5,0)
| not $ isGenerated (mg_ext fun_matches)
#else
| not $ isGenerated (mg_origin fun_matches)
#endif
-> Just $ L l fun_id
_ -> Nothing
| not $ isGenerated (groupOrigin fun_matches)
-> Just $ L l fun_id
_ -> Nothing
-- Existed signatures' name
sigNames = concat $ mapMaybe (\(L _ r) -> getSigName r) cid_sigs
toBindInfo (L l (L l' _)) = BindInfo
Expand All @@ -130,12 +130,14 @@ codeLens state plId CodeLensParams{..} = pluginResponse $ do
let cmd = mkLspCommand plId typeLensCommandId title (Just [toJSON edit])
in CodeLens range (Just cmd) Nothing

makeEdit :: Range -> T.Text -> [TextEdit]
makeEdit range bind =
makeEdit :: Range -> T.Text -> PositionMapping -> [TextEdit]
makeEdit range bind mp =
let startPos = range ^. J.start
insertChar = startPos ^. J.character
insertRange = Range startPos startPos
in [TextEdit insertRange (bind <> "\n" <> T.replicate (fromIntegral insertChar) " ")]
in case toCurrentRange mp insertRange of
Just rg -> [TextEdit rg (bind <> "\n" <> T.replicate (fromIntegral insertChar) " ")]
Nothing -> []

codeLensCommandHandler :: CommandFunction IdeState WorkspaceEdit
codeLensCommandHandler _ wedit = do
Expand Down
8 changes: 6 additions & 2 deletions plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -46,6 +46,10 @@ toMethodName n
| otherwise
= n

-- | Here we use `useWithStale` to compute, Using stale results means that we can almost always return a value.
-- In practice this means the lenses don't 'flicker'.
-- This function is also used in code actions, but it doesn't matter because our actions only work
-- if the module parsed success.
insertPragmaIfNotPresent :: (MonadIO m)
=> IdeState
-> NormalizedFilePath
Expand All @@ -59,10 +63,10 @@ insertPragmaIfNotPresent state nfp pragma = do
(_, fileContents) <- liftIO
$ runAction "classplugin.insertPragmaIfNotPresent.GetFileContents" state
$ getFileContents nfp
pm <- handleMaybeM "Unable to GetParsedModuleWithComments"
(pm, _) <- handleMaybeM "Unable to GetParsedModuleWithComments"
$ liftIO
$ runAction "classplugin.insertPragmaIfNotPresent.GetParsedModuleWithComments" state
$ use GetParsedModuleWithComments nfp
$ useWithStale GetParsedModuleWithComments nfp
Copy link
Collaborator

Choose a reason for hiding this comment

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

and here

Copy link
Collaborator

Choose a reason for hiding this comment

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

Interestingly, this seems like somewhere we shouldn't do it. We really want the up-to-date module to compute an edit! But because we return the edit as part of the code lens, we have to. So the thing to do in the long run would be to implment codeLens/resolve so only the resolution method would need this. Worth a comment!

Also relevant for #3536

let exts = getExtensions pm
info = getNextPragmaInfo sessionDynFlags fileContents
pure [insertNewPragma info pragma | pragma `notElem` exts]
12 changes: 11 additions & 1 deletion plugins/hls-class-plugin/test/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -27,7 +27,9 @@ classPlugin = mkPluginTestDescriptor Class.descriptor "class"
tests :: TestTree
tests = testGroup
"class"
[codeActionTests, codeLensTests]
[ codeActionTests
, codeLensTests
]

codeActionTests :: TestTree
codeActionTests = testGroup
Expand Down Expand Up @@ -101,6 +103,14 @@ codeLensTests = testGroup
goldenCodeLens "Don't insert pragma while GHC2021 enabled" "CodeLensWithGHC2021" 0
, goldenCodeLens "Qualified name" "Qualified" 0
, goldenCodeLens "Type family" "TypeFamily" 0
, testCase "keep stale lens" $ do
runSessionWithServer classPlugin testDataDir $ do
doc <- openDoc "Stale.hs" "haskell"
oldLens <- getCodeLenses doc
let edit = TextEdit (mkRange 4 11 4 12) "" -- Remove the `_`
_ <- applyEdit doc edit
newLens <- getCodeLenses doc
liftIO $ newLens @?= oldLens
]

_CACodeAction :: Prism' (Command |? CodeAction) CodeAction
Expand Down
5 changes: 5 additions & 0 deletions plugins/hls-class-plugin/test/testdata/Stale.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
module Stale where

data A a
instance Functor A where
fmap = _