+{-# LANGUAGE TypeFamilies #-}

+{-# LANGUAGE FunctionalDependencies #-}

+import Data.Either ( partitionEithers, lefts )

+import Data.IORef

+import qualified Data.List.NonEmpty as NE

+  n_jobs     <- mkWorkerLimit (hsc_dflags hsc_env)

+  summ_cache <- newIORef (mkModSummaryCache (zip old_summaries (repeat SummOld)))

+  imps_cache <- newIORef Map.empty

+  (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg

+                                   (getRootSummary excl_mods summ_cache imps_cache)

+       (downsweep_errs, downsweep_nodes) <-

+          downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph

+            excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) []

+       let (other_errs, unit_nodes) = partitionEithers $

+              HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) []

+                                      (hsc_HUG hsc_env)

+  summs <- newIORef (mkModSummaryCache [(mod_summary,SummOld)])

+  imps  <- newIORef mempty

+  ~(errs, mg) <- downsweepFromRootNodes hsc_env summs imps Nothing [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] []

+      interactive_mn = icInteractiveModule ic

+      key = dsNodeInfoKey (DSInteractive interactive_mn imps)

+  summ_cache <- newIORef mempty

+  imps_cache <- newIORef mempty

+  let env = DownsweepEnv hsc_env DownsweepUseFixed{-or UseCompiled?-} summ_cache imps_cache []

+  graph <- runDownsweepM env do

+    loopFromInteractive cached_nodes interactive_mn imps

+  let interactive_node  = expectJust $ M.lookup key graph

+      all_nodes  = M.elems graph

+    summs <- newIORef mempty

+    imps  <- newIORef mempty

+    (errs, mg) <- downsweepFromRootNodes hsc_env summs imps Nothing [] True DownsweepUseFixed nodes external_uids

+                  -> ModSummaryCache

+                  -> ImportsCache

+downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph excl_mods allow_dup_roots mode root_nodes root_uids = do

+     when (not allow_dup_roots) $

+       case root_duplicates of

+         []           -> return ()

+         (dup_root:_) -> multiRootsErr sec dup_root

+     let env = DownsweepEnv hsc_env mode summ_cache imps_cache excl_mods

+     deps' <- runDownsweepM env  $ do

+        let base_nodes = maybe M.empty moduleGraphNodeMap maybe_base_graph

+        module_deps <- loopModuleNodeInfos base_nodes root_nodes

+        all_deps    <- loopUnits module_deps (hscActiveUnitId hsc_env) root_uids

+        deps'       <- loopInstantiations all_deps (getHomeUnitInstantiations hsc_env)

+        return deps'

+     f_cache <- readIORef summ_cache

+     let downsweep_errs = lefts (M.elems f_cache)

+         downsweep_nodes = M.elems deps'

+

+     return (downsweep_errs, downsweep_nodes)

+  where

+    getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)]

+    getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey

+      (\nodes uid hue -> nodes ++  instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env)

+

+    -- In a root module, the filename is allowed to diverge from the module

+    -- name, so we have to check that there aren't multiple root files

+    -- defining the same module (otherwise the duplicates will be silently

+    -- ignored, leading to confusing behaviour).

+    root_duplicates :: [NE.NonEmpty ModuleNodeInfo]

+    root_duplicates = mapMaybe takes2 (M.elems root_map)

+       where

+         takes2 (a:as@(_:_)) = Just (a NE.:| as) -- Each at least of length 2

+         takes2 _            = Nothing

+

+         root_map = Map.fromListWith (flip (++))

+           [ ((moduleNodeInfoUnitId s, moduleNodeInfoMnwib s), [s])

+           | s <- root_nodes ]

+

+    moduleGraphNodeMap :: ModuleGraph -> M.Map NodeKey ModuleGraphNode

+    moduleGraphNodeMap graph

