Improve handling of specialTarget

Author: wz1000

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

@@ -42,6 +42,7 @@ import qualified Data.HashMap.Strict                  as HM
 import           Data.IORef
 import qualified Data.Set                             as OS
 import           Data.List
+import           Data.List.Extra                      as L
 import qualified Data.List.NonEmpty                   as NE
 import qualified Data.Map.Strict                      as Map
 import           Data.Maybe
@@ -501,7 +502,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
         packageSetup (hieYaml, cfp, opts, libDir) = do
           -- Parse DynFlags for the newly discovered component
           hscEnv <- emptyHscEnv ideNc libDir
-          newTargetDfs <- evalGhcEnv hscEnv $ setOptions opts (hsc_dflags hscEnv)
+          newTargetDfs <- evalGhcEnv hscEnv $ setOptions cfp opts (hsc_dflags hscEnv)
           let deps = componentDependencies opts ++ maybeToList hieYaml
           dep_info <- getDependencyInfo deps
           -- Now lookup to see whether we are combining with an existing HscEnv
@@ -575,7 +576,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
           let this_flags_map = HM.fromList (concatMap toFlagsMap all_targets)
 
           void $ modifyVar' fileToFlags $
-              Map.insertWith HM.union hieYaml this_flags_map
+              Map.insert hieYaml this_flags_map
           void $ modifyVar' filesMap $
               flip HM.union (HM.fromList (zip (map fst $ concatMap toFlagsMap all_targets) (repeat hieYaml)))
 
@@ -756,7 +757,10 @@ fromTargetId is exts (GHC.TargetModule modName) env dep = do
 -- For a 'TargetFile' we consider all the possible module names
 fromTargetId _ _ (GHC.TargetFile f _) env deps = do
     nf <- toNormalizedFilePath' <$> makeAbsolute f
-    return [TargetDetails (TargetFile nf) env deps [nf]]
+    let other
+          | "-boot" `isSuffixOf` f = toNormalizedFilePath' (L.dropEnd 5 $ fromNormalizedFilePath nf)
+          | otherwise = toNormalizedFilePath' (fromNormalizedFilePath nf ++ "-boot")
+    return [TargetDetails (TargetFile nf) env deps [nf, other]]
 
 toFlagsMap :: TargetDetails -> [(NormalizedFilePath, (IdeResult HscEnvEq, DependencyInfo))]
 toFlagsMap TargetDetails{..} =
@@ -781,8 +785,13 @@ newComponentCache
          -> [ComponentInfo]
          -> IO [ ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))]
 newComponentCache recorder exts cradlePath cfp hsc_env old_cis new_cis = do
-    let cis = Map.union (mkMap new_cis) (mkMap old_cis) -- Left biased so prefer new components over old ones
-        mkMap = Map.fromList . map (\ci -> (componentUnitId ci, ci))
+    let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis)
+        -- When we have multiple components with the same uid,
+        -- prefer the new one over the old.
+        -- However, we might have added some targets to the old unit
+        -- (see special target), so preserve those
+        unionCIs new_ci old_ci = new_ci { componentTargets = componentTargets new_ci ++ componentTargets old_ci }
+        mkMap = Map.fromListWith unionCIs . map (\ci -> (componentUnitId ci, ci))
     let dfs = map componentDynFlags $ Map.elems cis
         uids = Map.keys cis
     hscEnv' <- -- Set up a multi component session with the other units on GHC 9.4
@@ -825,7 +834,7 @@ newComponentCache recorder exts cradlePath cfp hsc_env old_cis new_cis = do
             Nothing  -> pure ()
             Just err -> logWith recorder Error $ LogDLLLoadError err
 
-        fmap (addSpecial cfp) $ forM (Map.elems cis) $ \ci -> do
+        forM (Map.elems cis) $ \ci -> do
           let df = componentDynFlags ci
           let newFunc = maybe newHscEnvEqPreserveImportPaths newHscEnvEq cradlePath
           thisEnv <- do
@@ -859,34 +868,7 @@ newComponentCache recorder exts cradlePath cfp hsc_env old_cis new_cis = do
           let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends
           ctargets <- concatMapM mk (componentTargets ci)
 
