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

Author: cocreature

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

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

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

test/exe/Main.hs

@@ -7,15 +7,19 @@
 
 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
 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