Skip to content

Commit cda1325

Browse files
July541mergify[bot]
July541
and
mergify[bot]
authored
Keep stale lenses for module name (#3570)
* Keep stale lenses for module name * Return Nothing if toCurrentRange failed --------- Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
1 parent 6640ebf commit cda1325

File tree

3 files changed

+59
-40
lines changed

3 files changed

+59
-40
lines changed

‎plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs‎

Lines changed: 48 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -17,46 +17,53 @@ module Ide.Plugin.ModuleName (
1717
Log,
1818
) where
1919

20-
import Control.Monad (forM_, void)
21-
import Control.Monad.IO.Class (liftIO)
22-
import Control.Monad.Trans.Class (lift)
20+
import Control.Monad (forM_, void)
21+
import Control.Monad.IO.Class (liftIO)
22+
import Control.Monad.Trans.Class (lift)
2323
import Control.Monad.Trans.Maybe
24-
import Data.Aeson (Value (Null), toJSON)
25-
import Data.Char (isLower)
26-
import qualified Data.HashMap.Strict as HashMap
27-
import Data.List (intercalate, isPrefixOf,
28-
minimumBy)
29-
import qualified Data.List.NonEmpty as NE
30-
import Data.Maybe (maybeToList)
31-
import Data.Ord (comparing)
32-
import Data.String (IsString)
33-
import qualified Data.Text as T
34-
import Development.IDE (GetParsedModule (GetParsedModule),
35-
GhcSession (GhcSession),
36-
IdeState, Pretty,
37-
Priority (Debug), Recorder,
38-
WithPriority, colon, evalGhcEnv,
39-
hscEnvWithImportPaths, logWith,
40-
realSrcSpanToRange, runAction,
41-
uriToFilePath', use, use_, (<+>))
42-
import Development.IDE.GHC.Compat (GenLocated (L),
43-
getSessionDynFlags, hsmodName,
44-
importPaths, locA,
45-
moduleNameString,
46-
pattern RealSrcSpan,
47-
pm_parsed_source, unLoc)
48-
import Development.IDE.Types.Logger (Pretty (..))
24+
import Data.Aeson (Value (Null), toJSON)
25+
import Data.Char (isLower)
26+
import qualified Data.HashMap.Strict as HashMap
27+
import Data.List (intercalate, isPrefixOf,
28+
minimumBy)
29+
import qualified Data.List.NonEmpty as NE
30+
import Data.Maybe (fromMaybe, maybeToList)
31+
import Data.Ord (comparing)
32+
import Data.String (IsString)
33+
import qualified Data.Text as T
34+
import Development.IDE (GetParsedModule (GetParsedModule),
35+
GhcSession (GhcSession),
36+
IdeState, Pretty,
37+
Priority (Debug),
38+
Recorder, WithPriority,
39+
colon, evalGhcEnv,
40+
hscEnvWithImportPaths,
41+
logWith,
42+
realSrcSpanToRange,
43+
runAction,
44+
uriToFilePath',
45+
useWithStale,
46+
useWithStale_, (<+>))
47+
import Development.IDE.Core.PositionMapping (toCurrentRange)
48+
import Development.IDE.GHC.Compat (GenLocated (L),
49+
getSessionDynFlags,
50+
hsmodName, importPaths,
51+
locA, moduleNameString,
52+
pattern RealSrcSpan,
53+
pm_parsed_source, unLoc)
54+
import Development.IDE.Types.Logger (Pretty (..))
4955
import Ide.Types
5056
import Language.LSP.Server
51-
import Language.LSP.Types hiding
52-
(SemanticTokenAbsolute (length, line),
53-
SemanticTokenRelative (length),
54-
SemanticTokensEdit (_start))
55-
import Language.LSP.VFS (virtualFileText)
56-
import System.Directory (makeAbsolute)
57-
import System.FilePath (dropExtension, normalise,
58-
pathSeparator, splitDirectories,
59-
takeFileName)
57+
import Language.LSP.Types hiding
58+
(SemanticTokenAbsolute (length, line),
59+
SemanticTokenRelative (length),
60+
SemanticTokensEdit (_start))
61+
import Language.LSP.VFS (virtualFileText)
62+
import System.Directory (makeAbsolute)
63+
import System.FilePath (dropExtension, normalise,
64+
pathSeparator,
65+
splitDirectories,
66+
takeFileName)
6067

6168
-- |Plugin descriptor
6269
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
@@ -134,7 +141,7 @@ pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath
134141
pathModuleNames recorder state normFilePath filePath
135142
| isLower . head $ takeFileName filePath = return ["Main"]
136143
| otherwise = do
137-
session <- runAction "ModuleName.ghcSession" state $ use_ GhcSession normFilePath
144+
session <- fst <$> (runAction "ModuleName.ghcSession" state $ useWithStale_ GhcSession normFilePath)
138145
srcPaths <- evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags
139146
logWith recorder Debug (SrcPaths srcPaths)
140147

@@ -160,9 +167,10 @@ pathModuleNames recorder state normFilePath filePath
160167
-- | The module name, as stated in the module
161168
codeModuleName :: IdeState -> NormalizedFilePath -> IO (Maybe (Range, T.Text))
162169
codeModuleName state nfp = runMaybeT $ do
163-
pm <- MaybeT . runAction "ModuleName.GetParsedModule" state $ use GetParsedModule nfp
170+
(pm, mp) <- MaybeT . runAction "ModuleName.GetParsedModule" state $ useWithStale GetParsedModule nfp
164171
L (locA -> (RealSrcSpan l _)) m <- MaybeT . pure . hsmodName . unLoc $ pm_parsed_source pm
165-
pure (realSrcSpanToRange l, T.pack $ moduleNameString m)
172+
range <- MaybeT . pure $ toCurrentRange mp (realSrcSpanToRange l)
173+
pure (range, T.pack $ moduleNameString m)
166174

167175
data Log =
168176
CorrectNames [T.Text]

‎plugins/hls-module-name-plugin/test/Main.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -48,6 +48,16 @@ tests =
4848
[CodeLens { _command = Just c }] <- getCodeLenses doc
4949
executeCommand c
5050
void $ skipManyTill anyMessage (message SWorkspaceApplyEdit)
51+
, testCase "Keep stale lens even if parse failed" $ do
52+
runSessionWithServer moduleNamePlugin testDataDir $ do
53+
doc <- openDoc "Stale.hs" "haskell"
54+
oldLens <- getCodeLenses doc
55+
let edit = TextEdit (mkRange 1 0 1 0) "f ="
56+
_ <- applyEdit doc edit
57+
newLens <- getCodeLenses doc
58+
txt <- documentContents doc
59+
liftIO $ newLens @?= oldLens
60+
closeDoc doc
5161
]
5262

5363
goldenWithModuleName :: TestName -> FilePath -> (TextDocumentIdentifier -> Session ()) -> TestTree

‎plugins/hls-module-name-plugin/test/testdata/Stale.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
module Foo where

0 commit comments

Comments
 (0)