Skip to content

Commit a819523

Browse files
July541July541
committed
Make path canonicalized
1 parent df77e7d commit a819523

File tree

8 files changed

+106
-66
lines changed

8 files changed

+106
-66
lines changed

‎exe/Plugins.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -183,7 +183,7 @@ idePlugins recorder includeExamples = pluginDescToIdePlugins allPlugins
183183
RefineImports.descriptor pluginRecorder "refineImports" :
184184
#endif
185185
#if hls_moduleName
186-
ModuleName.descriptor "moduleName" :
186+
ModuleName.descriptor pluginRecorder "moduleName" :
187187
#endif
188188
#if hls_hlint
189189
Hlint.descriptor pluginRecorder "hlint" :

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

Lines changed: 70 additions & 53 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,11 @@
11
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE LambdaCase #-}
23
{-# LANGUAGE OverloadedStrings #-}
34
{-# LANGUAGE PatternSynonyms #-}
45
{-# LANGUAGE RecordWildCards #-}
56
{-# LANGUAGE ViewPatterns #-}
67
{-# OPTIONS_GHC -Wall -Wwarn -fno-warn-type-defaults #-}
8+
{-# OPTIONS_GHC -Wno-name-shadowing #-}
79

810
{- | Keep the module name in sync with its file path.
911
@@ -15,65 +17,71 @@ module Ide.Plugin.ModuleName (
1517
descriptor,
1618
) where
1719

18-
import Control.Monad (forM_, void)
19-
import Control.Monad.IO.Class (liftIO)
20-
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)
2123
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)
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, Info), Recorder,
38+
WithPriority, 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 (..))
4149
import Ide.Types
4250
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)
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 (canonicalizePath, makeAbsolute)
57+
import System.FilePath (dropExtension, 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 (ModuleNameLog $ "ModuleName.correctNames: " <> T.unlines correctNames)
105114
bestName <- minimumBy (comparing T.length) <$> (MaybeT . pure $ NE.nonEmpty correctNames)
115+
logWith recorder Info (ModuleNameLog $ "ModuleName.bestName: " <> bestName)
106116

107-
statedNameMaybe <- liftIO $ traceAs "statedName" <$> codeModuleName state nfp
117+
statedNameMaybe <- liftIO $ codeModuleName state nfp
118+
logWith recorder Debug (ModuleNameLog $ "ModuleName.statedNameMaybe: " <> (T.pack $ show statedNameMaybe))
108119
case statedNameMaybe of
109120
Just (nameRange, statedName)
110121
| statedName `notElem` correctNames ->
@@ -118,22 +129,28 @@ 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 (ModuleNameLog $ "ModuleName.srcpath: " <> T.pack (unlines srcPaths))
139+
140+
paths <- mapM canonicalizePath srcPaths
141+
logWith recorder Debug (ModuleNameLog $ "ModuleName.paths: " <> T.pack (unlines paths))
142+
128143
mdlPath <- makeAbsolute filePath
144+
logWith recorder Debug (ModuleNameLog $ "ModuleName.mdlPath: " <> T.pack mdlPath)
145+
129146
let prefixes = filter (`isPrefixOf` mdlPath) paths
130147
pure (map (moduleNameFrom mdlPath) prefixes)
131148
where
132149
moduleNameFrom mdlPath prefix =
133150
T.pack
134151
. intercalate "."
135152
. splitDirectories
136-
. drop (length prefix + 1)
153+
. drop (length prefix + 1) -- plus one to remove `/`, for example `a/b/c` to `b/c`.
137154
$ dropExtension mdlPath
138155

139156
-- | The module name, as stated in the module
@@ -143,8 +160,8 @@ codeModuleName state nfp = runMaybeT $ do
143160
L (locA -> (RealSrcSpan l _)) m <- MaybeT . pure . hsmodName . unLoc $ pm_parsed_source pm
144161
pure (realSrcSpanToRange l, T.pack $ moduleNameString m)
145162

146-
-- traceAs :: Show a => String -> a -> a
147-
-- traceAs lbl a = trace (lbl ++ " = " ++ show a) a
163+
newtype Log = ModuleNameLog T.Text deriving Show
148164

149-
traceAs :: b -> a -> a
150-
traceAs _ a = a
165+
instance Pretty Log where
166+
pretty = \case
167+
ModuleNameLog log -> 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)