2a67821 · ghcide · git.iko.soy

git.iko.soy/ghcide

Avoid file path normalization in moduleImportPath (#152)

This fixes some issues where we used an uppercase drive letter in the import path even though the LSP client uses lowercase drive letters

commit2a67821e608a95a660af7414fdcfa8cd907576e8 authorMoritz Kiefer <moritz.kiefer@purelyfunctional.org> dateFri 4 Oct 2019, 09:37 (7 years ago) parent726af7f

4 files changed+57−21

compare with master

unifiedsplit

src/Development/IDE/Core/Compile.hs+3−3 src/Development/IDE/Core/Rules.hs+1−1 src/Development/IDE/GHC/Util.hs+14−16 test/exe/Main.hs+39−1

src/Development/IDE/Core/Compile.hs+3−3

@@ -159,9 +159,9 @@ upgradeWarningToError (nfp, fd) =

159159 warn2err :: T.Text -> T.Text

160160 warn2err = T.intercalate ": error:" . T.splitOn ": warning:"

161161

162−addRelativeImport :: ParsedModule -> DynFlags -> DynFlags

163−addRelativeImport modu dflags = dflags

164− {importPaths = nubOrd $ maybeToList (moduleImportPath modu) ++ importPaths dflags}

162+addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags

163+addRelativeImport fp modu dflags = dflags

164+ {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}

165165

166166mkTcModuleResult

167167 :: GhcMonad m

src/Development/IDE/Core/Rules.hs+1−1

@@ -153,7 +153,7 @@ getLocatedImportsRule =

153153 let ms = pm_mod_summary pm

154154 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]

155155 env <- hscEnv <$> use_ GhcSession file

156− let dflags = addRelativeImport pm $ hsc_dflags env

156+ let dflags = addRelativeImport file pm $ hsc_dflags env

157157 opt <- getIdeOptions

158158 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do

159159 diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource

src/Development/IDE/GHC/Util.hs+14−16

@@ -39,6 +39,8 @@ import qualified Data.Text as T

3939import StringBuffer

4040import System.FilePath

4141

42+import Development.IDE.Types.Location

43+

4244

4345----------------------------------------------------------------------

4446-- GHC setup

@@ -103,26 +105,22 @@ fakeDynFlags = defaultDynFlags settings mempty

103105 , pc_WORD_SIZE=8

104106 }

105107

106−moduleImportPath :: GHC.ParsedModule -> Maybe FilePath

107−moduleImportPath pm

108− | rootModDir == "." = Just rootPathDir

109− | otherwise = do

110− dir <- dropTrailingPathSeparator <$> stripSuffix (normalise rootModDir) (normalise rootPathDir)

111− -- For modules with more than one component, this can be empty, e.g.,

112− -- stripSuffix (normalise ./A) (normalise ./A) for A/B.daml.

113− -- We make a best effort attemp at not duplicating file paths

114− -- by mapping the current directory to '.' if 'rootPathDir' starts with '.' and

115− -- to an empty string otherwise.

116− pure $! if null dir then dotDir else dir

108+moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath

109+-- The call to takeDirectory is required since DAML does not require that

110+-- the file name matches the module name in the last component.

111+-- Once that has changed we can get rid of this.

112+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm

113+ -- This happens for single-component modules since takeDirectory "A" == "."

114+ | modDir == "." = Just pathDir

115+ | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir

117116 where

118− dotDir = if "." `isPrefixOf` rootPathDir then "." else ""

119117 ms = GHC.pm_mod_summary pm

120− file = GHC.ms_hspp_file ms

121118 mod' = GHC.ms_mod ms

122− -- ./src/A for file ./src/A/B.daml

123− rootPathDir = takeDirectory file

124119 -- A for module A.B

125− rootModDir = takeDirectory . moduleNameSlashes . GHC.moduleName $ mod'

120+ modDir =

121+ takeDirectory $

122+ fromNormalizedFilePath $ toNormalizedFilePath $

123+ moduleNameSlashes $ GHC.moduleName mod'

126124

127125-- | An HscEnv with equality.

128126data HscEnvEq = HscEnvEq Unique HscEnv

test/exe/Main.hs+39−1

@@ -7,8 +7,11 @@

88module Main (main) where

10−import Control.Monad (void)

10+import Control.Applicative.Combinators

11+import Control.Monad

1112import Control.Monad.IO.Class (liftIO)

13+import Data.Char (toLower)

14+import Data.Foldable

1215import qualified Data.Text as T

1316import Development.IDE.Test

1417import Development.IDE.Test.Runfiles

@@ -16,6 +19,7 @@ import Language.Haskell.LSP.Test

1619import Language.Haskell.LSP.Types

1720import Language.Haskell.LSP.Types.Capabilities

1821import System.Environment.Blank (setEnv)

22+import System.FilePath

1923import System.IO.Extra

2024import System.Directory

2125import Test.Tasty

@@ -329,6 +333,40 @@ diagnosticTests = testGroup "diagnostics"

329333 ]

330334 )

331335 ]

336+ , testSessionWait "lower-case drive" $ do

337+ let aContent = T.unlines

338+ [ "module A.A where"

339+ , "import A.B ()"

340+ ]

341+ bContent = T.unlines

342+ [ "{-# OPTIONS_GHC -Wall #-}"

343+ , "module A.B where"

344+ , "import Data.List"

345+ ]

346+ uriB <- getDocUri "A/B.hs"

347+ Just pathB <- pure $ uriToFilePath uriB

348+ uriB <- pure $

349+ let (drive, suffix) = splitDrive pathB

350+ in filePathToUri (joinDrive (map toLower drive ) suffix)

351+ liftIO $ createDirectoryIfMissing True (takeDirectory pathB)

352+ liftIO $ writeFileUTF8 pathB $ T.unpack bContent

353+ uriA <- getDocUri "A/A.hs"

354+ Just pathA <- pure $ uriToFilePath uriA

355+ uriA <- pure $

356+ let (drive, suffix) = splitDrive pathA

357+ in filePathToUri (joinDrive (map toLower drive ) suffix)

358+ let itemA = TextDocumentItem uriA "haskell" 0 aContent

359+ let a = TextDocumentIdentifier uriA

360+ sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA)

361+ diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification

362+ let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification)

363+ -- Check that if we put a lower-case drive in for A.A

364+ -- the diagnostics for A.B will also be lower-case.

365+ liftIO $ fileUri @?= uriB

366+ let msg = _message (head (toList diags) :: Diagnostic)

367+ liftIO $ unless ("redundant" `T.isInfixOf` msg) $

368+ assertFailure ("Expected redundant import but got " <> T.unpack msg)

369+ closeDoc a

332370 ]

333371

334372codeActionTests :: TestTree