+        = M.fromList [(mkNodeKey node, node) | node <- mgModSummaries' graph]

+

+    sec = initSourceErrorContext (hsc_dflags hsc_env)

+    , _downsweep_summaries_cache :: ModSummaryCache

+    , downsweep_imports_cache :: ImportsCache

+type ModSummaryCache = IORef ModSummaryCacheMap

+type ImportsCache    = IORef ImportsCacheMap

+

+-- | A cache from file paths to the already summarised modules. The same file

+-- can be used in multiple units so the map is actually also keyed by which

+-- unit the file was used in.

+--

+-- We want to reuse ModSummaries as far as possible because the most expensive

+-- part of downsweep is reading and parsing the headers.

+--

+-- See Note [Downsweep Control Flow and Caching]

+type ModSummaryCacheMap

+      -- The cache can't be keyed by 'Module' because that isn't sufficient to

+      -- distinguish .hs from .hs-boot files. Use path+unit instead.

+      = ( M.Map (UnitId, OsPath) (Either DriverMessages (ModSummary, SummProvenance)) )

+

+data SummProvenance

+  -- | Constructed during this downsweep: trivially up to date

+  = SummFresh

+  -- | Carried over from a previous run: may be stale, must be hash-checked

+  -- (and considered by -fforce-recomp)

+  | SummOld

+

+mkModSummaryCache :: [(ModSummary, SummProvenance)] -> ModSummaryCacheMap

+mkModSummaryCache summs = foldl' (flip (uncurry addModSummaryCache)) M.empty summs

+

+addModSummaryCache :: ModSummary -> SummProvenance -> ModSummaryCacheMap -> ModSummaryCacheMap

+addModSummaryCache ms pr fe = upd_fe fe

+  where

+    upd_fe fe

+      | Just src_fn_os <- ml_hs_file_ospath (ms_location ms)

+      = M.insert (ms_unitid ms, src_fn_os) (Right (ms, pr)) fe

+      | otherwise = fe

+

+modifySummCache :: ModSummaryCache -> (ModSummaryCacheMap -> ModSummaryCacheMap) -> IO ()

+modifyImpsCache :: ImportsCache    -> (ImportsCacheMap    -> ImportsCacheMap)    -> IO ()

+modifySummCache r f = atomicModifyIORef' r (\c -> (f c, ()))

+modifyImpsCache r f = atomicModifyIORef' r (\c -> (f c, ()))

+

+-- | A cache from a module import (in given home unit context, with a package

+-- qualifier, and the imported module name (with or without SOURCE)) to the

+-- result of summarising that import (see 'summariseModuleDispatch').

+--

+-- See Note [Downsweep Control Flow and Caching]

+type ImportsCacheMap

+      = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) SummariseResult

+

+loopDownsweepNodes  :: M.Map NodeKey ModuleGraphNode -> [DownsweepNode]              -> DownsweepM (M.Map NodeKey ModuleGraphNode)

+loopModuleNodeInfos :: M.Map NodeKey ModuleGraphNode -> [ModuleNodeInfo]             -> DownsweepM (M.Map NodeKey ModuleGraphNode)

+loopUnits           :: M.Map NodeKey ModuleGraphNode -> UnitId -> [UnitId] -> DownsweepM (M.Map NodeKey ModuleGraphNode)

+loopInstantiations  :: M.Map NodeKey ModuleGraphNode -> [(UnitId, InstantiatedUnit)] -> DownsweepM (M.Map NodeKey ModuleGraphNode)

+loopFromInteractive :: M.Map NodeKey ModuleGraphNode -> Module -> [InteractiveImport] -> DownsweepM (M.Map NodeKey ModuleGraphNode)

+loopDownsweepNodes  base_map nodes = dfsBuild (Just base_map) nodes dsNodeInfoKey dsNodeExpand

+loopModuleNodeInfos base_map       = loopDownsweepNodes base_map . map DSMod

+loopUnits           base_map homud = loopDownsweepNodes base_map . map (DSUnit homud)

+loopInstantiations  base_map       = loopDownsweepNodes base_map . map (uncurry DSInst)

+loopFromInteractive base_map m     = loopDownsweepNodes base_map . (:[]) . DSInteractive m

+

+--------------------------------------------------------------------------------

+

+-- | A 'DownsweepNode' is the basic block of the downsweep algorithm which

+-- encompasses the types of nodes we can iteratively expand to construct the

+-- full module graph. See 'loopDownsweepNodes'.

+--

+-- See Note [Downsweep Control Flow and Caching]

+data DownsweepNode

+  -- | A module node to expand

+  = DSMod ModuleNodeInfo

+  -- | A unit node to expand

+  | DSUnit

+  { home_context_uid :: UnitId

+  -- ^ The home unit which introduced the dependency on this 'node_uid'. This

+  -- 'node_uid' can only be expanded in the context ('HscEnv') where

+  -- 'home_context_uid' is the active home unit, to make sure the package flags

+  -- are the ones attributed to the home package that introduced this node.

+  , node_uid         :: UnitId

+  -- ^ The unit node to expand

+  }

+  -- | FIXME: document the meaning of 'DSInst'

+  | DSInst

+  { home_context_uid :: UnitId

+  , instantiated_ud  :: InstantiatedUnit

+  }

+  -- | A group of interactive imports from this interactive Module

+  | DSInteractive Module [InteractiveImport]

+

+instance Outputable DownsweepNode where

+  ppr = \case

