session-loader: Don't loop forever when we don't find a file in any m…

…ulti component (#4096)

* session-loader: Don't loop forever when we don't find a file in any multi component

We add a check for if the current file is a target we know about, and emit a
diagnostic if that is the case, refusing to load the file in.

This doesn't change the implicit adding of the current file as a target for a
single component case, as we need the old behaviour to support bare GHC/Direct
cradles where not all targets may be listed.

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

Co-authored-by: fendor <[email protected]>

---------

Co-authored-by: fendor <[email protected]>
Co-authored-by: Michael Peyton Jones <[email protected]>

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

@@ -585,9 +585,21 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
           let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv
           all_target_details <- new_cache old_deps new_deps
 
-          let all_targets = concatMap fst all_target_details
-
-          let this_flags_map = HM.fromList (concatMap toFlagsMap all_targets)
+          this_dep_info <- getDependencyInfo $ maybeToList hieYaml
+          let (all_targets, this_flags_map, this_options)
+                = case HM.lookup _cfp flags_map' of
+                    Just this -> (all_targets', flags_map', this)
+                    Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags)
+                  where all_targets' = concat all_target_details
+                        flags_map' = HM.fromList (concatMap toFlagsMap all_targets')
+                        this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp]
+                        this_flags = (this_error_env, this_dep_info)
+                        this_error_env = ([this_error], Nothing)
+                        this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp
+                                       $ T.unlines
+                                       [ "No cradle target found. Is this file listed in the targets of your cradle?"
+                                       , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section"
+                                       ]
 
           void $ modifyVar' fileToFlags $
               Map.insert hieYaml this_flags_map
@@ -615,7 +627,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
                     let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces
                     liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>)
 
-          return $ second Map.keys $ this_flags_map HM.! _cfp
+          return $ second Map.keys this_options
 
     let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
         consultCradle hieYaml cfp = do
@@ -810,7 +822,7 @@ newComponentCache
          -> HscEnv             -- ^ An empty HscEnv
          -> [ComponentInfo]    -- ^ New components to be loaded
          -> [ComponentInfo]    -- ^ old, already existing components
-         -> IO [ ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))]
+         -> IO [ [TargetDetails] ]
 newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do
     let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis)
         -- When we have multiple components with the same uid,
@@ -882,14 +894,13 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do
       henv <- createHscEnvEq thisEnv (zip uids dfs)
       let targetEnv = (if isBad ci then multi_errs else [], Just henv)
           targetDepends = componentDependencyInfo ci
-          res = ( targetEnv, targetDepends)
-      logWith recorder Debug $ LogNewComponentCache res
+      logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends)
       evaluate $ liftRnf rwhnf $ componentTargets ci
 
       let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends
       ctargets <- concatMapM mk (componentTargets ci)
 
-      return (L.nubOrdOn targetTarget ctargets, res)
+      return (L.nubOrdOn targetTarget ctargets)
 
 {- Note [Avoiding bad interface files]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1081,15 +1092,20 @@ setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do
         -- 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.
+        --
+        -- When we have a single component that is caused to be loaded due to a
+        -- file, we assume the file is part of that component. This is useful
+        -- for bare GHC sessions, such as many of the ones used in the testsuite
         --
         -- 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.
+        --
+        -- If we don't end up with a target for the current file in the end, then
+        -- we will report it as an error for that file
         abs_fp <- liftIO $ makeAbsolute (fromNormalizedFilePath cfp)
         let special_target = Compat.mkSimpleTarget df abs_fp
         pure $ (df, special_target : targets) :| []