Skip to content

Keep stale lenses for module name #3570

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 3 commits into from
Apr 26, 2023
Merged

Keep stale lenses for module name #3570

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
a86b58b
Keep stale lenses for module name
July541 Apr 22, 2023
3854973
Return Nothing if toCurrentRange failed
July541 Apr 22, 2023
8ffc9e3
Merge branch 'master' into stale-module-name
mergify[bot] Apr 26, 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
89 changes: 49 additions & 40 deletions plugins/hls-module-name-plugin/src/Ide/Plugin/ModuleName.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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)

Expand All @@ -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)
Copy link
Collaborator

Choose a reason for hiding this comment

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

This seems wrong, shouldn't we fail or give up somehow if we can't map the range to the current thing, not use the probably-wrong range we have?

Copy link
Collaborator Author

Choose a reason for hiding this comment

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

Turns out I can't have a counterexample that toCurrentRange can fail, keep it unless we know how it fails.

Copy link
Collaborator

Choose a reason for hiding this comment

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

Seems risky to me 🤷 Why does it return a Maybe if it can't happen? And if it does happen we'll just silently do the wrong thing.

Copy link
Collaborator Author

Choose a reason for hiding this comment

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

Well, it makes sense, I'll let them be failed if toCurrentRange returns Nothing. But I'm still curious about how it fails 😅

Copy link
Collaborator

Choose a reason for hiding this comment

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

If you find out, please add some Haddock! 🙃

pure (range', T.pack $ moduleNameString m)

data Log =
CorrectNames [T.Text]
Expand Down
10 changes: 10 additions & 0 deletions plugins/hls-module-name-plugin/test/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
1 change: 1 addition & 0 deletions plugins/hls-module-name-plugin/test/testdata/Stale.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1 @@
module Foo where