Some fixes for multi component stuff (#3686)

* Only bring units actually depended on into scope on 9.4+

* Cabal uses `main` as the unit id of all executable packages. This confused multi component sessions.

Solution: include the hash of the options in the unit id when the unit id is called "main".

Fixes #3513

* Fix call hierarchy tests

Author: wz1000

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

@@ -484,7 +484,25 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
         packageSetup (hieYaml, cfp, opts, libDir) = do
           -- Parse DynFlags for the newly discovered component
           hscEnv <- emptyHscEnv ideNc libDir
-          (df, targets) <- evalGhcEnv hscEnv $ setOptions opts (hsc_dflags hscEnv)
+          (df', targets) <- evalGhcEnv hscEnv $ setOptions opts (hsc_dflags hscEnv)
+          let df =
+#if MIN_VERSION_ghc(9,3,0)
+                case unitIdString (homeUnitId_ df') of
+                     -- cabal uses main for the unit id of all executable packages
+                     -- This makes multi-component sessions confused about what
+                     -- options to use for that component.
+                     -- Solution: hash the options and use that as part of the unit id
+                     -- This works because there won't be any dependencies on the
+                     -- executable unit.
+                     "main" ->
+                       let hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack $ componentOptions opts)
+                           hashed_uid = Compat.toUnitId (Compat.stringToUnit ("main-"++hash))
+                       in setHomeUnitId_ hashed_uid df'
+                     _ -> df'
+#else
+                df'
+#endif
+
           let deps = componentDependencies opts ++ maybeToList hieYaml
           dep_info <- getDependencyInfo deps
           -- Now lookup to see whether we are combining with an existing HscEnv
@@ -499,6 +517,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
                   -- We will modify the unitId and DynFlags used for
                   -- compilation but these are the true source of
                   -- information.
+                  
                   new_deps = RawComponentInfo (homeUnitId_ df) df targets cfp opts dep_info
                                 : maybe [] snd oldDeps
                   -- Get all the unit-ids for things in this component

ghcide/src/Development/IDE/Import/FindImports.hs

@@ -29,6 +29,7 @@ import           Data.Maybe
 import           System.FilePath
 #if MIN_VERSION_ghc(9,3,0)
 import           GHC.Types.PkgQual
+import           GHC.Unit.State
 #endif
 
 data Import
@@ -135,25 +136,45 @@ locateModule env comp_info exts targetFor modName mbPkgName isSource = do
 #else
     Nothing -> do
 #endif
+
+      mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : other_imports) exts targetFor isSource $ unLoc modName
+      case mbFile of
+        Nothing          -> lookupInPackageDB env
+        Just (uid, file) -> toModLocation uid file
+  where
+    dflags = hsc_dflags env
+    import_paths = mapMaybe (mkImportDirs env) comp_info
+    other_imports =
+#if MIN_VERSION_ghc(9,4,0)
+      -- On 9.4+ instead of bringing all the units into scope, only bring into scope the units
+      -- this one depends on
+      -- This way if you have multiple units with the same module names, we won't get confused
+      -- For example if unit a imports module M from unit B, when there is also a module M in unit C,
+      -- and unit a only depends on unit b, without this logic there is the potential to get confused
+      -- about which module unit a imports.
+      -- Without multi-component support it is hard to recontruct the dependency environment so
+      -- unit a will have both unit b and unit c in scope.
+      map (\uid -> (uid, importPaths (homeUnitEnv_dflags (ue_findHomeUnitEnv uid ue)))) hpt_deps
+    ue = hsc_unit_env env
+    units = homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId_ dflags) ue
+    hpt_deps :: [UnitId]
+    hpt_deps = homeUnitDepends units
+#else
+      import_paths'
+#endif
+
       -- first try to find the module as a file. If we can't find it try to find it in the package
       -- database.
       -- Here the importPaths for the current modules are added to the front of the import paths from the other components.
       -- This is particularly important for Paths_* modules which get generated for every component but unless you use it in
       -- each component will end up being found in the wrong place and cause a multi-cradle match failure.
