Skip to content

Commit 49373fd

Browse files
July541July541
authored
Fix #3047 (#3092)
* Make path canonicalized * Update extra-source-files * Replace with normalise * Change to a more detailed log * Comment patch detail * 2 spaces indent
1 parent 548ca17 commit 49373fd

File tree

9 files changed

+124
-67
lines changed

9 files changed

+124
-67
lines changed

‎exe/Plugins.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -188,7 +188,7 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
188188
RefineImports.descriptor pluginRecorder "refineImports" :
189189
#endif
190190
#if hls_moduleName
191-
ModuleName.descriptor "moduleName" :
191+
ModuleName.descriptor pluginRecorder "moduleName" :
192192
#endif
193193
#if hls_hlint
194194
Hlint.descriptor pluginRecorder "hlint" :

‎plugins/hls-module-name-plugin/hls-module-name-plugin.cabal

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,8 @@ extra-source-files:
1616
LICENSE
1717
test/testdata/**/*.yaml
1818
test/testdata/**/*.hs
19+
test/testdata/**/*.cabal
20+
test/testdata/**/*.project
1921

2022
library
2123
exposed-modules: Ide.Plugin.ModuleName

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

Lines changed: 86 additions & 54 deletions
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@
44
{-# LANGUAGE RecordWildCards #-}
55
{-# LANGUAGE ViewPatterns #-}
66
{-# OPTIONS_GHC -Wall -Wwarn -fno-warn-type-defaults #-}
7+
{-# OPTIONS_GHC -Wno-name-shadowing #-}
78

89
{- | Keep the module name in sync with its file path.
910
@@ -15,65 +16,72 @@ module Ide.Plugin.ModuleName (
1516
descriptor,
1617
) where
1718

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

5260
-- |Plugin descriptor
53-
descriptor :: PluginId -> PluginDescriptor IdeState
54-
descriptor plId =
61+
descriptor :: Recorder (WithPriority Log) -> PluginId -> PluginDescriptor IdeState
62+
descriptor recorder plId =
5563
(defaultPluginDescriptor plId)
56-
{ pluginHandlers = mkPluginHandler STextDocumentCodeLens codeLens
57-
, pluginCommands = [PluginCommand updateModuleNameCommand "set name of module to match with file path" command]
64+
{ pluginHandlers = mkPluginHandler STextDocumentCodeLens (codeLens recorder)
65+
, pluginCommands = [PluginCommand updateModuleNameCommand "set name of module to match with file path" (command recorder)]
5866
}
5967

6068
updateModuleNameCommand :: IsString p => p
6169
updateModuleNameCommand = "updateModuleName"
6270

6371
-- | Generate code lenses
64-
codeLens :: PluginMethodHandler IdeState 'TextDocumentCodeLens
65-
codeLens state pluginId CodeLensParams{_textDocument=TextDocumentIdentifier uri} =
66-
Right . List . maybeToList . (asCodeLens <$>) <$> action state uri
72+
codeLens :: Recorder (WithPriority Log) -> PluginMethodHandler IdeState 'TextDocumentCodeLens
73+
codeLens recorder state pluginId CodeLensParams{_textDocument=TextDocumentIdentifier uri} =
74+
Right . List . maybeToList . (asCodeLens <$>) <$> action recorder state uri
6775
where
6876
asCodeLens :: Action -> CodeLens
6977
asCodeLens Replace{..} = CodeLens aRange (Just cmd) Nothing
7078
where
7179
cmd = mkLspCommand pluginId updateModuleNameCommand aTitle (Just [toJSON aUri])
7280

7381
-- | (Quasi) Idempotent command execution: recalculate action to execute on command request
74-
command :: CommandFunction IdeState Uri
75-
command state uri = do
76-
actMaybe <- action state uri
82+
command :: Recorder (WithPriority Log) -> CommandFunction IdeState Uri
83+
command recorder state uri = do
84+
actMaybe <- action recorder state uri
7785
forM_ actMaybe $ \Replace{..} ->
7886
let
7987
-- | Convert an Action to the corresponding edit operation
@@ -92,19 +100,22 @@ data Action = Replace
92100
deriving (Show)
93101

94102
-- | Required action (that can be converted to either CodeLenses or CodeActions)
95-
action :: IdeState -> Uri -> LspM c (Maybe Action)
96-
action state uri =
97-
traceAs "action" <$> runMaybeT $ do
103+
action :: Recorder (WithPriority Log) -> IdeState -> Uri -> LspM c (Maybe Action)
104+
action recorder state uri =
105+
runMaybeT $ do
98106
nfp <- MaybeT . pure . uriToNormalizedFilePath $ toNormalizedUri uri
99107
fp <- MaybeT . pure $ uriToFilePath' uri
100108

101109
contents <- lift . getVirtualFile $ toNormalizedUri uri
102110
let emptyModule = maybe True (T.null . T.strip . virtualFileText) contents
103111

104-
correctNames <- liftIO $ traceAs "correctNames" <$> pathModuleNames state nfp fp
112+
correctNames <- liftIO $ pathModuleNames recorder state nfp fp
113+
logWith recorder Debug (CorrectNames correctNames)
105114
bestName <- minimumBy (comparing T.length) <$> (MaybeT . pure $ NE.nonEmpty correctNames)
115+
logWith recorder Info (BestName bestName)
106116

107-
statedNameMaybe <- liftIO $ traceAs "statedName" <$> codeModuleName state nfp
117+
statedNameMaybe <- liftIO $ codeModuleName state nfp
118+
logWith recorder Debug (ModuleName $ snd <$> statedNameMaybe)
108119
case statedNameMaybe of
109120
Just (nameRange, statedName)
110121
| statedName `notElem` correctNames ->
@@ -118,22 +129,31 @@ action state uri =
118129
-- | Possible module names, as derived by the position of the module in the
119130
-- source directories. There may be more than one possible name, if the source
120131
-- directories are nested inside each other.
121-
pathModuleNames :: IdeState -> NormalizedFilePath -> String -> IO [T.Text]
122-
pathModuleNames state normFilePath filePath
132+
pathModuleNames :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FilePath -> IO [T.Text]
133+
pathModuleNames recorder state normFilePath filePath
123134
| isLower . head $ takeFileName filePath = return ["Main"]
124135
| otherwise = do
125136
session <- runAction "ModuleName.ghcSession" state $ use_ GhcSession normFilePath
126137
srcPaths <- evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags
127-
paths <- mapM makeAbsolute srcPaths
138+
logWith recorder Debug (SrcPaths srcPaths)
139+
140+
-- Append a `pathSeparator` to make the path looks like a directory,
141+
-- and then we can drop it uniformly.
142+
-- See https://github.com/haskell/haskell-language-server/pull/3092 for details.
143+
let paths = map (normalise . (<> pure pathSeparator)) srcPaths
144+
logWith recorder Debug (NormalisedPaths paths)
145+
128146
mdlPath <- makeAbsolute filePath
147+
logWith recorder Debug (AbsoluteFilePath mdlPath)
148+
129149
let prefixes = filter (`isPrefixOf` mdlPath) paths
130150
pure (map (moduleNameFrom mdlPath) prefixes)
131151
where
132152
moduleNameFrom mdlPath prefix =
133153
T.pack
134154
. intercalate "."
135155
. splitDirectories
136-
. drop (length prefix + 1)
156+
. drop (length prefix)
137157
$ dropExtension mdlPath
138158

139159
-- | The module name, as stated in the module
@@ -143,8 +163,20 @@ codeModuleName state nfp = runMaybeT $ do
143163
L (locA -> (RealSrcSpan l _)) m <- MaybeT . pure . hsmodName . unLoc $ pm_parsed_source pm
144164
pure (realSrcSpanToRange l, T.pack $ moduleNameString m)
145165

146-
-- traceAs :: Show a => String -> a -> a
147-
-- traceAs lbl a = trace (lbl ++ " = " ++ show a) a
148-
149-
traceAs :: b -> a -> a
150-
traceAs _ a = a
166+
data Log =
167+
CorrectNames [T.Text]
168+
| BestName T.Text
169+
| ModuleName (Maybe T.Text)
170+
| SrcPaths [FilePath]
171+
| NormalisedPaths [FilePath]
172+
| AbsoluteFilePath FilePath
173+
deriving Show
174+
175+
instance Pretty Log where
176+
pretty log = "ModuleName." <> case log of
177+
CorrectNames log -> "CorrectNames" <> colon <+> pretty log
178+
BestName log -> "BestName" <> colon <+> pretty log
179+
ModuleName log -> "StatedNameMaybe" <> colon <+> pretty log
180+
SrcPaths log -> "SrcPaths" <> colon <+> pretty log
181+
NormalisedPaths log -> "NormalisedPaths" <> colon <+> pretty log
182+
AbsoluteFilePath log -> "AbsoluteFilePath" <> colon <+> pretty log

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

Lines changed: 10 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,7 @@ main :: IO ()
1313
main = defaultTestRunner tests
1414

1515
moduleNamePlugin :: PluginDescriptor IdeState
16-
moduleNamePlugin = ModuleName.descriptor "moduleName"
16+
moduleNamePlugin = ModuleName.descriptor mempty "moduleName"
1717

1818
tests :: TestTree
1919
tests =
@@ -39,10 +39,15 @@ tests =
3939
void $ skipManyTill anyMessage (message SWorkspaceApplyEdit)
4040
, testCase "Should not show code lens if the module name is correct" $
4141
runSessionWithServer moduleNamePlugin testDataDir $ do
42-
doc <- openDoc "CorrectName.hs" "haskell"
43-
lenses <- getCodeLenses doc
44-
liftIO $ lenses @?= []
45-
closeDoc doc
42+
doc <- openDoc "CorrectName.hs" "haskell"
43+
lenses <- getCodeLenses doc
44+
liftIO $ lenses @?= []
45+
closeDoc doc
46+
-- https://github.com/haskell/haskell-language-server/issues/3047
47+
, goldenWithModuleName "Fix#3047" "canonicalize/Lib/A" $ \doc -> do
48+
[CodeLens { _command = Just c }] <- getCodeLenses doc
49+
executeCommand c
50+
void $ skipManyTill anyMessage (message SWorkspaceApplyEdit)
4651
]
4752

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

‎plugins/hls-module-name-plugin/test/testdata/cabal.project

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
packages: ./canonicalize

‎plugins/hls-module-name-plugin/test/testdata/canonicalize/Lib/A.expected.hs

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

‎plugins/hls-module-name-plugin/test/testdata/canonicalize/Lib/A.hs

Whitespace-only changes.

‎plugins/hls-module-name-plugin/test/testdata/canonicalize/canonicalize.cabal

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
cabal-version: 2.4
2+
name: canonicalize
3+
version: 0.1.0.0
4+
5+
library
6+
build-depends: base
7+
hs-source-dirs: ./

‎plugins/hls-module-name-plugin/test/testdata/hie.yaml

Lines changed: 16 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,17 @@
11
cradle:
2-
direct:
3-
arguments:
4-
- "-isubdir"
5-
- "TEmptyModule"
6-
- "TWrongModuleName"
7-
- "mainlike"
8-
- "CorrectName"
2+
multi:
3+
- path: "./"
4+
config:
5+
cradle:
6+
direct:
7+
arguments:
8+
- "-isubdir"
9+
- "TEmptyModule"
10+
- "TWrongModuleName"
11+
- "CorrectName"
12+
- path: "./canonicalize"
13+
config:
14+
cradle:
15+
cabal:
16+
- path: "./"
17+
component: "lib:canonicalize"

0 commit comments

Comments
 (0)