From 2a67821e608a95a660af7414fdcfa8cd907576e8 Mon Sep 17 00:00:00 2001 From: Moritz Kiefer Date: Fri, 4 Oct 2019 09:37:47 +0200 Subject: [PATCH] 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 --- src/Development/IDE/Core/Compile.hs | 6 ++--- src/Development/IDE/Core/Rules.hs | 2 +- src/Development/IDE/GHC/Util.hs | 30 ++++++++++------------ test/exe/Main.hs | 40 ++++++++++++++++++++++++++++- 4 files changed, 57 insertions(+), 21 deletions(-) diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs index e2d1f456..32ca3fec 100644 --- a/src/Development/IDE/Core/Compile.hs +++ b/src/Development/IDE/Core/Compile.hs @@ -159,9 +159,9 @@ upgradeWarningToError (nfp, fd) = warn2err :: T.Text -> T.Text warn2err = T.intercalate ": error:" . T.splitOn ": warning:" -addRelativeImport :: ParsedModule -> DynFlags -> DynFlags -addRelativeImport modu dflags = dflags - {importPaths = nubOrd $ maybeToList (moduleImportPath modu) ++ importPaths dflags} +addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags +addRelativeImport fp modu dflags = dflags + {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags} mkTcModuleResult :: GhcMonad m diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs index ba7d9779..f98410a1 100644 --- a/src/Development/IDE/Core/Rules.hs +++ b/src/Development/IDE/Core/Rules.hs @@ -153,7 +153,7 @@ getLocatedImportsRule = let ms = pm_mod_summary pm let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms] env <- hscEnv <$> use_ GhcSession file - let dflags = addRelativeImport pm $ hsc_dflags env + let dflags = addRelativeImport file pm $ hsc_dflags env opt <- getIdeOptions (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource diff --git a/src/Development/IDE/GHC/Util.hs b/src/Development/IDE/GHC/Util.hs index 9391ced7..4229b404 100644 --- a/src/Development/IDE/GHC/Util.hs +++ b/src/Development/IDE/GHC/Util.hs @@ -39,6 +39,8 @@ import qualified Data.Text as T import StringBuffer import System.FilePath +import Development.IDE.Types.Location + ---------------------------------------------------------------------- -- GHC setup @@ -103,26 +105,22 @@ fakeDynFlags = defaultDynFlags settings mempty , pc_WORD_SIZE=8 } -moduleImportPath :: GHC.ParsedModule -> Maybe FilePath -moduleImportPath pm - | rootModDir == "." = Just rootPathDir - | otherwise = do - dir <- dropTrailingPathSeparator <$> stripSuffix (normalise rootModDir) (normalise rootPathDir) - -- For modules with more than one component, this can be empty, e.g., - -- stripSuffix (normalise ./A) (normalise ./A) for A/B.daml. - -- We make a best effort attemp at not duplicating file paths - -- by mapping the current directory to '.' if 'rootPathDir' starts with '.' and - -- to an empty string otherwise. - pure $! if null dir then dotDir else dir +moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath +-- The call to takeDirectory is required since DAML does not require that +-- the file name matches the module name in the last component. +-- Once that has changed we can get rid of this. +moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm + -- This happens for single-component modules since takeDirectory "A" == "." + | modDir == "." = Just pathDir + | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir where - dotDir = if "." `isPrefixOf` rootPathDir then "." else "" ms = GHC.pm_mod_summary pm - file = GHC.ms_hspp_file ms mod' = GHC.ms_mod ms - -- ./src/A for file ./src/A/B.daml - rootPathDir = takeDirectory file -- A for module A.B - rootModDir = takeDirectory . moduleNameSlashes . GHC.moduleName $ mod' + modDir = + takeDirectory $ + fromNormalizedFilePath $ toNormalizedFilePath $ + moduleNameSlashes $ GHC.moduleName mod' -- | An HscEnv with equality. data HscEnvEq = HscEnvEq Unique HscEnv diff --git a/test/exe/Main.hs b/test/exe/Main.hs index 03fd47db..db5c1b64 100644 --- a/test/exe/Main.hs +++ b/test/exe/Main.hs @@ -7,8 +7,11 @@ module Main (main) where -import Control.Monad (void) +import Control.Applicative.Combinators +import Control.Monad import Control.Monad.IO.Class (liftIO) +import Data.Char (toLower) +import Data.Foldable import qualified Data.Text as T import Development.IDE.Test import Development.IDE.Test.Runfiles @@ -16,6 +19,7 @@ import Language.Haskell.LSP.Test import Language.Haskell.LSP.Types import Language.Haskell.LSP.Types.Capabilities import System.Environment.Blank (setEnv) +import System.FilePath import System.IO.Extra import System.Directory import Test.Tasty @@ -329,6 +333,40 @@ diagnosticTests = testGroup "diagnostics" ] ) ] + , testSessionWait "lower-case drive" $ do + let aContent = T.unlines + [ "module A.A where" + , "import A.B ()" + ] + bContent = T.unlines + [ "{-# OPTIONS_GHC -Wall #-}" + , "module A.B where" + , "import Data.List" + ] + uriB <- getDocUri "A/B.hs" + Just pathB <- pure $ uriToFilePath uriB + uriB <- pure $ + let (drive, suffix) = splitDrive pathB + in filePathToUri (joinDrive (map toLower drive ) suffix) + liftIO $ createDirectoryIfMissing True (takeDirectory pathB) + liftIO $ writeFileUTF8 pathB $ T.unpack bContent + uriA <- getDocUri "A/A.hs" + Just pathA <- pure $ uriToFilePath uriA + uriA <- pure $ + let (drive, suffix) = splitDrive pathA + in filePathToUri (joinDrive (map toLower drive ) suffix) + let itemA = TextDocumentItem uriA "haskell" 0 aContent + let a = TextDocumentIdentifier uriA + sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams itemA) + diagsNot <- skipManyTill anyMessage message :: Session PublishDiagnosticsNotification + let PublishDiagnosticsParams fileUri diags = _params (diagsNot :: PublishDiagnosticsNotification) + -- Check that if we put a lower-case drive in for A.A + -- the diagnostics for A.B will also be lower-case. + liftIO $ fileUri @?= uriB + let msg = _message (head (toList diags) :: Diagnostic) + liftIO $ unless ("redundant" `T.isInfixOf` msg) $ + assertFailure ("Expected redundant import but got " <> T.unpack msg) + closeDoc a ] codeActionTests :: TestTree