-      let import_paths' =
+    import_paths' =
 #if MIN_VERSION_ghc(9,3,0)
             import_paths
 #else
             map snd import_paths
 #endif
 
-      mbFile <- locateModuleFile ((homeUnitId_ dflags, importPaths dflags) : import_paths') exts targetFor isSource $ unLoc modName
-      case mbFile of
-        Nothing          -> lookupInPackageDB env
-        Just (uid, file) -> toModLocation uid file
-  where
-    dflags = hsc_dflags env
-    import_paths = mapMaybe (mkImportDirs env) comp_info
     toModLocation uid file = liftIO $ do
         loc <- mkHomeModLocation dflags (unLoc modName) (fromNormalizedFilePath file)
 #if MIN_VERSION_ghc(9,0,0)

plugins/hls-call-hierarchy-plugin/test/Main.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE RankNTypes         #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TupleSections      #-}
@@ -504,25 +505,40 @@ outgoingCallMultiFileTestCase filepath queryX queryY mp =
         _      -> liftIO $ assertFailure "Not one element"
     closeDoc doc
 
-oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem) -> Assertion
+oneCaseWithCreate :: T.Text -> Int -> Int -> (Uri -> CallHierarchyItem -> Assertion) -> Assertion
 oneCaseWithCreate contents queryX queryY expected = withCanonicalTempDir $ \dir ->
   runSessionWithServer plugin dir $ do
     doc <- createDoc "A.hs" "haskell" contents
     waitForIndex (dir </> "A.hs")
     Test.prepareCallHierarchy (mkPrepareCallHierarchyParam doc queryX queryY) >>=
       \case
-        [item] -> liftIO $ item @?= expected (doc ^. L.uri)
+        [item] -> liftIO $ expected (doc ^. L.uri) item
         res    -> liftIO $ assertFailure "Not one element"
     closeDoc doc
 
-mkCallHierarchyItem' :: String -> T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem
-mkCallHierarchyItem' prefix name kind range selRange uri =
-  CallHierarchyItem name kind Nothing (Just "Main") uri range selRange (Just v)
+mkCallHierarchyItem' :: String -> T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem -> Assertion
+mkCallHierarchyItem' prefix name kind range selRange uri c@(CallHierarchyItem name' kind' tags' detail' uri' range' selRange' xdata') = do
+    assertHierarchyItem name name'
+    assertHierarchyItem kind kind'
+    assertHierarchyItem tags tags'
+    assertHierarchyItem detail detail'
+    assertHierarchyItem uri uri'
+    assertHierarchyItem range range'
+    assertHierarchyItem selRange selRange'
+    case xdata' of
+      Nothing -> assertFailure ("In " ++ show c ++ ", got Nothing for data but wanted " ++ show xdata)
+      Just v -> case fromJSON v of
+        Success v -> assertBool ("In " ++ show c ++ " wanted data prefix: " ++ show xdata) (xdata `T.isPrefixOf` v)
+        Error err -> assertFailure ("In " ++ show c ++ " wanted data prefix: " ++ show xdata ++ " but json parsing failed with " ++ show err)
   where
-    v = toJSON $ prefix <> ":" <> T.unpack name <> ":Main:main"
+    tags = Nothing
+    detail = Just "Main"
+    assertHierarchyItem :: forall a. (Eq a, Show a) => a -> a -> Assertion
+    assertHierarchyItem = assertEqual ("In " ++ show c ++ ", got unexpected value for field")
+    xdata = T.pack prefix <> ":" <> name <> ":Main:main"
 
 mkCallHierarchyItemC, mkCallHierarchyItemT, mkCallHierarchyItemV ::
-  T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem
+  T.Text -> SymbolKind -> Range -> Range -> Uri -> CallHierarchyItem -> Assertion
 mkCallHierarchyItemC = mkCallHierarchyItem' "c"
 mkCallHierarchyItemT = mkCallHierarchyItem' "t"
 mkCallHierarchyItemV = mkCallHierarchyItem' "v"