+    DSMod (ModuleNodeCompile ms) -> text "DSModC" <+> ppr (ms_mod_name ms)

+    DSMod (ModuleNodeFixed key _) -> text "DSModF" <+> ppr key

+    DSUnit{node_uid} -> text "DSUnit" <+> ppr node_uid

+    DSInst{instantiated_ud} -> text "DSInst" <+> ppr instantiated_ud

+    DSInteractive mod ii    -> text "DSInteractive" <+> ppr mod <+> ppr ii

+

+-- | They key by which to cache previously visited 'DownsweepNode's

+dsNodeInfoKey :: DownsweepNode -> NodeKey

+dsNodeInfoKey = \case

+  DSMod (ModuleNodeCompile ms)  -> NodeKey_Module (msKey ms)

+  DSMod (ModuleNodeFixed mod _) -> NodeKey_Module mod

+  DSUnit{node_uid}              -> NodeKey_ExternalUnit node_uid

+  DSInst{instantiated_ud}       -> NodeKey_Unit instantiated_ud

+  DSInteractive mod _imps       -> NodeKey_Module $ moduleToMnk mod NotBoot

+

+dsNodeExpand :: DownsweepNode -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode]))

+dsNodeExpand = \case

+  DSMod (ModuleNodeCompile ms)         -> expandModuleSummary ms

+  DSMod (ModuleNodeFixed key loc)      -> expandFixedModuleNode key loc

+  DSUnit{ node_uid, home_context_uid } -> expandUnitNode node_uid home_context_uid

+  DSInst{ instantiated_ud

+        , home_context_uid }           -> expandInstantiatedUnit instantiated_ud home_context_uid

+  DSInteractive imod iis               -> expandInteractiveImports imod iis

+

+expandModuleSummary :: ModSummary -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode]))

+expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do that.

+    hsc_env <- asks downsweep_hsc_env

+    let home_uid  = ms_unitid ms

+        home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)

+    (final_deps, todo) <- fmap unzip $ forM (calcDeps ms) $ \(imp,mb_pkg,gwib) -> do

+      let GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib

+          wanted_mod = L loc mod

+      mb_s <- downsweepSummarise home_unit is_boot wanted_mod mb_pkg Nothing

+      case mb_s of

+        NotThere -> return

+          ( Nothing, [] )

+        External uid -> return

+          ( Just $ mkModuleEdge imp (NodeKey_ExternalUnit uid)

+          -- Specify home unit, as each unit might have a different visible package database.

+          , [DSUnit{node_uid = uid, home_context_uid = home_uid}] )

+        FoundInstantiation iud -> return

+          ( Just (mkModuleEdge imp (NodeKey_Unit iud)), [] )

+        FoundHomeWithError (_uid, _e) -> return

+          ( Nothing, [] )

+          -- the error @e@ is already stored in the summarisation cache,

+          -- (the IORef in DownsweepM) and will get reported at the end.

+        FoundHome s -> return

+          -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.

+          ( Just $ mkModuleEdge imp (NodeKey_Module (mnKey s))

+          , [DSMod s] )

+

+    -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.

+    boot_todo <-

+      if | HsBootFile <- ms_hsc_src ms

+         -> do

+            r <- downsweepSummarise home_unit NotBoot (noLoc $ ms_mod_name ms) NoPkgQual Nothing

+            case r of

+              FoundHome s -> pure [DSMod s]

+              _           -> pure []

+         | otherwise      -> pure []

+

+    return $ Just

+      ( ModuleNode (catMaybes final_deps) (ModuleNodeCompile ms)

+      , boot_todo ++ concat todo

+      )

+

+-- | Expand a 'ModuleNodeFixed' node

+-- NB: If you ever reach a Fixed node, everything under that also must be fixed.

+expandFixedModuleNode :: ModNodeKeyWithUid -> ModLocation -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode]))

+expandFixedModuleNode key loc = do

+    hsc_env <- asks downsweep_hsc_env

+    -- MP: TODO, we should just read the dependency info from the interface rather than either

+    -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)

+    -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)

+    read_result <- liftIO $

+      -- 1. Check if the interface is already loaded into the EPS by some other

+      -- part of the compiler.

+      lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case

+        Just iface -> return (M.Succeeded iface)

+        Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)

+    case read_result of

+      M.Succeeded iface -> do

+        -- Computer information about this node

+        let node_deps = ifaceDeps (mi_deps iface)

+            edges = map mkFixedEdge node_deps

+            node = ModuleNode edges (ModuleNodeFixed key loc)

+        deps' <- catMaybes <$> mapM (mk_dep hsc_env) (bimap snd snd <$> node_deps)

