diff --git a/ghcide/src/Development/IDE/GHC/Compat/Core.hs b/ghcide/src/Development/IDE/GHC/Compat/Core.hs index 8794f44db4..be4d72beb3 100644 --- a/ghcide/src/Development/IDE/GHC/Compat/Core.hs +++ b/ghcide/src/Development/IDE/GHC/Compat/Core.hs @@ -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 @@ -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 diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs index 44d3857c86..1b3b4f10f3 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/CodeLens.hs @@ -1,17 +1,17 @@ {-# 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 @@ -19,24 +19,28 @@ 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 @@ -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 @@ -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 @@ -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 diff --git a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs index 1c5deb10e9..31dbd021a2 100644 --- a/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs +++ b/plugins/hls-class-plugin/src/Ide/Plugin/Class/Utils.hs @@ -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 @@ -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 let exts = getExtensions pm info = getNextPragmaInfo sessionDynFlags fileContents pure [insertNewPragma info pragma | pragma `notElem` exts] diff --git a/plugins/hls-class-plugin/test/Main.hs b/plugins/hls-class-plugin/test/Main.hs index c8d0dd3d3c..b8c8cfaebc 100644 --- a/plugins/hls-class-plugin/test/Main.hs +++ b/plugins/hls-class-plugin/test/Main.hs @@ -27,7 +27,9 @@ classPlugin = mkPluginTestDescriptor Class.descriptor "class" tests :: TestTree tests = testGroup "class" - [codeActionTests, codeLensTests] + [ codeActionTests + , codeLensTests + ] codeActionTests :: TestTree codeActionTests = testGroup @@ -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 diff --git a/plugins/hls-class-plugin/test/testdata/Stale.hs b/plugins/hls-class-plugin/test/testdata/Stale.hs new file mode 100644 index 0000000000..f70be2017f --- /dev/null +++ b/plugins/hls-class-plugin/test/testdata/Stale.hs @@ -0,0 +1,5 @@ +module Stale where + +data A a +instance Functor A where + fmap = _