-          return (ctargets, res)
-  where
-    -- A special target for the file which caused this wonderful
-    -- component to be created. In case the cradle doesn't list all the targets for
-    -- the component, in which case things will be horribly broken anyway.
-    -- Otherwise, we will immediately attempt to reload this module which
-    -- causes an infinite loop and high CPU usage.
-    addSpecial cfp xs
-      | alreadyIncluded = xs
-      | otherwise = let (as,bs) = break inIncludePath xs
-                    in case bs of
-                         [] ->
-                          -- There is no appropriate target to add the file to, so pick one randomly
-                          case as of
-                           [] -> []
-                           ((ctargets,res@(targetEnv, targetDepends)):xs) ->
-                            let x = (TargetDetails (TargetFile cfp) targetEnv targetDepends [cfp] : ctargets, res)
-                            in x:xs
-                         -- There is a component which could have this file in its include path
-                         -- pick one of these components
-                         ((ctargets,res@(targetEnv, targetDepends)):bs) ->
-                           let b = (TargetDetails (TargetFile cfp) targetEnv targetDepends [cfp] : ctargets, res)
-                           in as ++ (b:bs)
-      where
-        alreadyIncluded = any (any (cfp ==) . concatMap targetLocations . fst) xs
-        inIncludePath (_,((_, Just env),_)) = any (isParent $ fromNormalizedFilePath cfp) $ maybe [] OS.toList $ envImportPaths env
-          where
-            isParent fp parent = any (equalFilePath parent) (map (foldr (</>) "") $ inits $ splitPath fp)
+          return (L.nubOrdOn targetTarget ctargets, res)
 
 {- Note [Avoiding bad interface files]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1068,12 +1050,28 @@ addUnit unit_str = liftEwM $ do
   putCmdLineState (unit_str : units)
 
 -- | Throws if package flags are unsatisfiable
-setOptions :: GhcMonad m => ComponentOptions -> DynFlags -> m (NE.NonEmpty (DynFlags, [GHC.Target]))
-setOptions (ComponentOptions theOpts compRoot _) dflags = do
+setOptions :: GhcMonad m => NormalizedFilePath -> ComponentOptions -> DynFlags -> m (NE.NonEmpty (DynFlags, [GHC.Target]))
+setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do
     ((theOpts',errs,warns),units) <- processCmdLineP unit_flags [] (map noLoc theOpts)
     case NE.nonEmpty units of
       Just us -> initMulti us
-      Nothing -> (NE.:| []) <$> initOne (map unLoc theOpts')
+      Nothing -> do
+        (df, targets) <- initOne (map unLoc theOpts')
+        -- A special target for the file which caused this wonderful
+        -- component to be created. In case the cradle doesn't list all the targets for
+        -- the component, in which case things will be horribly broken anyway.
+        -- Otherwise, we will immediately attempt to reload this module which
+        -- causes an infinite loop and high CPU usage.
+        --
+        -- We don't do this when we have multiple components, because each
+        -- component better list all targets or there will be anarchy.
+        -- It is difficult to know which component to add our file to in
+        -- that case.
+        -- Multi unit arguments are likely to come from cabal, which
+        -- does list all targets.
+        abs_fp <- liftIO $ makeAbsolute (fromNormalizedFilePath cfp)
+        let special_target = Compat.mkSimpleTarget df abs_fp
+        pure $ (df, special_target : targets) NE.:| []
     where
       initMulti unitArgFiles =
         forM unitArgFiles $ \f -> do

ghcide/src/Development/IDE/GHC/Compat/Core.hs

@@ -282,6 +282,7 @@ module Development.IDE.GHC.Compat.Core (
     -- * Driver-Make
     Target(..),
     TargetId(..),
+    mkSimpleTarget,
     mkModuleGraph,
     -- * GHCi
     initObjLinker,
@@ -971,3 +972,10 @@ homeModInfoObject = hm_linkable
 field_label :: a -> a
 field_label = id
 #endif
+
+mkSimpleTarget :: DynFlags -> FilePath -> Target
+#if MIN_VERSION_ghc(9,3,0)
+mkSimpleTarget df fp = Target (TargetFile fp Nothing) True (homeUnitId_ df) Nothing
+#else
+mkSimpleTarget _ fp = Target (TargetFile fp Nothing) True Nothing
+#endif

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

@@ -17,7 +17,7 @@ import           GHC.Generics
 type KnownTargets = HashMap Target (HashSet NormalizedFilePath)
 
 data Target = TargetModule ModuleName | TargetFile NormalizedFilePath
-  deriving ( Eq, Generic, Show )
+  deriving ( Eq, Ord, Generic, Show )
   deriving anyclass (Hashable, NFData)
 
 toKnownFiles :: KnownTargets -> HashSet NormalizedFilePath