+        pure $ Just (node, deps')

+

+      -- Ignore any failure, we might try to read a .hi-boot file for

+      -- example, even if there is not one.

+      M.Failed {} ->

+        pure Nothing

+  where

+    mk_dep hsc_env (Left key) = do

+      -- Like expandImports, but we already know exactly which module we are looking for.

+      read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)

+      case read_result of

+        InstalledFound loc -> do

+          pure $ Just $ DSMod (ModuleNodeFixed key loc)

+        _otherwise ->

+          -- If the finder fails, just keep going, there will be another

+          -- error later.

+          pure Nothing

+    mk_dep _ (Right uid_dep) = do

+      -- Set active unit so that looking loopUnit finds the correct

+      -- -package flags in the unit state.

+      let home_uid = mnkUnitId key

+      pure (Just DSUnit{node_uid=uid_dep, home_context_uid=home_uid})

+

+-- | Expand a unit id under the context of a certain home unit

+expandUnitNode :: UnitId {-^ @node_uid@ -} -> UnitId {-^ Home unit from where @node_uid@ was introduced -}

+               -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode]))

+expandUnitNode node_uid home_context_uid = do

+    -- Set active unit so that looking loopUnit finds the correct

+    -- -package flags in the unit state.

+    hsc_env <- asks downsweep_hsc_env

+    let lcl_hsc_env = hscSetActiveUnitId home_context_uid hsc_env

+    case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) node_uid of

+      Just us -> pure $ Just ((UnitNode us node_uid), map (\u -> DSUnit{node_uid=u, home_context_uid{-inherit-}}) us)

+      Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr node_uid)

+

+expandInstantiatedUnit :: InstantiatedUnit -> UnitId {-^ Home unit -} -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode]))

+expandInstantiatedUnit iud home_uid = pure $ Just

+  ( InstantiationNode home_uid iud

+  , [DSUnit{node_uid=instUnitInstanceOf iud, home_context_uid=home_uid}] )

+

+expandInteractiveImports :: Module -> [InteractiveImport] -> DownsweepM (Maybe (ModuleGraphNode, [DownsweepNode]))

+expandInteractiveImports imod imps = do

+  hsc_env    <- asks downsweep_hsc_env

+  imps_cache <- asks downsweep_imports_cache

+

+  let

+    -- A simple edge to a module from the same home unit

+    mkEdge (IIModule n) = return $

+      let

+        mod_node_key = ModNodeKeyWithUid

+          { mnkModuleName = GWIB (moduleName n) NotBoot

+          , mnkUnitId =

+              -- 'toUnitId' is safe here, as we can't import modules that

+              -- don't have a 'UnitId'.

+              toUnitId (moduleUnit n)

+          }

+       in (Just $ ModuleNodeEdge NormalLevel (NodeKey_Module mod_node_key), [])

+    -- A complete import statement

+    mkEdge (IIDecl i) =

+      let lvl = convImportLevel (ideclLevelSpec i)

+          wanted_mod = unLoc (ideclName i)

+          is_boot = ideclSource i

+          mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)

+          unitId = homeUnitId $ hsc_home_unit hsc_env

+      in do

+        let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env)

+        let k _ loc mod =

+              let key = moduleToMnk mod is_boot

+              in return $ FoundHome (ModuleNodeFixed key loc)

+

+        found <- liftIO $ summariseModuleDispatch k hsc_env imps_cache

+                            home_unit is_boot (noLoc wanted_mod) mb_pkg []

+        case found of

+          -- Case 1: Home modules have to already be in the cache.

+          FoundHome (ModuleNodeFixed mod _) -> do

+            let edge = ModuleNodeEdge lvl (NodeKey_Module mod)

+            -- Note: Does not perform any further downsweep as the module must already be in the cache.

+            return (Just edge, [])

+          -- Case 2: External units may not be in the cache, if we haven't already initialised the

+          -- module graph. We can construct the module graph for those here by calling loopUnit.

+          External uid -> do

+            let edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid)

+            return (Just edge, [DSUnit{node_uid=uid, home_context_uid=homeUnitId home_unit}])

+          -- And if it's not found.. just carry on and hope.

+          _ -> return (Nothing, [])

+

+  (module_edges, todo) <- unzip <$> mapM mkEdge imps

+  pure $ Just

+    ( ModuleNode (catMaybes module_edges) node_type, concat todo )

+    -- No sensible value for ModLocation.. if you hit this panic then you probably

+    -- need to add proper support for modules without any source files to the driver.

+    ml = pprPanic "modLocation" (ppr imod <+> ppr imps)

+    key = moduleToMnk imod NotBoot

+    node_type = ModuleNodeFixed key ml

+--------------------------------------------------------------------------------