From a86b58bf6a4d003d3d8e4d256848a3728c96586a Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Sat, 22 Apr 2023 23:01:21 +0800 Subject: [PATCH 1/2] Keep stale lenses for module name --- .../src/Ide/Plugin/ModuleName.hs | 89 ++++++++++--------- plugins/hls-module-name-plugin/test/Main.hs | 10 +++ .../test/testdata/Stale.hs | 1 + 3 files changed, 60 insertions(+), 40 deletions(-) create mode 100644 plugins/hls-module-name-plugin/test/testdata/Stale.hs diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs index d520da077e..f1bf54c2f4 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -17,46 +17,53 @@ module Ide.Plugin.ModuleName ( Log, ) where -import Control.Monad (forM_, void) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift) +import Control.Monad (forM_, void) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Maybe -import Data.Aeson (Value (Null), toJSON) -import Data.Char (isLower) -import qualified Data.HashMap.Strict as HashMap -import Data.List (intercalate, isPrefixOf, - minimumBy) -import qualified Data.List.NonEmpty as NE -import Data.Maybe (maybeToList) -import Data.Ord (comparing) -import Data.String (IsString) -import qualified Data.Text as T -import Development.IDE (GetParsedModule (GetParsedModule), - GhcSession (GhcSession), - IdeState, Pretty, - Priority (Debug), Recorder, - WithPriority, colon, evalGhcEnv, - hscEnvWithImportPaths, logWith, - realSrcSpanToRange, runAction, - uriToFilePath', use, use_, (<+>)) -import Development.IDE.GHC.Compat (GenLocated (L), - getSessionDynFlags, hsmodName, - importPaths, locA, - moduleNameString, - pattern RealSrcSpan, - pm_parsed_source, unLoc) -import Development.IDE.Types.Logger (Pretty (..)) +import Data.Aeson (Value (Null), toJSON) +import Data.Char (isLower) +import qualified Data.HashMap.Strict as HashMap +import Data.List (intercalate, isPrefixOf, + minimumBy) +import qualified Data.List.NonEmpty as NE +import Data.Maybe (fromMaybe, maybeToList) +import Data.Ord (comparing) +import Data.String (IsString) +import qualified Data.Text as T +import Development.IDE (GetParsedModule (GetParsedModule), + GhcSession (GhcSession), + IdeState, Pretty, + Priority (Debug), + Recorder, WithPriority, + colon, evalGhcEnv, + hscEnvWithImportPaths, + logWith, + realSrcSpanToRange, + runAction, + uriToFilePath', + useWithStale, + useWithStale_, (<+>)) +import Development.IDE.Core.PositionMapping (toCurrentRange) +import Development.IDE.GHC.Compat (GenLocated (L), + getSessionDynFlags, + hsmodName, importPaths, + locA, moduleNameString, + pattern RealSrcSpan, + pm_parsed_source, unLoc) +import Development.IDE.Types.Logger (Pretty (..)) import Ide.Types import Language.LSP.Server -import Language.LSP.Types hiding - (SemanticTokenAbsolute (length, line), - SemanticTokenRelative (length), - SemanticTokensEdit (_start)) -import Language.LSP.VFS (virtualFileText) -import System.Directory (makeAbsolute) -import System.FilePath (dropExtension, normalise, - pathSeparator, splitDirectories, - takeFileName) +import Language.LSP.Types hiding + (SemanticTokenAbsolute (length, line), + SemanticTokenRelative (length), + SemanticTokensEdit (_start)) +import Language.LSP.VFS (virtualFileText) +import System.Directory (makeAbsolute) +import System.FilePath (dropExtension, normalise, + pathSeparator, + splitDirectories, + takeFileName) -- |Plugin descriptor descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState @@ -134,7 +141,7 @@ pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath pathModuleNames recorder state normFilePath filePath | isLower . head $ takeFileName filePath = return ["Main"] | otherwise = do - session <- runAction "ModuleName.ghcSession" state $ use_ GhcSession normFilePath + session <- fst <$> (runAction "ModuleName.ghcSession" state $ useWithStale_ GhcSession normFilePath) srcPaths <- evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags logWith recorder Debug (SrcPaths srcPaths) @@ -160,9 +167,11 @@ pathModuleNames recorder state normFilePath filePath -- | The module name, as stated in the module codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, T.Text)) codeModuleName state nfp = runMaybeT $ do - pm <- MaybeT . runAction "ModuleName.GetParsedModule" state $ use GetParsedModule nfp + (pm, mp) <- MaybeT . runAction "ModuleName.GetParsedModule" state $ useWithStale GetParsedModule nfp L (locA -> (RealSrcSpan l _)) m <- MaybeT . pure . hsmodName . unLoc $ pm_parsed_source pm - pure (realSrcSpanToRange l, T.pack $ moduleNameString m) + let range = realSrcSpanToRange l + let range' = fromMaybe range (toCurrentRange mp range) + pure (range', T.pack $ moduleNameString m) data Log = CorrectNames [T.Text] diff --git a/plugins/hls-module-name-plugin/test/Main.hs b/plugins/hls-module-name-plugin/test/Main.hs index 06da6aefcf..840bf4ee06 100644 --- a/plugins/hls-module-name-plugin/test/Main.hs +++ b/plugins/hls-module-name-plugin/test/Main.hs @@ -48,6 +48,16 @@ tests = [CodeLens { _command = Just c }] <- getCodeLenses doc executeCommand c void $ skipManyTill anyMessage (message SWorkspaceApplyEdit) + , testCase "Keep stale lens even if parse failed" $ do + runSessionWithServer moduleNamePlugin testDataDir $ do + doc <- openDoc "Stale.hs" "haskell" + oldLens <- getCodeLenses doc + let edit = TextEdit (mkRange 1 0 1 0) "f =" + _ <- applyEdit doc edit + newLens <- getCodeLenses doc + txt <- documentContents doc + liftIO $ newLens @?= oldLens + closeDoc doc ] goldenWithModuleName :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree diff --git a/plugins/hls-module-name-plugin/test/testdata/Stale.hs b/plugins/hls-module-name-plugin/test/testdata/Stale.hs new file mode 100644 index 0000000000..efbf93bbde --- /dev/null +++ b/plugins/hls-module-name-plugin/test/testdata/Stale.hs @@ -0,0 +1 @@ +module Foo where From 38549733be54f28488db20594ed262f6e613f7a9 Mon Sep 17 00:00:00 2001 From: Lei Zhu Date: Sat, 22 Apr 2023 23:34:39 +0800 Subject: [PATCH 2/2] Return Nothing if toCurrentRange failed --- plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs index f1bf54c2f4..9bca69854c 100644 --- a/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs +++ b/plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs @@ -169,9 +169,8 @@ codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, T.Text)) codeModuleName state nfp = runMaybeT $ do (pm, mp) <- MaybeT . runAction "ModuleName.GetParsedModule" state $ useWithStale GetParsedModule nfp L (locA -> (RealSrcSpan l _)) m <- MaybeT . pure . hsmodName . unLoc $ pm_parsed_source pm - let range = realSrcSpanToRange l - let range' = fromMaybe range (toCurrentRange mp range) - pure (range', T.pack $ moduleNameString m) + range <- MaybeT . pure $ toCurrentRange mp (realSrcSpanToRange l) + pure (range, T.pack $ moduleNameString m) data Log = CorrectNames [T.Text]