Avoid unnecessary Target canonicalisation in Session setup (haskell#2359

)

* Add test-case for projects that use symbolic links

In particular, this test checks whether modules that are actually
symbolic lins can be found by ghcide.
This is known to be broken, as Session.hs canonicalises Targets, e.g.
saves the location of the symbolic link. When we later try to load that
module, we can't find it, as it won't be part of the known targets since
it is not canonicalized.

* Dont canonicalise Targets during session setup

Canonicalising Targets makes it harder later to actually find the
targets during import analysis, as ghcide only looks for modules in the
import paths and checks for existence in the known target Map.

However, import analysis doesn't canonicalise target candidates, thus
the lookup in the known target Map will always fail.

We no longer canonicalise Targets, so import analysis will succeed
loading modules that are actually symbolic links.

* Prefer makeAbsolute over canonicalizePath

* Use makeAbsolute to read HIE files from disk

* Restore repeated builds

the ghcide build fails for win and ghc-8.8 with segfaults

Co-authored-by: Javier Neira <atreyu.bbb@gmail.com>
Co-authored-by: Pepe Iborra <pepeiborra@gmail.com>
Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>

.github/workflows/test.yml

@@ -139,8 +139,9 @@ jobs:
           sed -i.bak -e 's/Paths_haskell_language_server/Paths_hls/g' \
                      src/**/*.hs exe/*.hs
 
+      # repeating builds to workaround segfaults in windows and ghc-8.8.4
       - name: Build
-        run: cabal build
+        run: cabal build || cabal build || cabal build
 
       - name: Set test options
         run: |

ghcide/session-loader/Development/IDE/Session.hs

@@ -462,7 +462,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
                     -> IO (IdeResult HscEnvEq, [FilePath])
         sessionOpts (hieYaml, file) = do
           v <- fromMaybe HM.empty . Map.lookup hieYaml <$> readVar fileToFlags
-          cfp <- canonicalizePath file
+          cfp <- makeAbsolute file
           case HM.lookup (toNormalizedFilePath' cfp) v of
             Just (opts, old_di) -> do
               deps_ok <- checkDependencyInfo old_di
@@ -483,7 +483,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
     -- before attempting to do so.
     let getOptions :: FilePath -> IO (IdeResult HscEnvEq, [FilePath])
         getOptions file = do
-            ncfp <- toNormalizedFilePath' <$> canonicalizePath file
+            ncfp <- toNormalizedFilePath' <$> makeAbsolute file
             cachedHieYamlLocation <- HM.lookup ncfp <$> readVar filesMap
             hieYaml <- cradleLoc file
             sessionOpts (join cachedHieYamlLocation <|> hieYaml, file) `Safe.catch` \e ->
@@ -553,11 +553,11 @@ fromTargetId is exts (GHC.TargetModule mod) env dep = do
               , i <- is
               , boot <- ["", "-boot"]
               ]
-    locs <- mapM (fmap toNormalizedFilePath' . canonicalizePath) fps
+    locs <- mapM (fmap toNormalizedFilePath' . makeAbsolute) fps
     return [TargetDetails (TargetModule mod) env dep locs]
 -- For a 'TargetFile' we consider all the possible module names
 fromTargetId _ _ (GHC.TargetFile f _) env deps = do
-    nf <- toNormalizedFilePath' <$> canonicalizePath f
+    nf <- toNormalizedFilePath' <$> makeAbsolute f
     return [TargetDetails (TargetFile nf) env deps [nf]]
 
 toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]

ghcide/src/Development/IDE/Core/Rules.hs

@@ -138,7 +138,7 @@ import           Ide.Plugin.Config
 import qualified Language.LSP.Server                          as LSP
 import           Language.LSP.Types                           (SMethod (SCustomMethod))
 import           Language.LSP.VFS
-import           System.Directory                             (canonicalizePath, makeAbsolute)
+import           System.Directory                             (makeAbsolute)
 import           Data.Default                                 (def, Default)
 import           Ide.Plugin.Properties                        (HasProperty,
                                                                KeyNameProxy,
@@ -769,7 +769,7 @@ getModIfaceFromDiskAndIndexRule =
       hie_loc = Compat.ml_hie_file $ ms_location ms
   hash <- liftIO $ Util.getFileHash hie_loc
   mrow <- liftIO $ HieDb.lookupHieFileFromSource hiedb (fromNormalizedFilePath f)
-  hie_loc' <- liftIO $ traverse (canonicalizePath . HieDb.hieModuleHieFile) mrow
+  hie_loc' <- liftIO $ traverse (makeAbsolute . HieDb.hieModuleHieFile) mrow
   case mrow of
     Just row
       | hash == HieDb.modInfoHash (HieDb.hieModInfo row)

ghcide/src/Development/IDE/Types/HscEnvEq.hs

@@ -29,7 +29,7 @@ import           Development.IDE.GHC.Util        (lookupPackageConfig)
 import           Development.IDE.Graph.Classes
 import           Development.IDE.Types.Exports   (ExportsMap, createExportsMap)
 import           OpenTelemetry.Eventlog          (withSpan)
-import           System.Directory                (canonicalizePath)
+import           System.Directory                (makeAbsolute)
 import           System.FilePath
 
 -- | An 'HscEnv' with equality. Two values are considered equal
@@ -58,9 +58,9 @@ newHscEnvEq cradlePath hscEnv0 deps = do
     let relativeToCradle = (takeDirectory cradlePath </>)
         hscEnv = removeImportPaths hscEnv0
 
-    -- Canonicalize import paths since we also canonicalize targets
+    -- Make Absolute since targets are also absolute
     importPathsCanon <-
-      mapM canonicalizePath $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0)
+      mapM makeAbsolute $ relativeToCradle <$> importPaths (hsc_dflags hscEnv0)
 
     newHscEnvEqWithImportPaths (Just $ Set.fromList importPathsCanon) hscEnv deps
 

ghcide/test/data/symlink/hie.yaml

@@ -0,0 +1,10 @@
+
+cradle:
+  direct:
+    arguments:
+      - -i
+      - -isrc
+      - -iother_loc/
+      - other_loc/Sym.hs
+      - src/Foo.hs
+      - -Wall

ghcide/test/data/symlink/some_loc/Sym.hs

@@ -0,0 +1,4 @@
+module Sym where
+
+foo :: String
+foo = ""

ghcide/test/data/symlink/src/Foo.hs

@@ -0,0 +1,4 @@
+module Foo where
+
+import Sym
+

ghcide/test/exe/Main.hs

@@ -164,6 +164,7 @@ main = do
     , pluginParsedResultTests
     , preprocessorTests
     , thTests
+    , symlinkTests
     , safeTests
     , unitTests
     , haddockTests
@@ -4051,14 +4052,25 @@ thTests =
     expectDiagnostics [ ( cPath, [(DsWarning, (3, 0), "Top-level binding with no type signature: a :: A")] ) ]
     ]
 
+-- | Tests for projects that use symbolic links one way or another
+symlinkTests :: TestTree
+symlinkTests =
+  testGroup "Projects using Symlinks"
+    [ testCase "Module is symlinked" $ runWithExtraFiles "symlink" $ \dir -> do
+        liftIO $ createFileLink (dir </> "some_loc" </> "Sym.hs") (dir </> "other_loc" </> "Sym.hs")
+        let fooPath = dir </> "src" </> "Foo.hs"
+        _ <- openDoc fooPath "haskell"
+        expectDiagnosticsWithTags  [("src" </> "Foo.hs", [(DsWarning, (2, 0), "The import of 'Sym' is redundant", Just DtUnnecessary)])]
+        pure ()
+    ]
+
 -- | Test that all modules have linkables
 thLoadingTest :: TestTree
 thLoadingTest = testCase "Loading linkables" $ runWithExtraFiles "THLoading" $ \dir -> do
     let thb = dir </> "THB.hs"
     _ <- openDoc thb "haskell"
     expectNoMoreDiagnostics 1
 
-
 -- | test that TH is reevaluated on typecheck
 thReloadingTest :: Bool -> TestTree
 thReloadingTest unboxed = testCase name $ runWithExtraFiles dir $ \dir -> do

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

@@ -23,6 +23,7 @@ import           Data.Char                  (isLower)
 import qualified Data.HashMap.Strict        as HashMap
 import           Data.List                  (intercalate, isPrefixOf, minimumBy)
 import           Data.Maybe                 (maybeToList)
+import           Data.Ord                   (comparing)
 import           Data.String                (IsString)
 import qualified Data.Text                  as T
 import           Development.IDE            (GetParsedModule (GetParsedModule),
@@ -41,10 +42,9 @@ import           Language.LSP.Types         hiding
                                              SemanticTokenRelative (length),
                                              SemanticTokensEdit (_start))
 import           Language.LSP.VFS           (virtualFileText)
-import           System.Directory           (canonicalizePath)
+import           System.Directory           (makeAbsolute)
 import           System.FilePath            (dropExtension, splitDirectories,
                                              takeFileName)
-import Data.Ord (comparing)
 
 -- |Plugin descriptor
 descriptor :: PluginId -> PluginDescriptor IdeState
@@ -121,8 +121,8 @@ pathModuleNames state normFilePath filePath
   | otherwise = do
       session <- runAction "ModuleName.ghcSession" state $ use_ GhcSession normFilePath
       srcPaths <- evalGhcEnv (hscEnvWithImportPaths session) $ importPaths <$> getSessionDynFlags
-      paths <- mapM canonicalizePath srcPaths
-      mdlPath <- canonicalizePath filePath
+      paths <- mapM makeAbsolute srcPaths
+      mdlPath <- makeAbsolute filePath
       let prefixes = filter (`isPrefixOf` mdlPath) paths
       pure (map (moduleNameFrom mdlPath) prefixes)
   where