{-# LANGUAGE LambdaCase      #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveTraversable #-}

-- | A module graph should be constructed once and never change from there onwards.
--
-- The only operations should be for building the 'ModuleGraph'
-- (once and for all -- no update-like/insert-like functions)
-- and querying the structure in various ways, e.g. to determine reachability.
--
-- We should avoid exposing fields like 'mg_mss' since it may be a footgun
-- trying to use the nodes directly... We do still expose it, but it feels like
-- all its use cases would be better served by a more proper ModuleGraph
-- abstraction
module GHC.Unit.Module.Graph
   (
    -- * Construct a module graph
    --
    -- | A module graph should be constructed once by downsweep and never modified.
     ModuleGraph(..)
   , emptyMG
   , mkModuleGraph
   , mkModuleGraphChecked

   -- * Invariant checking
   , checkModuleGraph
   , ModuleGraphInvariantError(..)

    -- * Nodes in a module graph
    --
    -- | The user-facing nodes in a module graph are 'ModuleGraphNode's.
    -- There are a few things which we can query out of each 'ModuleGraphNode':
    --
    -- - 'mgNodeDependencies' gets the immediate dependencies of this node
    -- - 'mgNodeUnitId' returns the 'UnitId' of that node
    -- - 'mgNodeModSum' extracts the 'ModSummary' of a node if exists
   , ModuleGraphNode(..)
   , mgNodeDependencies
   , mgNodeIsModule
   , mgNodeUnitId

   , ModuleNodeEdge(..)
   , mkModuleEdge
   , mkNormalEdge

   , ModuleNodeInfo(..)
   , moduleNodeInfoModule
   , moduleNodeInfoUnitId
   , moduleNodeInfoMnwib
   , moduleNodeInfoModuleName
   , moduleNodeInfoModNodeKeyWithUid
   , moduleNodeInfoHscSource
   , moduleNodeInfoLocation
   , isBootModuleNodeInfo
    -- * Module graph operations
   , lengthMG
   , isEmptyMG
    -- ** 'ModSummary' operations
    --
    -- | A couple of operations on the module graph allow access to the
    -- 'ModSummary's of the modules in it contained.
    --
    -- In particular, 'mapMG' and 'mapMGM' allow updating these 'ModSummary's
    -- (without changing the 'ModuleGraph' structure itself!).
    -- 'mgModSummaries' lists out all 'ModSummary's, and
    -- 'mgLookupModule' looks up a 'ModSummary' for a given module.
   , mapMG, mgMapM
   , mgModSummaries
   , mgLookupModule
   , mgLookupModuleName
   , mgHasHoles
   , HomeModuleNameProvidersMap
   , mgHomeModuleNameProvidersMap
   , showModMsg

    -- ** Reachability queries
    --
    -- | A module graph explains the structure and relationship between the
    -- modules being compiled. Often times, this structure is relevant to
    -- answer reachability queries -- is X reachable from Y; or, what is the
    -- transitive closure of Z?
   , mgReachable
   , mgReachableLoop
   , mgQuery
   , ZeroScopeKey(..)
   , mgQueryZero
   , mgQueryMany
   , mgQueryManyZero
   , mgMember

    -- ** Other operations
    --
    -- | These operations allow more-internal-than-ideal access to the
    -- ModuleGraph structure. Ideally, we could restructure the code using
    -- these functions to avoid deconstructing/reconstructing the ModuleGraph
    -- and instead extend the "proper interface" of the ModuleGraph to achieve
    -- what is currently done but through a better abstraction.
   , mgModSummaries'
   , moduleGraphNodes
   , moduleGraphModulesBelow -- needed for 'hptSomeThingsBelowUs',
                             -- but I think we could be more clever and cache
                             -- the graph-ixs of boot modules to efficiently
                             -- filter them out of the returned list.
                             -- hptInstancesBelow is re-doing that work every
                             -- time it's called.
   , filterToposortToModules
   , moduleGraphNodesZero
   , StageSummaryNode
   , stageSummaryNodeSummary
   , stageSummaryNodeKey
   , mkStageDeps

    -- * Keys into the 'ModuleGraph'
   , NodeKey(..)
   , mkNodeKey
   , nodeKeyUnitId
   , nodeKeyModName
   , ModNodeKey
   , ModNodeKeyWithUid(..)
   , mnkToModule
   , moduleToMnk
   , mnkToInstalledModule
   , installedModuleToMnk
   , mnkIsBoot
   , msKey
   , mnKey
   , miKey

   , ImportLevel(..)

    -- ** Internal node representation
    --
    -- | 'SummaryNode' is the internal representation for each node stored in
    -- the graph. It's not immediately clear to me why users do depend on them.
   , SummaryNode
   , summaryNodeSummary
   , summaryNodeKey

   )
where

import GHC.Prelude
import GHC.Platform

import GHC.Data.Maybe
import Data.Either
import GHC.Data.Graph.Directed
import GHC.Data.Graph.Directed.Reachability

import GHC.Driver.Backend
import GHC.Driver.DynFlags

import GHC.Types.SourceFile ( hscSourceString, isHsigFile, HscSource(..))
import GHC.Types.Basic

import GHC.Unit.Module.ModSummary
import GHC.Unit.Types
import GHC.Utils.Outputable
import GHC.Unit.Module.ModIface
import GHC.Utils.Misc ( partitionWith )

import System.FilePath
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import GHC.Types.Unique.DSet
import GHC.Types.Unique.Map (UniqMap, emptyUniqMap, listToUniqMap_C)
import GHC.Unit.Module
import GHC.Unit.Module.ModNodeKey
import GHC.Unit.Module.Stage
import GHC.Linker.Static.Utils

import Data.Bifunctor
import Data.Function
import Data.List (sort)
import Data.List.NonEmpty ( NonEmpty (..) )
import qualified Data.List.NonEmpty as NE
import Control.Monad
import qualified GHC.LanguageExtensions as LangExt

-- | A '@ModuleGraph@' contains all the nodes from the home package (only). See
-- '@ModuleGraphNode@' for information about the nodes.
--
-- Modules need to be compiled. hs-boots need to be typechecked before
-- the associated "real" module so modules with {-# SOURCE #-} imports can be
-- built. Instantiations also need to be typechecked to ensure that the module
-- fits the signature. Substantiation typechecking is roughly comparable to the
-- check that the module and its hs-boot agree.
--
-- The graph is not necessarily stored in topologically-sorted order. Use
-- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this.
data ModuleGraph = ModuleGraph
  { ModuleGraph -> [ModuleGraphNode]
mg_mss :: [ModuleGraphNode]
  , ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
  , ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
  , ModuleGraph
-> (ReachabilityIndex ZeroSummaryNode,
    ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_zero_graph :: (ReachabilityIndex ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode)

    -- `mg_graph` and `mg_loop_graph` cached transitive dependency calculations
    -- so that a lot of work is not repeated whenever the transitive
    -- dependencies need to be calculated (for example, hptInstances).
    --
    --- - `mg_graph` is a reachability index constructed from a module
    -- graph /with/ boot nodes (which make the graph acyclic), and
    --
    --- * `mg_loop_graph` is a reachability index for the graph /without/
    -- hs-boot nodes, that may be cyclic.

  , ModuleGraph -> Bool
mg_has_holes :: !Bool
  -- Cached computation, whether any of the ModuleGraphNode are isHoleModule,
  -- This is only used for a hack in GHC.Iface.Load to do with backpack, please
  -- remove this at the earliest opportunity.
  , ModuleGraph -> HomeModuleNameProvidersMap
mg_home_module_name_providers_map :: HomeModuleNameProvidersMap
    -- ^ For each module name, which home units provide it.
  }

type HomeModuleNameProvidersMap = UniqMap ModuleName (Set UnitId)

mkHomeModuleNameProvidersMap :: [ModuleGraphNode] -> HomeModuleNameProvidersMap
mkHomeModuleNameProvidersMap :: [ModuleGraphNode] -> HomeModuleNameProvidersMap
mkHomeModuleNameProvidersMap [ModuleGraphNode]
nodes
    = (Set UnitId -> Set UnitId -> Set UnitId)
-> [(ModuleName, Set UnitId)] -> HomeModuleNameProvidersMap
forall k a. Uniquable k => (a -> a -> a) -> [(k, a)] -> UniqMap k a
listToUniqMap_C Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([(ModuleName, Set UnitId)] -> HomeModuleNameProvidersMap)
-> [(ModuleName, Set UnitId)] -> HomeModuleNameProvidersMap
forall a b. (a -> b) -> a -> b
$
      [
          (ModuleName
moduleName, UnitId -> Set UnitId
forall a. a -> Set a
Set.singleton UnitId
unitID) |
              ModuleNode [ModuleNodeEdge]
_ ModuleNodeInfo
moduleNodeInfo <- [ModuleGraphNode]
nodes,
              let moduleName :: ModuleName
moduleName = ModuleNodeInfo -> ModuleName
moduleNodeInfoModuleName ModuleNodeInfo
moduleNodeInfo,
              let unitID :: UnitId
unitID     = ModuleNodeInfo -> UnitId
moduleNodeInfoUnitId ModuleNodeInfo
moduleNodeInfo
      ]

mgHomeModuleNameProvidersMap :: ModuleGraph -> HomeModuleNameProvidersMap
mgHomeModuleNameProvidersMap :: ModuleGraph -> HomeModuleNameProvidersMap
mgHomeModuleNameProvidersMap = ModuleGraph -> HomeModuleNameProvidersMap
mg_home_module_name_providers_map

-- | Why do we ever need to construct empty graphs? Is it because of one shot mode?
emptyMG :: ModuleGraph
emptyMG :: ModuleGraph
emptyMG = [ModuleGraphNode]
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
-> (ReachabilityIndex ZeroSummaryNode,
    ZeroScopeKey -> Maybe ZeroSummaryNode)
-> Bool
-> HomeModuleNameProvidersMap
-> ModuleGraph
ModuleGraph [] (Graph SummaryNode -> ReachabilityIndex SummaryNode
forall node. Graph node -> ReachabilityIndex node
graphReachability Graph SummaryNode
forall a. Graph a
emptyGraph, Maybe SummaryNode -> NodeKey -> Maybe SummaryNode
forall a b. a -> b -> a
const Maybe SummaryNode
forall a. Maybe a
Nothing)
                         (Graph SummaryNode -> ReachabilityIndex SummaryNode
forall node. Graph node -> ReachabilityIndex node
graphReachability Graph SummaryNode
forall a. Graph a
emptyGraph, Maybe SummaryNode -> NodeKey -> Maybe SummaryNode
forall a b. a -> b -> a
const Maybe SummaryNode
forall a. Maybe a
Nothing)
                         (Graph ZeroSummaryNode -> ReachabilityIndex ZeroSummaryNode
forall node. Graph node -> ReachabilityIndex node
graphReachability Graph ZeroSummaryNode
forall a. Graph a
emptyGraph, Maybe ZeroSummaryNode -> ZeroScopeKey -> Maybe ZeroSummaryNode
forall a b. a -> b -> a
const Maybe ZeroSummaryNode
forall a. Maybe a
Nothing)
                         Bool
False
                         HomeModuleNameProvidersMap
forall k a. UniqMap k a
emptyUniqMap

-- | Construct a module graph. This function should be the only entry point for
-- building a 'ModuleGraph', since it is supposed to be built once and never modified.
--
-- If you ever find the need to build a 'ModuleGraph' iteratively, don't
-- add insert and update functions to the API since they become footguns.
-- Instead, design an API that allows iterative construction without posterior
-- modification, perhaps like what is done for building arrays from mutable
-- arrays.
mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph
mkModuleGraph :: [ModuleGraphNode] -> ModuleGraph
mkModuleGraph = (ModuleGraphNode -> ModuleGraph -> ModuleGraph)
-> ModuleGraph -> [ModuleGraphNode] -> ModuleGraph
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((ModuleGraph -> ModuleGraphNode -> ModuleGraph)
-> ModuleGraphNode -> ModuleGraph -> ModuleGraph
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleGraph -> ModuleGraphNode -> ModuleGraph
extendMG) ModuleGraph
emptyMG

-- | A version of mkModuleGraph that checks the module graph for invariants.
mkModuleGraphChecked :: [ModuleGraphNode] -> Either [ModuleGraphInvariantError] ModuleGraph
mkModuleGraphChecked :: [ModuleGraphNode] -> Either [ModuleGraphInvariantError] ModuleGraph
mkModuleGraphChecked [ModuleGraphNode]
nodes =
  let mg :: ModuleGraph
mg = [ModuleGraphNode] -> ModuleGraph
mkModuleGraph [ModuleGraphNode]
nodes
  in case ModuleGraph -> [ModuleGraphInvariantError]
checkModuleGraph ModuleGraph
mg of
       [] -> ModuleGraph -> Either [ModuleGraphInvariantError] ModuleGraph
forall a b. b -> Either a b
Right ModuleGraph
mg
       [ModuleGraphInvariantError]
errors -> [ModuleGraphInvariantError]
-> Either [ModuleGraphInvariantError] ModuleGraph
forall a b. a -> Either a b
Left [ModuleGraphInvariantError]
errors

--------------------------------------------------------------------------------
-- * Module Graph Nodes
--------------------------------------------------------------------------------

-- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'.
-- Edges between nodes mark dependencies arising from module imports
-- and dependencies arising from backpack instantiations.
data ModuleGraphNode
  -- | Instantiation nodes track the instantiation of other units
  -- (backpack dependencies) with the holes (signatures) of the current package.
  = InstantiationNode UnitId InstantiatedUnit
  -- | There is a module node for each module being built.
  -- A node is either fixed or can be compiled.
  -- - Fixed modules are not compiled, the artifacts are just loaded from disk.
  --   It is up to your to make sure the artifacts are up to date and available.
  -- - Compile modules are compiled from source if needed.
  | ModuleNode [ModuleNodeEdge] ModuleNodeInfo
  -- | Link nodes are whether are are creating a linked product (ie executable/shared object etc) for a unit.
  | LinkNode [NodeKey] UnitId
  -- | Package dependency
  | UnitNode [UnitId] UnitId


data ModuleNodeEdge = ModuleNodeEdge { ModuleNodeEdge -> ImportLevel
edgeLevel :: ImportLevel
                                     , ModuleNodeEdge -> NodeKey
edgeTargetKey :: NodeKey }

mkModuleEdge :: ImportLevel -> NodeKey -> ModuleNodeEdge
mkModuleEdge :: ImportLevel -> NodeKey -> ModuleNodeEdge
mkModuleEdge ImportLevel
level NodeKey
key = ImportLevel -> NodeKey -> ModuleNodeEdge
ModuleNodeEdge ImportLevel
level NodeKey
key

-- | A 'normal' edge in the graph which isn't offset by an import stage.
mkNormalEdge :: NodeKey -> ModuleNodeEdge
mkNormalEdge :: NodeKey -> ModuleNodeEdge
mkNormalEdge = ImportLevel -> NodeKey -> ModuleNodeEdge
mkModuleEdge ImportLevel
NormalLevel

instance Outputable ModuleNodeEdge where
  ppr :: ModuleNodeEdge -> SDoc
ppr (ModuleNodeEdge ImportLevel
level NodeKey
key) =
    let level_str :: String
level_str = case ImportLevel
level of
                      ImportLevel
NormalLevel -> String
""
                      ImportLevel
SpliceLevel -> String
"(S)"
                      ImportLevel
QuoteLevel -> String
"(Q)"
    in String -> SDoc
forall doc. IsLine doc => String -> doc
text String
level_str SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> NodeKey -> SDoc
forall a. Outputable a => a -> SDoc
ppr NodeKey
key

data ModuleGraphInvariantError =
        FixedNodeDependsOnCompileNode ModNodeKeyWithUid [NodeKey]
      | DuplicateModuleNodeKey NodeKey
      | DependencyNotInGraph NodeKey [NodeKey]
      deriving (ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool
(ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool)
-> (ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool)
-> Eq ModuleGraphInvariantError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool
== :: ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool
$c/= :: ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool
/= :: ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool
Eq, Eq ModuleGraphInvariantError
Eq ModuleGraphInvariantError =>
(ModuleGraphInvariantError
 -> ModuleGraphInvariantError -> Ordering)
-> (ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool)
-> (ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool)
-> (ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool)
-> (ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool)
-> (ModuleGraphInvariantError
    -> ModuleGraphInvariantError -> ModuleGraphInvariantError)
-> (ModuleGraphInvariantError
    -> ModuleGraphInvariantError -> ModuleGraphInvariantError)
-> Ord ModuleGraphInvariantError
ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool
ModuleGraphInvariantError -> ModuleGraphInvariantError -> Ordering
ModuleGraphInvariantError
-> ModuleGraphInvariantError -> ModuleGraphInvariantError
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ModuleGraphInvariantError -> ModuleGraphInvariantError -> Ordering
compare :: ModuleGraphInvariantError -> ModuleGraphInvariantError -> Ordering
$c< :: ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool
< :: ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool
$c<= :: ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool
<= :: ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool
$c> :: ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool
> :: ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool
$c>= :: ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool
>= :: ModuleGraphInvariantError -> ModuleGraphInvariantError -> Bool
$cmax :: ModuleGraphInvariantError
-> ModuleGraphInvariantError -> ModuleGraphInvariantError
max :: ModuleGraphInvariantError
-> ModuleGraphInvariantError -> ModuleGraphInvariantError
$cmin :: ModuleGraphInvariantError
-> ModuleGraphInvariantError -> ModuleGraphInvariantError
min :: ModuleGraphInvariantError
-> ModuleGraphInvariantError -> ModuleGraphInvariantError
Ord)

instance Outputable ModuleGraphInvariantError where
  ppr :: ModuleGraphInvariantError -> SDoc
ppr = \case
    FixedNodeDependsOnCompileNode ModNodeKeyWithUid
key [NodeKey]
bad_deps ->
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Fixed node" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModNodeKeyWithUid -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModNodeKeyWithUid
key SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"depends on compile nodes" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [NodeKey] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [NodeKey]
bad_deps
    DuplicateModuleNodeKey NodeKey
k ->
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Duplicate module node key" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> NodeKey -> SDoc
forall a. Outputable a => a -> SDoc
ppr NodeKey
k
    DependencyNotInGraph NodeKey
from [NodeKey]
to ->
      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Dependency not in graph" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> NodeKey -> SDoc
forall a. Outputable a => a -> SDoc
ppr NodeKey
from SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"->" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [NodeKey] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [NodeKey]
to

-- Used for invariant checking. Is a NodeKey fixed or compilable?
data ModuleNodeType = MN_Fixed | MN_Compile

instance Outputable ModuleNodeType where
  ppr :: ModuleNodeType -> SDoc
ppr = \case
    ModuleNodeType
MN_Fixed -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Fixed"
    ModuleNodeType
MN_Compile -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Compile"

moduleNodeType :: ModuleGraphNode -> ModuleNodeType
moduleNodeType :: ModuleGraphNode -> ModuleNodeType
moduleNodeType (ModuleNode [ModuleNodeEdge]
_ (ModuleNodeCompile ModSummary
_)) = ModuleNodeType
MN_Compile
moduleNodeType (ModuleNode [ModuleNodeEdge]
_ (ModuleNodeFixed ModNodeKeyWithUid
_ ModLocation
_)) = ModuleNodeType
MN_Fixed
moduleNodeType (UnitNode {}) = ModuleNodeType
MN_Fixed
moduleNodeType ModuleGraphNode
_ = ModuleNodeType
MN_Compile

checkModuleGraph :: ModuleGraph -> [ModuleGraphInvariantError]
checkModuleGraph :: ModuleGraph -> [ModuleGraphInvariantError]
checkModuleGraph ModuleGraph{Bool
[ModuleGraphNode]
(ReachabilityIndex ZeroSummaryNode,
 ZeroScopeKey -> Maybe ZeroSummaryNode)
(ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
HomeModuleNameProvidersMap
mg_mss :: ModuleGraph -> [ModuleGraphNode]
mg_graph :: ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph :: ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_zero_graph :: ModuleGraph
-> (ReachabilityIndex ZeroSummaryNode,
    ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_has_holes :: ModuleGraph -> Bool
mg_home_module_name_providers_map :: ModuleGraph -> HomeModuleNameProvidersMap
mg_mss :: [ModuleGraphNode]
mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_zero_graph :: (ReachabilityIndex ZeroSummaryNode,
 ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_has_holes :: Bool
mg_home_module_name_providers_map :: HomeModuleNameProvidersMap
..} =
  (ModuleGraphNode -> Maybe ModuleGraphInvariantError)
-> [ModuleGraphNode] -> [ModuleGraphInvariantError]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
-> ModuleGraphNode -> Maybe ModuleGraphInvariantError
checkFixedModuleInvariant Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
node_types) [ModuleGraphNode]
mg_mss
  [ModuleGraphInvariantError]
-> [ModuleGraphInvariantError] -> [ModuleGraphInvariantError]
forall a. [a] -> [a] -> [a]
++ (ModuleGraphNode -> Maybe ModuleGraphInvariantError)
-> [ModuleGraphNode] -> [ModuleGraphInvariantError]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
-> ModuleGraphNode -> Maybe ModuleGraphInvariantError
checkAllDependenciesInGraph Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
node_types) [ModuleGraphNode]
mg_mss
  [ModuleGraphInvariantError]
-> [ModuleGraphInvariantError] -> [ModuleGraphInvariantError]
forall a. [a] -> [a] -> [a]
++ [ModuleGraphInvariantError]
duplicate_errs
  where
    duplicate_errs :: [ModuleGraphInvariantError]
duplicate_errs = [Either ModuleNodeType ModuleGraphInvariantError]
-> [ModuleGraphInvariantError]
forall a b. [Either a b] -> [b]
rights (Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
-> [Either ModuleNodeType ModuleGraphInvariantError]
forall k a. Map k a -> [a]
Map.elems Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
node_types)

    node_types :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
    node_types :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
node_types = (NodeKey
 -> Either ModuleNodeType ModuleGraphInvariantError
 -> Either ModuleNodeType ModuleGraphInvariantError
 -> Either ModuleNodeType ModuleGraphInvariantError)
-> [(NodeKey, Either ModuleNodeType ModuleGraphInvariantError)]
-> Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
forall k a. Ord k => (k -> a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWithKey NodeKey
-> Either ModuleNodeType ModuleGraphInvariantError
-> Either ModuleNodeType ModuleGraphInvariantError
-> Either ModuleNodeType ModuleGraphInvariantError
go [ (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
n, ModuleNodeType -> Either ModuleNodeType ModuleGraphInvariantError
forall a b. a -> Either a b
Left (ModuleGraphNode -> ModuleNodeType
moduleNodeType ModuleGraphNode
n)) | ModuleGraphNode
n <- [ModuleGraphNode]
mg_mss ]
      where
        -- Multiple nodes with the same key are not allowed.
        go :: NodeKey -> Either ModuleNodeType ModuleGraphInvariantError
                      -> Either ModuleNodeType ModuleGraphInvariantError
                      -> Either ModuleNodeType ModuleGraphInvariantError
        go :: NodeKey
-> Either ModuleNodeType ModuleGraphInvariantError
-> Either ModuleNodeType ModuleGraphInvariantError
-> Either ModuleNodeType ModuleGraphInvariantError
go NodeKey
k Either ModuleNodeType ModuleGraphInvariantError
_ Either ModuleNodeType ModuleGraphInvariantError
_ = ModuleGraphInvariantError
-> Either ModuleNodeType ModuleGraphInvariantError
forall a b. b -> Either a b
Right (NodeKey -> ModuleGraphInvariantError
DuplicateModuleNodeKey NodeKey
k)

-- | Check that all dependencies in the graph are present in the node_types map.
-- This is a helper function used by checkModuleGraph.
checkAllDependenciesInGraph :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
                            -> ModuleGraphNode
                            -> Maybe ModuleGraphInvariantError
checkAllDependenciesInGraph :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
-> ModuleGraphNode -> Maybe ModuleGraphInvariantError
checkAllDependenciesInGraph Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
node_types ModuleGraphNode
node =
  let nodeKey :: NodeKey
nodeKey = ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
node
      deps :: [NodeKey]
deps = Bool -> ModuleGraphNode -> [NodeKey]
mgNodeDependencies Bool
False ModuleGraphNode
node
      missingDeps :: [NodeKey]
missingDeps = (NodeKey -> Bool) -> [NodeKey] -> [NodeKey]
forall a. (a -> Bool) -> [a] -> [a]
filter (\NodeKey
dep -> Bool -> Bool
not (NodeKey
-> Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
-> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member NodeKey
dep Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
node_types)) [NodeKey]
deps
  in if [NodeKey] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeKey]
missingDeps
     then Maybe ModuleGraphInvariantError
forall a. Maybe a
Nothing
     else ModuleGraphInvariantError -> Maybe ModuleGraphInvariantError
forall a. a -> Maybe a
Just (NodeKey -> [NodeKey] -> ModuleGraphInvariantError
DependencyNotInGraph NodeKey
nodeKey [NodeKey]
missingDeps)


-- | Check if for the fixed module node invariant:
--
--   Fixed nodes can only depend on other fixed nodes.
checkFixedModuleInvariant :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
                -> ModuleGraphNode
                -> Maybe ModuleGraphInvariantError
checkFixedModuleInvariant :: Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
-> ModuleGraphNode -> Maybe ModuleGraphInvariantError
checkFixedModuleInvariant Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
node_types ModuleGraphNode
node = case ModuleGraphNode
node of
  ModuleNode [ModuleNodeEdge]
deps (ModuleNodeFixed ModNodeKeyWithUid
key ModLocation
_) ->
    let check_node :: NodeKey -> Maybe NodeKey
check_node NodeKey
dep = case NodeKey
-> Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
-> Maybe (Either ModuleNodeType ModuleGraphInvariantError)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeKey
dep Map NodeKey (Either ModuleNodeType ModuleGraphInvariantError)
node_types of
                           -- Dependency is not fixed
                           Just (Left ModuleNodeType
MN_Compile) -> NodeKey -> Maybe NodeKey
forall a. a -> Maybe a
Just NodeKey
dep
                           Maybe (Either ModuleNodeType ModuleGraphInvariantError)
_ -> Maybe NodeKey
forall a. Maybe a
Nothing
        bad_deps :: [NodeKey]
bad_deps = (NodeKey -> Maybe NodeKey) -> [NodeKey] -> [NodeKey]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NodeKey -> Maybe NodeKey
check_node ((ModuleNodeEdge -> NodeKey) -> [ModuleNodeEdge] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map ModuleNodeEdge -> NodeKey
edgeTargetKey [ModuleNodeEdge]
deps)
    in if [NodeKey] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NodeKey]
bad_deps
       then Maybe ModuleGraphInvariantError
forall a. Maybe a
Nothing
       else ModuleGraphInvariantError -> Maybe ModuleGraphInvariantError
forall a. a -> Maybe a
Just (ModNodeKeyWithUid -> [NodeKey] -> ModuleGraphInvariantError
FixedNodeDependsOnCompileNode ModNodeKeyWithUid
key [NodeKey]
bad_deps)

  ModuleGraphNode
_ -> Maybe ModuleGraphInvariantError
forall a. Maybe a
Nothing


{- Note [Module Types in the ModuleGraph]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Modules can be one of two different types in the module graph.

1. ModuleNodeCompile, modules with source files we can compile.
2. ModuleNodeFixed, modules which we presume are already compiled and available.

The ModuleGraph can contain a combination of these two types of nodes but must
obey the invariant that Fixed nodes only depend on other Fixed nodes. This invariant
can be checked by the `checkModuleGraph` function, but it's
the responsibility of the code constructing the ModuleGraph to ensure it is upheld.

At the moment, when using --make mode, GHC itself will only use `ModuleNodeCompile` nodes.

In oneshot mode, we don't have access to the source files of dependencies but sometimes need to know
information about the module graph still (for example, getLinkDeps).

In theory, the whole compiler will work if an API program uses ModuleNodeFixed nodes, and
there is a simple test in FixedNodes, which can be extended in future to cover
any missing cases.

-}
data ModuleNodeInfo = ModuleNodeFixed ModNodeKeyWithUid ModLocation
                    | ModuleNodeCompile ModSummary

-- | Extract the Module from a ModuleNodeInfo
moduleNodeInfoModule :: ModuleNodeInfo -> Module
moduleNodeInfoModule :: ModuleNodeInfo -> Module
moduleNodeInfoModule (ModuleNodeFixed ModNodeKeyWithUid
key ModLocation
_) = ModNodeKeyWithUid -> Module
mnkToModule ModNodeKeyWithUid
key
moduleNodeInfoModule (ModuleNodeCompile ModSummary
ms) = ModSummary -> Module
ms_mod ModSummary
ms

-- | Extract the ModNodeKeyWithUid from a ModuleNodeInfo
moduleNodeInfoModNodeKeyWithUid :: ModuleNodeInfo -> ModNodeKeyWithUid
moduleNodeInfoModNodeKeyWithUid :: ModuleNodeInfo -> ModNodeKeyWithUid
moduleNodeInfoModNodeKeyWithUid (ModuleNodeFixed ModNodeKeyWithUid
key ModLocation
_) = ModNodeKeyWithUid
key
moduleNodeInfoModNodeKeyWithUid (ModuleNodeCompile ModSummary
ms) = ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms

-- | Extract the HscSource from a ModuleNodeInfo, if we can determine it.
moduleNodeInfoHscSource :: ModuleNodeInfo -> Maybe HscSource
moduleNodeInfoHscSource :: ModuleNodeInfo -> Maybe HscSource
moduleNodeInfoHscSource (ModuleNodeFixed ModNodeKeyWithUid
_ ModLocation
_) = Maybe HscSource
forall a. Maybe a
Nothing
moduleNodeInfoHscSource (ModuleNodeCompile ModSummary
ms) = HscSource -> Maybe HscSource
forall a. a -> Maybe a
Just (ModSummary -> HscSource
ms_hsc_src ModSummary
ms)

-- | Extract the ModLocation from a ModuleNodeInfo
moduleNodeInfoLocation :: ModuleNodeInfo -> ModLocation
moduleNodeInfoLocation :: ModuleNodeInfo -> ModLocation
moduleNodeInfoLocation (ModuleNodeFixed ModNodeKeyWithUid
_ ModLocation
loc) = ModLocation
loc
moduleNodeInfoLocation (ModuleNodeCompile ModSummary
ms) = ModSummary -> ModLocation
ms_location ModSummary
ms

-- | Extract the IsBootInterface from a ModuleNodeInfo
isBootModuleNodeInfo :: ModuleNodeInfo -> IsBootInterface
isBootModuleNodeInfo :: ModuleNodeInfo -> IsBootInterface
isBootModuleNodeInfo (ModuleNodeFixed ModNodeKeyWithUid
mnwib ModLocation
_) = ModNodeKeyWithUid -> IsBootInterface
mnkIsBoot ModNodeKeyWithUid
mnwib
isBootModuleNodeInfo (ModuleNodeCompile ModSummary
ms) = ModSummary -> IsBootInterface
isBootSummary ModSummary
ms

-- | Extract the ModuleName from a ModuleNodeInfo
moduleNodeInfoModuleName :: ModuleNodeInfo -> ModuleName
moduleNodeInfoModuleName :: ModuleNodeInfo -> ModuleName
moduleNodeInfoModuleName ModuleNodeInfo
m = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModuleNodeInfo -> Module
moduleNodeInfoModule ModuleNodeInfo
m)

moduleNodeInfoUnitId :: ModuleNodeInfo -> UnitId
moduleNodeInfoUnitId :: ModuleNodeInfo -> UnitId
moduleNodeInfoUnitId (ModuleNodeFixed ModNodeKeyWithUid
key ModLocation
_) = ModNodeKeyWithUid -> UnitId
mnkUnitId ModNodeKeyWithUid
key
moduleNodeInfoUnitId (ModuleNodeCompile ModSummary
ms) = ModSummary -> UnitId
ms_unitid ModSummary
ms

moduleNodeInfoMnwib :: ModuleNodeInfo -> ModuleNameWithIsBoot
moduleNodeInfoMnwib :: ModuleNodeInfo -> ModuleNameWithIsBoot
moduleNodeInfoMnwib (ModuleNodeFixed ModNodeKeyWithUid
key ModLocation
_) = ModNodeKeyWithUid -> ModuleNameWithIsBoot
mnkModuleName ModNodeKeyWithUid
key
moduleNodeInfoMnwib (ModuleNodeCompile ModSummary
ms) = ModSummary -> ModuleNameWithIsBoot
ms_mnwib ModSummary
ms

-- | Collect the immediate dependencies of a ModuleGraphNode,
-- optionally avoiding hs-boot dependencies.
-- If the drop_hs_boot_nodes flag is False, and if this is a .hs and there is
-- an equivalent .hs-boot, add a link from the former to the latter.  This
-- has the effect of detecting bogus cases where the .hs-boot depends on the
-- .hs, by introducing a cycle.  Additionally, it ensures that we will always
-- process the .hs-boot before the .hs, and so the HomePackageTable will always
-- have the most up to date information.
mgNodeDependencies :: Bool -> ModuleGraphNode -> [NodeKey]
mgNodeDependencies :: Bool -> ModuleGraphNode -> [NodeKey]
mgNodeDependencies Bool
drop_hs_boot_nodes = \case
    LinkNode [NodeKey]
deps UnitId
_uid -> [NodeKey]
deps
    InstantiationNode UnitId
uid InstantiatedUnit
iuid ->
      [ ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
mod IsBootInterface
NotBoot) UnitId
uid) | ModuleName
mod <- UniqDSet ModuleName -> [ModuleName]
forall a. UniqDSet a -> [a]
uniqDSetToList (InstantiatedUnit -> UniqDSet ModuleName
forall unit. GenInstantiatedUnit unit -> UniqDSet ModuleName
instUnitHoles InstantiatedUnit
iuid) ]
      [NodeKey] -> [NodeKey] -> [NodeKey]
forall a. [a] -> [a] -> [a]
++ [ UnitId -> NodeKey
NodeKey_ExternalUnit (InstantiatedUnit -> UnitId
forall unit. GenInstantiatedUnit unit -> unit
instUnitInstanceOf InstantiatedUnit
iuid) ]
    ModuleNode [ModuleNodeEdge]
deps ModuleNodeInfo
_ms ->
      (ModuleNodeEdge -> NodeKey) -> [ModuleNodeEdge] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map (NodeKey -> NodeKey
drop_hs_boot (NodeKey -> NodeKey)
-> (ModuleNodeEdge -> NodeKey) -> ModuleNodeEdge -> NodeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleNodeEdge -> NodeKey
edgeTargetKey) [ModuleNodeEdge]
deps
    UnitNode [UnitId]
deps UnitId
_ -> (UnitId -> NodeKey) -> [UnitId] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> NodeKey
NodeKey_ExternalUnit [UnitId]
deps
  where
    -- Drop hs-boot nodes by using HsSrcFile as the key
    hs_boot_key :: IsBootInterface
hs_boot_key | Bool
drop_hs_boot_nodes = IsBootInterface
NotBoot -- is regular mod or signature
                | Bool
otherwise          = IsBootInterface
IsBoot

    drop_hs_boot :: NodeKey -> NodeKey
drop_hs_boot (NodeKey_Module (ModNodeKeyWithUid (GWIB ModuleName
mn IsBootInterface
IsBoot) UnitId
uid)) = (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModuleName -> IsBootInterface -> ModuleNameWithIsBoot
forall mod. mod -> IsBootInterface -> GenWithIsBoot mod
GWIB ModuleName
mn IsBootInterface
hs_boot_key) UnitId
uid))
    drop_hs_boot NodeKey
x = NodeKey
x

mgNodeIsModule :: ModuleGraphNode -> Maybe ModuleNodeInfo
mgNodeIsModule :: ModuleGraphNode -> Maybe ModuleNodeInfo
mgNodeIsModule (InstantiationNode {}) = Maybe ModuleNodeInfo
forall a. Maybe a
Nothing
mgNodeIsModule (LinkNode {})          = Maybe ModuleNodeInfo
forall a. Maybe a
Nothing
mgNodeIsModule (ModuleNode [ModuleNodeEdge]
_ ModuleNodeInfo
ms)      = ModuleNodeInfo -> Maybe ModuleNodeInfo
forall a. a -> Maybe a
Just ModuleNodeInfo
ms
mgNodeIsModule (UnitNode {})       = Maybe ModuleNodeInfo
forall a. Maybe a
Nothing

mgNodeUnitId :: ModuleGraphNode -> UnitId
mgNodeUnitId :: ModuleGraphNode -> UnitId
mgNodeUnitId ModuleGraphNode
mgn =
  case ModuleGraphNode
mgn of
    InstantiationNode UnitId
uid InstantiatedUnit
_iud -> UnitId
uid
    ModuleNode [ModuleNodeEdge]
_ ModuleNodeInfo
ms           -> GenUnit UnitId -> UnitId
toUnitId (Module -> GenUnit UnitId
forall unit. GenModule unit -> unit
moduleUnit (ModuleNodeInfo -> Module
moduleNodeInfoModule ModuleNodeInfo
ms))
    LinkNode [NodeKey]
_ UnitId
uid             -> UnitId
uid
    UnitNode [UnitId]
_ UnitId
uid          -> UnitId
uid

instance Outputable ModuleGraphNode where
  ppr :: ModuleGraphNode -> SDoc
ppr = \case
    InstantiationNode UnitId
_ InstantiatedUnit
iuid -> InstantiatedUnit -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
iuid
    ModuleNode [ModuleNodeEdge]
nks ModuleNodeInfo
ms -> ModNodeKeyWithUid -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModuleNodeInfo -> ModNodeKeyWithUid
mnKey ModuleNodeInfo
ms) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [ModuleNodeEdge] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ModuleNodeEdge]
nks
    LinkNode [NodeKey]
uid UnitId
_     -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"LN:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [NodeKey] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [NodeKey]
uid
    UnitNode [UnitId]
_ UnitId
uid  -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"P:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
uid

instance Eq ModuleGraphNode where
  == :: ModuleGraphNode -> ModuleGraphNode -> Bool
(==) = NodeKey -> NodeKey -> Bool
forall a. Eq a => a -> a -> Bool
(==) (NodeKey -> NodeKey -> Bool)
-> (ModuleGraphNode -> NodeKey)
-> ModuleGraphNode
-> ModuleGraphNode
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ModuleGraphNode -> NodeKey
mkNodeKey

instance Ord ModuleGraphNode where
  compare :: ModuleGraphNode -> ModuleGraphNode -> Ordering
compare = NodeKey -> NodeKey -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (NodeKey -> NodeKey -> Ordering)
-> (ModuleGraphNode -> NodeKey)
-> ModuleGraphNode
-> ModuleGraphNode
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ModuleGraphNode -> NodeKey
mkNodeKey

--------------------------------------------------------------------------------
-- * Module Graph operations
--------------------------------------------------------------------------------
-- | Returns the number of nodes in a 'ModuleGraph'
lengthMG :: ModuleGraph -> Int
lengthMG :: ModuleGraph -> Int
lengthMG = [ModuleGraphNode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([ModuleGraphNode] -> Int)
-> (ModuleGraph -> [ModuleGraphNode]) -> ModuleGraph -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleGraph -> [ModuleGraphNode]
mg_mss

isEmptyMG :: ModuleGraph -> Bool
isEmptyMG :: ModuleGraph -> Bool
isEmptyMG = [ModuleGraphNode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([ModuleGraphNode] -> Bool)
-> (ModuleGraph -> [ModuleGraphNode]) -> ModuleGraph -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleGraph -> [ModuleGraphNode]
mg_mss

--------------------------------------------------------------------------------
-- ** ModSummaries
--------------------------------------------------------------------------------

-- | Map a function 'f' over all the 'ModSummaries'.
-- To preserve invariants, 'f' can't change the isBoot status.
mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
mapMG ModSummary -> ModSummary
f mg :: ModuleGraph
mg@ModuleGraph{Bool
[ModuleGraphNode]
(ReachabilityIndex ZeroSummaryNode,
 ZeroScopeKey -> Maybe ZeroSummaryNode)
(ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
HomeModuleNameProvidersMap
mg_mss :: ModuleGraph -> [ModuleGraphNode]
mg_graph :: ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph :: ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_zero_graph :: ModuleGraph
-> (ReachabilityIndex ZeroSummaryNode,
    ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_has_holes :: ModuleGraph -> Bool
mg_home_module_name_providers_map :: ModuleGraph -> HomeModuleNameProvidersMap
mg_mss :: [ModuleGraphNode]
mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_zero_graph :: (ReachabilityIndex ZeroSummaryNode,
 ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_has_holes :: Bool
mg_home_module_name_providers_map :: HomeModuleNameProvidersMap
..} = ModuleGraph
mg
  { mg_mss = new_mss
  , mg_home_module_name_providers_map = mkHomeModuleNameProvidersMap new_mss
  }
  where
    new_mss :: [ModuleGraphNode]
new_mss =
      ((ModuleGraphNode -> ModuleGraphNode)
 -> [ModuleGraphNode] -> [ModuleGraphNode])
-> [ModuleGraphNode]
-> (ModuleGraphNode -> ModuleGraphNode)
-> [ModuleGraphNode]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (ModuleGraphNode -> ModuleGraphNode)
-> [ModuleGraphNode] -> [ModuleGraphNode]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ModuleGraphNode]
mg_mss ((ModuleGraphNode -> ModuleGraphNode) -> [ModuleGraphNode])
-> (ModuleGraphNode -> ModuleGraphNode) -> [ModuleGraphNode]
forall a b. (a -> b) -> a -> b
$ \case
        InstantiationNode UnitId
uid InstantiatedUnit
iuid -> UnitId -> InstantiatedUnit -> ModuleGraphNode
InstantiationNode UnitId
uid InstantiatedUnit
iuid
        LinkNode [NodeKey]
uid UnitId
nks -> [NodeKey] -> UnitId -> ModuleGraphNode
LinkNode [NodeKey]
uid UnitId
nks
        ModuleNode [ModuleNodeEdge]
deps (ModuleNodeFixed ModNodeKeyWithUid
key ModLocation
loc)  -> [ModuleNodeEdge] -> ModuleNodeInfo -> ModuleGraphNode
ModuleNode [ModuleNodeEdge]
deps (ModNodeKeyWithUid -> ModLocation -> ModuleNodeInfo
ModuleNodeFixed ModNodeKeyWithUid
key ModLocation
loc)
        ModuleNode [ModuleNodeEdge]
deps (ModuleNodeCompile ModSummary
ms) -> [ModuleNodeEdge] -> ModuleNodeInfo -> ModuleGraphNode
ModuleNode [ModuleNodeEdge]
deps (ModSummary -> ModuleNodeInfo
ModuleNodeCompile (ModSummary -> ModSummary
f ModSummary
ms))
        UnitNode [UnitId]
deps UnitId
uid -> [UnitId] -> UnitId -> ModuleGraphNode
UnitNode [UnitId]
deps UnitId
uid

-- | Map a function 'f' over all the 'ModSummaries', in 'IO'.
-- To preserve invariants, 'f' can't change the isBoot status.
mgMapM :: (ModuleNodeInfo -> IO ModuleNodeInfo) -> ModuleGraph -> IO ModuleGraph
mgMapM :: (ModuleNodeInfo -> IO ModuleNodeInfo)
-> ModuleGraph -> IO ModuleGraph
mgMapM ModuleNodeInfo -> IO ModuleNodeInfo
f mg :: ModuleGraph
mg@ModuleGraph{Bool
[ModuleGraphNode]
(ReachabilityIndex ZeroSummaryNode,
 ZeroScopeKey -> Maybe ZeroSummaryNode)
(ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
HomeModuleNameProvidersMap
mg_mss :: ModuleGraph -> [ModuleGraphNode]
mg_graph :: ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph :: ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_zero_graph :: ModuleGraph
-> (ReachabilityIndex ZeroSummaryNode,
    ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_has_holes :: ModuleGraph -> Bool
mg_home_module_name_providers_map :: ModuleGraph -> HomeModuleNameProvidersMap
mg_mss :: [ModuleGraphNode]
mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_zero_graph :: (ReachabilityIndex ZeroSummaryNode,
 ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_has_holes :: Bool
mg_home_module_name_providers_map :: HomeModuleNameProvidersMap
..} = do
  mss' <- [ModuleGraphNode]
-> (ModuleGraphNode -> IO ModuleGraphNode) -> IO [ModuleGraphNode]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ModuleGraphNode]
mg_mss ((ModuleGraphNode -> IO ModuleGraphNode) -> IO [ModuleGraphNode])
-> (ModuleGraphNode -> IO ModuleGraphNode) -> IO [ModuleGraphNode]
forall a b. (a -> b) -> a -> b
$ \case
    InstantiationNode UnitId
uid InstantiatedUnit
iuid -> ModuleGraphNode -> IO ModuleGraphNode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleGraphNode -> IO ModuleGraphNode)
-> ModuleGraphNode -> IO ModuleGraphNode
forall a b. (a -> b) -> a -> b
$ UnitId -> InstantiatedUnit -> ModuleGraphNode
InstantiationNode UnitId
uid InstantiatedUnit
iuid
    LinkNode [NodeKey]
uid UnitId
nks -> ModuleGraphNode -> IO ModuleGraphNode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleGraphNode -> IO ModuleGraphNode)
-> ModuleGraphNode -> IO ModuleGraphNode
forall a b. (a -> b) -> a -> b
$ [NodeKey] -> UnitId -> ModuleGraphNode
LinkNode [NodeKey]
uid UnitId
nks
    ModuleNode [ModuleNodeEdge]
deps ModuleNodeInfo
ms  -> [ModuleNodeEdge] -> ModuleNodeInfo -> ModuleGraphNode
ModuleNode [ModuleNodeEdge]
deps (ModuleNodeInfo -> ModuleGraphNode)
-> IO ModuleNodeInfo -> IO ModuleGraphNode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ModuleNodeInfo -> IO ModuleNodeInfo
f ModuleNodeInfo
ms)
    UnitNode [UnitId]
deps UnitId
uid -> ModuleGraphNode -> IO ModuleGraphNode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ModuleGraphNode -> IO ModuleGraphNode)
-> ModuleGraphNode -> IO ModuleGraphNode
forall a b. (a -> b) -> a -> b
$ [UnitId] -> UnitId -> ModuleGraphNode
UnitNode [UnitId]
deps UnitId
uid
  return $ mg { mg_mss = mss' }


mgModSummaries :: ModuleGraph -> [ModSummary]
mgModSummaries :: ModuleGraph -> [ModSummary]
mgModSummaries ModuleGraph
mg = [ ModSummary
m | ModuleNode [ModuleNodeEdge]
_ (ModuleNodeCompile ModSummary
m) <- ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
mg ]

-- | Look up a non-boot ModSummary in the ModuleGraph.
--
-- Careful: Linear in the size of the module graph
-- MP: This should probably be level aware
mgLookupModule :: ModuleGraph -> Module -> Maybe ModuleNodeInfo
mgLookupModule :: ModuleGraph -> Module -> Maybe ModuleNodeInfo
mgLookupModule ModuleGraph{Bool
[ModuleGraphNode]
(ReachabilityIndex ZeroSummaryNode,
 ZeroScopeKey -> Maybe ZeroSummaryNode)
(ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
HomeModuleNameProvidersMap
mg_mss :: ModuleGraph -> [ModuleGraphNode]
mg_graph :: ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph :: ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_zero_graph :: ModuleGraph
-> (ReachabilityIndex ZeroSummaryNode,
    ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_has_holes :: ModuleGraph -> Bool
mg_home_module_name_providers_map :: ModuleGraph -> HomeModuleNameProvidersMap
mg_mss :: [ModuleGraphNode]
mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_zero_graph :: (ReachabilityIndex ZeroSummaryNode,
 ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_has_holes :: Bool
mg_home_module_name_providers_map :: HomeModuleNameProvidersMap
..} Module
m = [ModuleNodeInfo] -> Maybe ModuleNodeInfo
forall a. [a] -> Maybe a
listToMaybe ([ModuleNodeInfo] -> Maybe ModuleNodeInfo)
-> [ModuleNodeInfo] -> Maybe ModuleNodeInfo
forall a b. (a -> b) -> a -> b
$ (ModuleGraphNode -> Maybe ModuleNodeInfo)
-> [ModuleGraphNode] -> [ModuleNodeInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ModuleGraphNode -> Maybe ModuleNodeInfo
go [ModuleGraphNode]
mg_mss
  where
    go :: ModuleGraphNode -> Maybe ModuleNodeInfo
go (ModuleNode [ModuleNodeEdge]
_ ModuleNodeInfo
ms)
      | IsBootInterface
NotBoot <- ModuleNodeInfo -> IsBootInterface
isBootModuleNodeInfo ModuleNodeInfo
ms
      , ModuleNodeInfo -> Module
moduleNodeInfoModule ModuleNodeInfo
ms Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== Module
m
      = ModuleNodeInfo -> Maybe ModuleNodeInfo
forall a. a -> Maybe a
Just ModuleNodeInfo
ms
    go ModuleGraphNode
_ = Maybe ModuleNodeInfo
forall a. Maybe a
Nothing

-- | Lookup up a 'ModuleNameWithIsBoot' in the 'ModuleGraph'.
--
-- Multiple nodes in the 'ModuleGraph' can have the same 'ModuleName'
-- and 'IsBootInterface'.
--
-- Careful: Linear in the size of the module graph.
mgLookupModuleName :: ModuleGraph -> ModuleNameWithIsBoot -> [ModuleNodeInfo]
mgLookupModuleName :: ModuleGraph -> ModuleNameWithIsBoot -> [ModuleNodeInfo]
mgLookupModuleName ModuleGraph{Bool
[ModuleGraphNode]
(ReachabilityIndex ZeroSummaryNode,
 ZeroScopeKey -> Maybe ZeroSummaryNode)
(ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
HomeModuleNameProvidersMap
mg_mss :: ModuleGraph -> [ModuleGraphNode]
mg_graph :: ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph :: ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_zero_graph :: ModuleGraph
-> (ReachabilityIndex ZeroSummaryNode,
    ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_has_holes :: ModuleGraph -> Bool
mg_home_module_name_providers_map :: ModuleGraph -> HomeModuleNameProvidersMap
mg_mss :: [ModuleGraphNode]
mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_zero_graph :: (ReachabilityIndex ZeroSummaryNode,
 ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_has_holes :: Bool
mg_home_module_name_providers_map :: HomeModuleNameProvidersMap
..} ModuleNameWithIsBoot
m = (ModuleGraphNode -> Maybe ModuleNodeInfo)
-> [ModuleGraphNode] -> [ModuleNodeInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ModuleGraphNode -> Maybe ModuleNodeInfo
go [ModuleGraphNode]
mg_mss
  where
    go :: ModuleGraphNode -> Maybe ModuleNodeInfo
go (ModuleNode [ModuleNodeEdge]
_ ModuleNodeInfo
ms)
      | ModuleNodeInfo -> ModuleNameWithIsBoot
moduleNodeInfoMnwib ModuleNodeInfo
ms ModuleNameWithIsBoot -> ModuleNameWithIsBoot -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleNameWithIsBoot
m
      = ModuleNodeInfo -> Maybe ModuleNodeInfo
forall a. a -> Maybe a
Just ModuleNodeInfo
ms
    go ModuleGraphNode
_ = Maybe ModuleNodeInfo
forall a. Maybe a
Nothing

mgMember :: ModuleGraph -> NodeKey -> Bool
mgMember :: ModuleGraph -> NodeKey -> Bool
mgMember ModuleGraph
graph NodeKey
k = Maybe SummaryNode -> Bool
forall a. Maybe a -> Bool
isJust (Maybe SummaryNode -> Bool) -> Maybe SummaryNode -> Bool
forall a b. (a -> b) -> a -> b
$ (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
-> NodeKey -> Maybe SummaryNode
forall a b. (a, b) -> b
snd (ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_graph ModuleGraph
graph) NodeKey
k

-- | A function you should not need to use, or desire to use. Only used
-- in one place, `GHC.Iface.Load` to facilitate a misimplementation in Backpack.
mgHasHoles :: ModuleGraph -> Bool
mgHasHoles :: ModuleGraph -> Bool
mgHasHoles ModuleGraph{Bool
[ModuleGraphNode]
(ReachabilityIndex ZeroSummaryNode,
 ZeroScopeKey -> Maybe ZeroSummaryNode)
(ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
HomeModuleNameProvidersMap
mg_mss :: ModuleGraph -> [ModuleGraphNode]
mg_graph :: ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph :: ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_zero_graph :: ModuleGraph
-> (ReachabilityIndex ZeroSummaryNode,
    ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_has_holes :: ModuleGraph -> Bool
mg_home_module_name_providers_map :: ModuleGraph -> HomeModuleNameProvidersMap
mg_mss :: [ModuleGraphNode]
mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_zero_graph :: (ReachabilityIndex ZeroSummaryNode,
 ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_has_holes :: Bool
mg_home_module_name_providers_map :: HomeModuleNameProvidersMap
..} = Bool
mg_has_holes

--------------------------------------------------------------------------------
-- ** Reachability
--------------------------------------------------------------------------------

-- | Return all nodes reachable from the given 'NodeKey'.
--
-- @Nothing@ if the key couldn't be found in the graph.
mgReachable :: ModuleGraph -> NodeKey -> Maybe [ModuleGraphNode]
mgReachable :: ModuleGraph -> NodeKey -> Maybe [ModuleGraphNode]
mgReachable ModuleGraph
mg NodeKey
nk = (SummaryNode -> ModuleGraphNode)
-> [SummaryNode] -> [ModuleGraphNode]
forall a b. (a -> b) -> [a] -> [b]
map SummaryNode -> ModuleGraphNode
summaryNodeSummary ([SummaryNode] -> [ModuleGraphNode])
-> Maybe [SummaryNode] -> Maybe [ModuleGraphNode]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe [SummaryNode]
modules_below where
  (ReachabilityIndex SummaryNode
td_map, NodeKey -> Maybe SummaryNode
lookup_node) = ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_graph ModuleGraph
mg
  modules_below :: Maybe [SummaryNode]
modules_below =
    ReachabilityIndex SummaryNode -> SummaryNode -> [SummaryNode]
forall node. ReachabilityIndex node -> node -> [node]
allReachable ReachabilityIndex SummaryNode
td_map (SummaryNode -> [SummaryNode])
-> Maybe SummaryNode -> Maybe [SummaryNode]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeKey -> Maybe SummaryNode
lookup_node NodeKey
nk

-- | Things which are reachable if hs-boot files are ignored. Used by 'getLinkDeps'
mgReachableLoop :: ModuleGraph -> [NodeKey] -> [ModuleGraphNode]
mgReachableLoop :: ModuleGraph -> [NodeKey] -> [ModuleGraphNode]
mgReachableLoop ModuleGraph
mg [NodeKey]
nk = (SummaryNode -> ModuleGraphNode)
-> [SummaryNode] -> [ModuleGraphNode]
forall a b. (a -> b) -> [a] -> [b]
map SummaryNode -> ModuleGraphNode
summaryNodeSummary [SummaryNode]
modules_below where
  (ReachabilityIndex SummaryNode
td_map, NodeKey -> Maybe SummaryNode
lookup_node) = ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph ModuleGraph
mg
  modules_below :: [SummaryNode]
modules_below =
    ReachabilityIndex SummaryNode -> [SummaryNode] -> [SummaryNode]
forall node. ReachabilityIndex node -> [node] -> [node]
allReachableMany ReachabilityIndex SummaryNode
td_map ((NodeKey -> Maybe SummaryNode) -> [NodeKey] -> [SummaryNode]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NodeKey -> Maybe SummaryNode
lookup_node [NodeKey]
nk)


-- | @'mgQueryZero' g root target@ answers the question: can we reach @target@ from @root@
-- in the module graph @g@, only using normal (level 0) imports?
--
-- If the @target@ key is not reachable, there is no path.
-- The @root@ key not being in @g@ results in a panic.
mgQueryZero :: ModuleGraph
            -> ZeroScopeKey
            -> ZeroScopeKey
            -> Bool
mgQueryZero :: ModuleGraph -> ZeroScopeKey -> ZeroScopeKey -> Bool
mgQueryZero ModuleGraph
mg ZeroScopeKey
rootKey ZeroScopeKey
targetKey =
  case ZeroScopeKey -> Maybe ZeroSummaryNode
lookup_node ZeroScopeKey
targetKey of
    -- The module we are looking for may not be in the module graph at all,
    -- e.g. if a reference to it did not arise from an explicit import
    -- declaration (as in #26568).
    Maybe ZeroSummaryNode
Nothing -> Bool
False
    Just ZeroSummaryNode
ntarget -> ReachabilityIndex ZeroSummaryNode
-> ZeroSummaryNode -> ZeroSummaryNode -> Bool
forall node. ReachabilityIndex node -> node -> node -> Bool
isReachable ReachabilityIndex ZeroSummaryNode
td_map ZeroSummaryNode
nroot ZeroSummaryNode
ntarget
  where
  -- invariant: the root key has to exist in the graph
  nroot :: ZeroSummaryNode
nroot = Maybe ZeroSummaryNode -> ZeroSummaryNode
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ZeroSummaryNode -> ZeroSummaryNode)
-> Maybe ZeroSummaryNode -> ZeroSummaryNode
forall a b. (a -> b) -> a -> b
$ ZeroScopeKey -> Maybe ZeroSummaryNode
lookup_node ZeroScopeKey
rootKey
  (ReachabilityIndex ZeroSummaryNode
td_map, ZeroScopeKey -> Maybe ZeroSummaryNode
lookup_node) = ModuleGraph
-> (ReachabilityIndex ZeroSummaryNode,
    ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_zero_graph ModuleGraph
mg


-- | Reachability Query.
--
-- @mgQuery(g, a, b)@ asks:
-- Can we reach @b@ from @a@ in graph @g@?
--
-- Both @a@ and @b@ must be in @g@.
mgQuery :: ModuleGraph -- ^ @g@
        -> NodeKey -- ^ @a@
        -> NodeKey -- ^ @b@
        -> Bool -- ^ @b@ is reachable from @a@
mgQuery :: ModuleGraph -> NodeKey -> NodeKey -> Bool
mgQuery ModuleGraph
mg NodeKey
nka NodeKey
nkb = ReachabilityIndex SummaryNode -> SummaryNode -> SummaryNode -> Bool
forall node. ReachabilityIndex node -> node -> node -> Bool
isReachable ReachabilityIndex SummaryNode
td_map SummaryNode
na SummaryNode
nb where
  (ReachabilityIndex SummaryNode
td_map, NodeKey -> Maybe SummaryNode
lookup_node) = ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_graph ModuleGraph
mg
  na :: SummaryNode
na = Maybe SummaryNode -> SummaryNode
forall a. HasCallStack => Maybe a -> a
expectJust (Maybe SummaryNode -> SummaryNode)
-> Maybe SummaryNode -> SummaryNode
forall a b. (a -> b) -> a -> b
$ NodeKey -> Maybe SummaryNode
lookup_node NodeKey
nka
  nb :: SummaryNode
nb = Maybe SummaryNode -> SummaryNode
forall a. HasCallStack => Maybe a -> a
expectJust (Maybe SummaryNode -> SummaryNode)
-> Maybe SummaryNode -> SummaryNode
forall a b. (a -> b) -> a -> b
$ NodeKey -> Maybe SummaryNode
lookup_node NodeKey
nkb

-- | Many roots reachability Query.
--
-- @mgQuery(g, roots, b)@ asks:
-- Can we reach @b@ from any of the @roots@ in graph @g@?
--
-- Node @b@ must be in @g@.
mgQueryMany :: ModuleGraph -- ^ @g@
            -> [NodeKey] -- ^ @roots@
            -> NodeKey -- ^ @b@
            -> Bool -- ^ @b@ is reachable from @roots@
mgQueryMany :: ModuleGraph -> [NodeKey] -> NodeKey -> Bool
mgQueryMany ModuleGraph
mg [NodeKey]
roots NodeKey
nkb = ReachabilityIndex SummaryNode
-> [SummaryNode] -> SummaryNode -> Bool
forall node. ReachabilityIndex node -> [node] -> node -> Bool
isReachableMany ReachabilityIndex SummaryNode
td_map [SummaryNode]
nroots SummaryNode
nb where
  (ReachabilityIndex SummaryNode
td_map, NodeKey -> Maybe SummaryNode
lookup_node) = ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_graph ModuleGraph
mg
  nroots :: [SummaryNode]
nroots = (NodeKey -> Maybe SummaryNode) -> [NodeKey] -> [SummaryNode]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NodeKey -> Maybe SummaryNode
lookup_node [NodeKey]
roots
  nb :: SummaryNode
nb = Maybe SummaryNode -> SummaryNode
forall a. HasCallStack => Maybe a -> a
expectJust (Maybe SummaryNode -> SummaryNode)
-> Maybe SummaryNode -> SummaryNode
forall a b. (a -> b) -> a -> b
$ NodeKey -> Maybe SummaryNode
lookup_node NodeKey
nkb

-- | Many roots reachability Query.
--
-- @mgQuery(g, roots, b)@ asks:
-- Can we reach @b@ from any of the @roots@ in graph @g@, only using normal (level 0) imports?
--
-- Node @b@ must be in @g@.
mgQueryManyZero :: ModuleGraph -- ^ @g@
            -> [ZeroScopeKey] -- ^ @roots@
            -> ZeroScopeKey -- ^ @b@
            -> Bool -- ^ @b@ is reachable from @roots@
mgQueryManyZero :: ModuleGraph -> [ZeroScopeKey] -> ZeroScopeKey -> Bool
mgQueryManyZero ModuleGraph
mg [ZeroScopeKey]
roots ZeroScopeKey
nkb = ReachabilityIndex ZeroSummaryNode
-> [ZeroSummaryNode] -> ZeroSummaryNode -> Bool
forall node. ReachabilityIndex node -> [node] -> node -> Bool
isReachableMany ReachabilityIndex ZeroSummaryNode
td_map [ZeroSummaryNode]
nroots ZeroSummaryNode
nb where
  (ReachabilityIndex ZeroSummaryNode
td_map, ZeroScopeKey -> Maybe ZeroSummaryNode
lookup_node) = ModuleGraph
-> (ReachabilityIndex ZeroSummaryNode,
    ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_zero_graph ModuleGraph
mg
  nroots :: [ZeroSummaryNode]
nroots = (ZeroScopeKey -> Maybe ZeroSummaryNode)
-> [ZeroScopeKey] -> [ZeroSummaryNode]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ZeroScopeKey -> Maybe ZeroSummaryNode
lookup_node [ZeroScopeKey]
roots
  nb :: ZeroSummaryNode
nb = Maybe ZeroSummaryNode -> ZeroSummaryNode
forall a. HasCallStack => Maybe a -> a
expectJust (Maybe ZeroSummaryNode -> ZeroSummaryNode)
-> Maybe ZeroSummaryNode -> ZeroSummaryNode
forall a b. (a -> b) -> a -> b
$ ZeroScopeKey -> Maybe ZeroSummaryNode
lookup_node (String -> SDoc -> ZeroScopeKey -> ZeroScopeKey
forall a. String -> SDoc -> a -> a
pprTrace String
"mg" (ZeroScopeKey -> SDoc
forall a. Outputable a => a -> SDoc
ppr ZeroScopeKey
nkb) ZeroScopeKey
nkb)

--------------------------------------------------------------------------------
-- ** Other operations (read haddocks on export list)
--------------------------------------------------------------------------------

mgModSummaries' :: ModuleGraph -> [ModuleGraphNode]
mgModSummaries' :: ModuleGraph -> [ModuleGraphNode]
mgModSummaries' = ModuleGraph -> [ModuleGraphNode]
mg_mss

-- | Turn a list of graph nodes into an efficient queriable graph.
-- The first boolean parameter indicates whether nodes corresponding to hs-boot files
-- should be collapsed into their relevant hs nodes.
moduleGraphNodes :: Bool
  -> [ModuleGraphNode]
  -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes :: Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
drop_hs_boot_nodes [ModuleGraphNode]
summaries =
  ([SummaryNode] -> Graph SummaryNode
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [SummaryNode]
nodes, NodeKey -> Maybe SummaryNode
lookup_node)
  where
    -- Map from module to extra boot summary dependencies which need to be merged in
    (Map Module [NodeKey]
boot_summaries, [SummaryNode]
nodes) = ([(Module, [NodeKey])] -> Map Module [NodeKey])
-> ([SummaryNode] -> [SummaryNode])
-> ([(Module, [NodeKey])], [SummaryNode])
-> (Map Module [NodeKey], [SummaryNode])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap [(Module, [NodeKey])] -> Map Module [NodeKey]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [SummaryNode] -> [SummaryNode]
forall a. a -> a
id (([(Module, [NodeKey])], [SummaryNode])
 -> (Map Module [NodeKey], [SummaryNode]))
-> ([(Module, [NodeKey])], [SummaryNode])
-> (Map Module [NodeKey], [SummaryNode])
forall a b. (a -> b) -> a -> b
$ ((ModuleGraphNode, Int) -> Either (Module, [NodeKey]) SummaryNode)
-> [(ModuleGraphNode, Int)]
-> ([(Module, [NodeKey])], [SummaryNode])
forall a b c. (a -> Either b c) -> [a] -> ([b], [c])
partitionWith (ModuleGraphNode, Int) -> Either (Module, [NodeKey]) SummaryNode
go [(ModuleGraphNode, Int)]
numbered_summaries

      where
        go :: (ModuleGraphNode, Int) -> Either (Module, [NodeKey]) SummaryNode
go (ModuleGraphNode
s, Int
key) =
          case ModuleGraphNode
s of
                ModuleNode [ModuleNodeEdge]
__deps ModuleNodeInfo
ms | ModuleNodeInfo -> IsBootInterface
isBootModuleNodeInfo ModuleNodeInfo
ms IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
IsBoot, Bool
drop_hs_boot_nodes
                  -- Using nodeDependencies here converts dependencies on other
                  -- boot files to dependencies on dependencies on non-boot files.
                  -> (Module, [NodeKey]) -> Either (Module, [NodeKey]) SummaryNode
forall a b. a -> Either a b
Left (ModuleNodeInfo -> Module
moduleNodeInfoModule ModuleNodeInfo
ms, Bool -> ModuleGraphNode -> [NodeKey]
mgNodeDependencies Bool
drop_hs_boot_nodes ModuleGraphNode
s)
                ModuleGraphNode
_ -> Either (Module, [NodeKey]) SummaryNode
normal_case
          where
           normal_case :: Either (Module, [NodeKey]) SummaryNode
normal_case =
              let lkup_key :: Maybe Module
lkup_key = ModuleNodeInfo -> Module
moduleNodeInfoModule (ModuleNodeInfo -> Module) -> Maybe ModuleNodeInfo -> Maybe Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleGraphNode -> Maybe ModuleNodeInfo
mgNodeIsModule ModuleGraphNode
s
                  extra :: Maybe [NodeKey]
extra = (Maybe Module
lkup_key Maybe Module -> (Module -> Maybe [NodeKey]) -> Maybe [NodeKey]
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Module
key -> Module -> Map Module [NodeKey] -> Maybe [NodeKey]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Module
key Map Module [NodeKey]
boot_summaries)

              in SummaryNode -> Either (Module, [NodeKey]) SummaryNode
forall a b. b -> Either a b
Right (SummaryNode -> Either (Module, [NodeKey]) SummaryNode)
-> SummaryNode -> Either (Module, [NodeKey]) SummaryNode
forall a b. (a -> b) -> a -> b
$ ModuleGraphNode -> Int -> [Int] -> SummaryNode
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode ModuleGraphNode
s Int
key ([Int] -> SummaryNode) -> [Int] -> SummaryNode
forall a b. (a -> b) -> a -> b
$ [NodeKey] -> [Int]
out_edge_keys ([NodeKey] -> [Int]) -> [NodeKey] -> [Int]
forall a b. (a -> b) -> a -> b
$
                      ([NodeKey] -> Maybe [NodeKey] -> [NodeKey]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [NodeKey]
extra
                        [NodeKey] -> [NodeKey] -> [NodeKey]
forall a. [a] -> [a] -> [a]
++ Bool -> ModuleGraphNode -> [NodeKey]
mgNodeDependencies Bool
drop_hs_boot_nodes ModuleGraphNode
s)

    numbered_summaries :: [(ModuleGraphNode, Int)]
numbered_summaries = [ModuleGraphNode] -> [Int] -> [(ModuleGraphNode, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [ModuleGraphNode]
summaries [Int
1..]

    lookup_node :: NodeKey -> Maybe SummaryNode
    lookup_node :: NodeKey -> Maybe SummaryNode
lookup_node NodeKey
key = NodeKey -> Map NodeKey SummaryNode -> Maybe SummaryNode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NodeKey
key (NodeMap SummaryNode -> Map NodeKey SummaryNode
forall a. NodeMap a -> Map NodeKey a
unNodeMap NodeMap SummaryNode
node_map)

    lookup_key :: NodeKey -> Maybe Int
    lookup_key :: NodeKey -> Maybe Int
lookup_key = (SummaryNode -> Int) -> Maybe SummaryNode -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SummaryNode -> Int
summaryNodeKey (Maybe SummaryNode -> Maybe Int)
-> (NodeKey -> Maybe SummaryNode) -> NodeKey -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NodeKey -> Maybe SummaryNode
lookup_node

    node_map :: NodeMap SummaryNode
    node_map :: NodeMap SummaryNode
node_map = Map NodeKey SummaryNode -> NodeMap SummaryNode
forall a. Map NodeKey a -> NodeMap a
NodeMap (Map NodeKey SummaryNode -> NodeMap SummaryNode)
-> Map NodeKey SummaryNode -> NodeMap SummaryNode
forall a b. (a -> b) -> a -> b
$
      [(NodeKey, SummaryNode)] -> Map NodeKey SummaryNode
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
s, SummaryNode
node)
                   | SummaryNode
node <- [SummaryNode]
nodes
                   , let s :: ModuleGraphNode
s = SummaryNode -> ModuleGraphNode
summaryNodeSummary SummaryNode
node
                   ]

    out_edge_keys :: [NodeKey] -> [Int]
    out_edge_keys :: [NodeKey] -> [Int]
out_edge_keys = (NodeKey -> Maybe Int) -> [NodeKey] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe NodeKey -> Maybe Int
lookup_key
        -- If we want keep_hi_boot_nodes, then we do lookup_key with
        -- IsBoot; else False


-- | This function returns all the modules belonging to the home-unit that can
-- be reached by following the given dependencies. Additionally, if both the
-- boot module and the non-boot module can be reached, it only returns the
-- non-boot one.
moduleGraphModulesBelow :: ModuleGraph -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
moduleGraphModulesBelow :: ModuleGraph
-> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid
moduleGraphModulesBelow ModuleGraph
mg UnitId
uid ModuleNameWithIsBoot
mn = [ModNodeKeyWithUid] -> Set ModNodeKeyWithUid
filtered_mods [ ModNodeKeyWithUid
mn |  NodeKey_Module ModNodeKeyWithUid
mn <- [NodeKey]
modules_below]
  where
    modules_below :: [NodeKey]
modules_below = [NodeKey]
-> ([ModuleGraphNode] -> [NodeKey])
-> Maybe [ModuleGraphNode]
-> [NodeKey]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((ModuleGraphNode -> NodeKey) -> [ModuleGraphNode] -> [NodeKey]
forall a b. (a -> b) -> [a] -> [b]
map ModuleGraphNode -> NodeKey
mkNodeKey) (ModuleGraph -> NodeKey -> Maybe [ModuleGraphNode]
mgReachable ModuleGraph
mg (ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid ModuleNameWithIsBoot
mn UnitId
uid)))
    filtered_mods :: [ModNodeKeyWithUid] -> Set ModNodeKeyWithUid
filtered_mods = [ModNodeKeyWithUid] -> Set ModNodeKeyWithUid
forall a. [a] -> Set a
Set.fromDistinctAscList ([ModNodeKeyWithUid] -> Set ModNodeKeyWithUid)
-> ([ModNodeKeyWithUid] -> [ModNodeKeyWithUid])
-> [ModNodeKeyWithUid]
-> Set ModNodeKeyWithUid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModNodeKeyWithUid] -> [ModNodeKeyWithUid]
filter_mods ([ModNodeKeyWithUid] -> [ModNodeKeyWithUid])
-> ([ModNodeKeyWithUid] -> [ModNodeKeyWithUid])
-> [ModNodeKeyWithUid]
-> [ModNodeKeyWithUid]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModNodeKeyWithUid] -> [ModNodeKeyWithUid]
forall a. Ord a => [a] -> [a]
sort

    -- IsBoot and NotBoot modules are necessarily consecutive in the sorted list
    -- (cf Ord instance of GenWithIsBoot). Hence we only have to perform a
    -- linear sweep with a window of size 2 to remove boot modules for which we
    -- have the corresponding non-boot.
    filter_mods :: [ModNodeKeyWithUid] -> [ModNodeKeyWithUid]
filter_mods = \case
      (r1 :: ModNodeKeyWithUid
r1@(ModNodeKeyWithUid (GWIB ModuleName
m1 IsBootInterface
b1) UnitId
uid1) : r2 :: ModNodeKeyWithUid
r2@(ModNodeKeyWithUid (GWIB ModuleName
m2 IsBootInterface
_) UnitId
uid2): [ModNodeKeyWithUid]
rs)
        | ModuleName
m1 ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== ModuleName
m2  Bool -> Bool -> Bool
&& UnitId
uid1 UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
uid2 ->
                       let !r' :: ModNodeKeyWithUid
r' = case IsBootInterface
b1 of
                                  IsBootInterface
NotBoot -> ModNodeKeyWithUid
r1
                                  IsBootInterface
IsBoot  -> ModNodeKeyWithUid
r2
                       in ModNodeKeyWithUid
r' ModNodeKeyWithUid -> [ModNodeKeyWithUid] -> [ModNodeKeyWithUid]
forall a. a -> [a] -> [a]
: [ModNodeKeyWithUid] -> [ModNodeKeyWithUid]
filter_mods [ModNodeKeyWithUid]
rs
        | Bool
otherwise -> ModNodeKeyWithUid
r1 ModNodeKeyWithUid -> [ModNodeKeyWithUid] -> [ModNodeKeyWithUid]
forall a. a -> [a] -> [a]
: [ModNodeKeyWithUid] -> [ModNodeKeyWithUid]
filter_mods (ModNodeKeyWithUid
r2ModNodeKeyWithUid -> [ModNodeKeyWithUid] -> [ModNodeKeyWithUid]
forall a. a -> [a] -> [a]
:[ModNodeKeyWithUid]
rs)
      [ModNodeKeyWithUid]
rs -> [ModNodeKeyWithUid]
rs

-- | This function filters out all the instantiation nodes from each SCC of a
-- topological sort. Use this with care, as the resulting "strongly connected components"
-- may not really be strongly connected in a direct way, as instantiations have been
-- removed. It would probably be best to eliminate uses of this function where possible.
filterToposortToModules
  :: [SCC ModuleGraphNode] -> [SCC ModuleNodeInfo]
filterToposortToModules :: [SCC ModuleGraphNode] -> [SCC ModuleNodeInfo]
filterToposortToModules = (SCC ModuleGraphNode -> Maybe (SCC ModuleNodeInfo))
-> [SCC ModuleGraphNode] -> [SCC ModuleNodeInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((SCC ModuleGraphNode -> Maybe (SCC ModuleNodeInfo))
 -> [SCC ModuleGraphNode] -> [SCC ModuleNodeInfo])
-> (SCC ModuleGraphNode -> Maybe (SCC ModuleNodeInfo))
-> [SCC ModuleGraphNode]
-> [SCC ModuleNodeInfo]
forall a b. (a -> b) -> a -> b
$ (ModuleGraphNode -> Maybe ModuleNodeInfo)
-> SCC ModuleGraphNode -> Maybe (SCC ModuleNodeInfo)
forall a b. (a -> Maybe b) -> SCC a -> Maybe (SCC b)
mapMaybeSCC ((ModuleGraphNode -> Maybe ModuleNodeInfo)
 -> SCC ModuleGraphNode -> Maybe (SCC ModuleNodeInfo))
-> (ModuleGraphNode -> Maybe ModuleNodeInfo)
-> SCC ModuleGraphNode
-> Maybe (SCC ModuleNodeInfo)
forall a b. (a -> b) -> a -> b
$ \case
  ModuleNode [ModuleNodeEdge]
_deps ModuleNodeInfo
node -> ModuleNodeInfo -> Maybe ModuleNodeInfo
forall a. a -> Maybe a
Just ModuleNodeInfo
node
  ModuleGraphNode
_ -> Maybe ModuleNodeInfo
forall a. Maybe a
Nothing
  where
    -- This higher order function is somewhat bogus,
    -- as the definition of "strongly connected component"
    -- is not necessarily respected.
    mapMaybeSCC :: (a -> Maybe b) -> SCC a -> Maybe (SCC b)
    mapMaybeSCC :: forall a b. (a -> Maybe b) -> SCC a -> Maybe (SCC b)
mapMaybeSCC a -> Maybe b
f = \case
      AcyclicSCC a
a -> b -> SCC b
forall vertex. vertex -> SCC vertex
AcyclicSCC (b -> SCC b) -> Maybe b -> Maybe (SCC b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe b
f a
a
      CyclicSCC [a]
as -> case (a -> Maybe b) -> [a] -> [b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe a -> Maybe b
f [a]
as of
        [] -> Maybe (SCC b)
forall a. Maybe a
Nothing
        [b
a] -> SCC b -> Maybe (SCC b)
forall a. a -> Maybe a
Just (SCC b -> Maybe (SCC b)) -> SCC b -> Maybe (SCC b)
forall a b. (a -> b) -> a -> b
$ b -> SCC b
forall vertex. vertex -> SCC vertex
AcyclicSCC b
a
        [b]
as -> SCC b -> Maybe (SCC b)
forall a. a -> Maybe a
Just (SCC b -> Maybe (SCC b)) -> SCC b -> Maybe (SCC b)
forall a b. (a -> b) -> a -> b
$ [b] -> SCC b
forall vertex. [vertex] -> SCC vertex
CyclicSCC [b]
as

--------------------------------------------------------------------------------
-- * Keys into ModuleGraph
--------------------------------------------------------------------------------

data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit
             | NodeKey_Module {-# UNPACK #-} !ModNodeKeyWithUid
             | NodeKey_Link !UnitId
             | NodeKey_ExternalUnit !UnitId
  deriving (NodeKey -> NodeKey -> Bool
(NodeKey -> NodeKey -> Bool)
-> (NodeKey -> NodeKey -> Bool) -> Eq NodeKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NodeKey -> NodeKey -> Bool
== :: NodeKey -> NodeKey -> Bool
$c/= :: NodeKey -> NodeKey -> Bool
/= :: NodeKey -> NodeKey -> Bool
Eq, Eq NodeKey
Eq NodeKey =>
(NodeKey -> NodeKey -> Ordering)
-> (NodeKey -> NodeKey -> Bool)
-> (NodeKey -> NodeKey -> Bool)
-> (NodeKey -> NodeKey -> Bool)
-> (NodeKey -> NodeKey -> Bool)
-> (NodeKey -> NodeKey -> NodeKey)
-> (NodeKey -> NodeKey -> NodeKey)
-> Ord NodeKey
NodeKey -> NodeKey -> Bool
NodeKey -> NodeKey -> Ordering
NodeKey -> NodeKey -> NodeKey
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NodeKey -> NodeKey -> Ordering
compare :: NodeKey -> NodeKey -> Ordering
$c< :: NodeKey -> NodeKey -> Bool
< :: NodeKey -> NodeKey -> Bool
$c<= :: NodeKey -> NodeKey -> Bool
<= :: NodeKey -> NodeKey -> Bool
$c> :: NodeKey -> NodeKey -> Bool
> :: NodeKey -> NodeKey -> Bool
$c>= :: NodeKey -> NodeKey -> Bool
>= :: NodeKey -> NodeKey -> Bool
$cmax :: NodeKey -> NodeKey -> NodeKey
max :: NodeKey -> NodeKey -> NodeKey
$cmin :: NodeKey -> NodeKey -> NodeKey
min :: NodeKey -> NodeKey -> NodeKey
Ord)

instance Outputable NodeKey where
  ppr :: NodeKey -> SDoc
ppr (NodeKey_Unit InstantiatedUnit
iu)   = InstantiatedUnit -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
iu
  ppr (NodeKey_Module ModNodeKeyWithUid
mk) = ModNodeKeyWithUid -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModNodeKeyWithUid
mk
  ppr (NodeKey_Link UnitId
uid)  = UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
uid
  ppr (NodeKey_ExternalUnit UnitId
uid) = UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
uid

mkNodeKey :: ModuleGraphNode -> NodeKey
mkNodeKey :: ModuleGraphNode -> NodeKey
mkNodeKey = \case
  InstantiationNode UnitId
_ InstantiatedUnit
iu -> InstantiatedUnit -> NodeKey
NodeKey_Unit InstantiatedUnit
iu
  ModuleNode [ModuleNodeEdge]
_ ModuleNodeInfo
x -> ModNodeKeyWithUid -> NodeKey
NodeKey_Module (ModNodeKeyWithUid -> NodeKey) -> ModNodeKeyWithUid -> NodeKey
forall a b. (a -> b) -> a -> b
$ ModuleNodeInfo -> ModNodeKeyWithUid
mnKey ModuleNodeInfo
x
  LinkNode [NodeKey]
_ UnitId
uid   -> UnitId -> NodeKey
NodeKey_Link UnitId
uid
  UnitNode [UnitId]
_ UnitId
uid -> UnitId -> NodeKey
NodeKey_ExternalUnit UnitId
uid

nodeKeyUnitId :: NodeKey -> UnitId
nodeKeyUnitId :: NodeKey -> UnitId
nodeKeyUnitId (NodeKey_Unit InstantiatedUnit
iu)   = InstantiatedUnit -> UnitId
forall unit. GenInstantiatedUnit unit -> unit
instUnitInstanceOf InstantiatedUnit
iu
nodeKeyUnitId (NodeKey_Module ModNodeKeyWithUid
mk) = ModNodeKeyWithUid -> UnitId
mnkUnitId ModNodeKeyWithUid
mk
nodeKeyUnitId (NodeKey_Link UnitId
uid)  = UnitId
uid
nodeKeyUnitId (NodeKey_ExternalUnit UnitId
uid) = UnitId
uid

nodeKeyModName :: NodeKey -> Maybe ModuleName
nodeKeyModName :: NodeKey -> Maybe ModuleName
nodeKeyModName (NodeKey_Module ModNodeKeyWithUid
mk) = ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just (ModuleNameWithIsBoot -> ModuleName
forall mod. GenWithIsBoot mod -> mod
gwib_mod (ModuleNameWithIsBoot -> ModuleName)
-> ModuleNameWithIsBoot -> ModuleName
forall a b. (a -> b) -> a -> b
$ ModNodeKeyWithUid -> ModuleNameWithIsBoot
mnkModuleName ModNodeKeyWithUid
mk)
nodeKeyModName NodeKey
_ = Maybe ModuleName
forall a. Maybe a
Nothing

msKey :: ModSummary -> ModNodeKeyWithUid
msKey :: ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms = ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModSummary -> ModuleNameWithIsBoot
ms_mnwib ModSummary
ms) (ModSummary -> UnitId
ms_unitid ModSummary
ms)

mnKey :: ModuleNodeInfo -> ModNodeKeyWithUid
mnKey :: ModuleNodeInfo -> ModNodeKeyWithUid
mnKey (ModuleNodeFixed ModNodeKeyWithUid
key ModLocation
_) = ModNodeKeyWithUid
key
mnKey (ModuleNodeCompile ModSummary
ms) = ModSummary -> ModNodeKeyWithUid
msKey ModSummary
ms

miKey :: ModIface -> ModNodeKeyWithUid
miKey :: ModIface -> ModNodeKeyWithUid
miKey ModIface
hmi = ModuleNameWithIsBoot -> UnitId -> ModNodeKeyWithUid
ModNodeKeyWithUid (ModIface -> ModuleNameWithIsBoot
mi_mnwib ModIface
hmi) ((GenUnit UnitId -> UnitId
toUnitId (GenUnit UnitId -> UnitId) -> GenUnit UnitId -> UnitId
forall a b. (a -> b) -> a -> b
$ Module -> GenUnit UnitId
forall unit. GenModule unit -> unit
moduleUnit (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
hmi)))

type ModNodeKey = ModuleNameWithIsBoot

--------------------------------------------------------------------------------
-- ** Internal node representation (exposed)
--------------------------------------------------------------------------------

type SummaryNode = Node Int ModuleGraphNode

summaryNodeKey :: SummaryNode -> Int
summaryNodeKey :: SummaryNode -> Int
summaryNodeKey = SummaryNode -> Int
forall key payload. Node key payload -> key
node_key

summaryNodeSummary :: SummaryNode -> ModuleGraphNode
summaryNodeSummary :: SummaryNode -> ModuleGraphNode
summaryNodeSummary = SummaryNode -> ModuleGraphNode
forall key payload. Node key payload -> payload
node_payload

--------------------------------------------------------------------------------
-- * Misc utilities
--------------------------------------------------------------------------------

showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc
showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc
showModMsg DynFlags
dflags Bool
_ (LinkNode {}) =
      let staticLink :: Bool
staticLink = case DynFlags -> GhcLink
ghcLink DynFlags
dflags of
                          GhcLink
LinkStaticLib -> Bool
True
                          GhcLink
_ -> Bool
False

          platform :: Platform
platform  = DynFlags -> Platform
targetPlatform DynFlags
dflags
          arch_os :: ArchOS
arch_os   = Platform -> ArchOS
platformArchOS Platform
platform
          exe_file :: String
exe_file  = ArchOS -> Bool -> Maybe String -> String
exeFileName ArchOS
arch_os Bool
staticLink (DynFlags -> Maybe String
outputFile_ DynFlags
dflags)
      in String -> SDoc
forall doc. IsLine doc => String -> doc
text String
exe_file
showModMsg DynFlags
_ Bool
_ (UnitNode [UnitId]
_deps UnitId
uid) = UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
uid
showModMsg DynFlags
_ Bool
_ (InstantiationNode UnitId
_uid InstantiatedUnit
indef_unit) =
  UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnitId -> SDoc) -> UnitId -> SDoc
forall a b. (a -> b) -> a -> b
$ InstantiatedUnit -> UnitId
forall unit. GenInstantiatedUnit unit -> unit
instUnitInstanceOf InstantiatedUnit
indef_unit
showModMsg DynFlags
dflags Bool
recomp (ModuleNode [ModuleNodeEdge]
_ ModuleNodeInfo
mni) =
  if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_HideSourcePaths DynFlags
dflags
      then String -> SDoc
forall doc. IsLine doc => String -> doc
text String
mod_str
      else [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
         [ String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
mod_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
mod_str)) Char
' ')
         , Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'('
         , String -> SDoc
forall doc. IsLine doc => String -> doc
text (ModuleNodeInfo -> String
moduleNodeInfoSource ModuleNodeInfo
mni) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
','
         , DynFlags -> Bool -> ModuleNodeInfo -> SDoc
moduleNodeInfoExtraMessage DynFlags
dflags Bool
recomp ModuleNodeInfo
mni, Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
')' ]
  where
    mod_str :: String
mod_str  = ModuleName -> String
moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModuleNodeInfo -> Module
moduleNodeInfoModule ModuleNodeInfo
mni)) String -> String -> String
forall a. [a] -> [a] -> [a]
++
               ModuleNodeInfo -> String
moduleNodeInfoBootString ModuleNodeInfo
mni

-- | Extra information about a 'ModuleNodeInfo' to display in the progress message.
moduleNodeInfoExtraMessage :: DynFlags -> Bool -> ModuleNodeInfo -> SDoc
moduleNodeInfoExtraMessage :: DynFlags -> Bool -> ModuleNodeInfo -> SDoc
moduleNodeInfoExtraMessage DynFlags
dflags Bool
recomp (ModuleNodeCompile ModSummary
mod_summary) =
    let dyn_file :: String
dyn_file = String -> String
normalise (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ModSummary -> String
msDynObjFilePath ModSummary
mod_summary
        obj_file :: String
obj_file = String -> String
normalise (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ModSummary -> String
msObjFilePath ModSummary
mod_summary
        files :: NonEmpty String
files    = String
obj_file
                   String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| [ String
dyn_file | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildDynamicToo DynFlags
dflags ]
                   [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"interpreted" | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ByteCodeAndObjectCode DynFlags
dflags ]
    in case Backend -> Bool -> Maybe String
backendSpecialModuleSource (DynFlags -> Backend
backend DynFlags
dflags) Bool
recomp of
              Just String
special -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
special
              Maybe String
Nothing -> (SDoc -> SDoc -> SDoc) -> NonEmpty SDoc -> SDoc
forall (t :: * -> *) a. Foldable1 t => (a -> a -> a) -> t a -> a
foldr1 (\SDoc
ofile SDoc
rest -> SDoc
ofile SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
comma SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
rest) ((String -> SDoc) -> NonEmpty String -> NonEmpty SDoc
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map String -> SDoc
forall doc. IsLine doc => String -> doc
text NonEmpty String
files)
moduleNodeInfoExtraMessage DynFlags
_ Bool
_ (ModuleNodeFixed {}) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"fixed"


-- | The source location of the module node to show to the user.
moduleNodeInfoSource :: ModuleNodeInfo -> FilePath
moduleNodeInfoSource :: ModuleNodeInfo -> String
moduleNodeInfoSource (ModuleNodeCompile ModSummary
ms) = String -> String
normalise (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ModSummary -> String
msHsFilePath ModSummary
ms
moduleNodeInfoSource (ModuleNodeFixed ModNodeKeyWithUid
_ ModLocation
loc) = String -> String
normalise (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ModLocation -> String
ml_hi_file ModLocation
loc

-- | The extra info about a module [boot] or [sig] to display.
moduleNodeInfoBootString :: ModuleNodeInfo -> String
moduleNodeInfoBootString :: ModuleNodeInfo -> String
moduleNodeInfoBootString (ModuleNodeCompile ModSummary
ms) = HscSource -> String
hscSourceString (ModSummary -> HscSource
ms_hsc_src ModSummary
ms)
moduleNodeInfoBootString mn :: ModuleNodeInfo
mn@(ModuleNodeFixed {}) =
  HscSource -> String
hscSourceString (case ModuleNodeInfo -> IsBootInterface
isBootModuleNodeInfo ModuleNodeInfo
mn of
                      IsBootInterface
IsBoot -> HscSource
HsBootFile
                      IsBootInterface
NotBoot -> HscSource
HsSrcFile)

--------------------------------------------------------------------------------
-- * Internal methods for module graph
--
-- These are *really* meant to be internal!
-- Don't expose them without careful consideration about the invariants
-- described in the export list haddocks.
--------------------------------------------------------------------------------

newtype NodeMap a = NodeMap { forall a. NodeMap a -> Map NodeKey a
unNodeMap :: Map NodeKey a }
  deriving ((forall a b. (a -> b) -> NodeMap a -> NodeMap b)
-> (forall a b. a -> NodeMap b -> NodeMap a) -> Functor NodeMap
forall a b. a -> NodeMap b -> NodeMap a
forall a b. (a -> b) -> NodeMap a -> NodeMap b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> NodeMap a -> NodeMap b
fmap :: forall a b. (a -> b) -> NodeMap a -> NodeMap b
$c<$ :: forall a b. a -> NodeMap b -> NodeMap a
<$ :: forall a b. a -> NodeMap b -> NodeMap a
Functor, Functor NodeMap
Foldable NodeMap
(Functor NodeMap, Foldable NodeMap) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> NodeMap a -> f (NodeMap b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    NodeMap (f a) -> f (NodeMap a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> NodeMap a -> m (NodeMap b))
-> (forall (m :: * -> *) a.
    Monad m =>
    NodeMap (m a) -> m (NodeMap a))
-> Traversable NodeMap
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => NodeMap (m a) -> m (NodeMap a)
forall (f :: * -> *) a.
Applicative f =>
NodeMap (f a) -> f (NodeMap a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NodeMap a -> m (NodeMap b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NodeMap a -> f (NodeMap b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NodeMap a -> f (NodeMap b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NodeMap a -> f (NodeMap b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
NodeMap (f a) -> f (NodeMap a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
NodeMap (f a) -> f (NodeMap a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NodeMap a -> m (NodeMap b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NodeMap a -> m (NodeMap b)
$csequence :: forall (m :: * -> *) a. Monad m => NodeMap (m a) -> m (NodeMap a)
sequence :: forall (m :: * -> *) a. Monad m => NodeMap (m a) -> m (NodeMap a)
Traversable, (forall m. Monoid m => NodeMap m -> m)
-> (forall m a. Monoid m => (a -> m) -> NodeMap a -> m)
-> (forall m a. Monoid m => (a -> m) -> NodeMap a -> m)
-> (forall a b. (a -> b -> b) -> b -> NodeMap a -> b)
-> (forall a b. (a -> b -> b) -> b -> NodeMap a -> b)
-> (forall b a. (b -> a -> b) -> b -> NodeMap a -> b)
-> (forall b a. (b -> a -> b) -> b -> NodeMap a -> b)
-> (forall a. (a -> a -> a) -> NodeMap a -> a)
-> (forall a. (a -> a -> a) -> NodeMap a -> a)
-> (forall a. NodeMap a -> [a])
-> (forall a. NodeMap a -> Bool)
-> (forall a. NodeMap a -> Int)
-> (forall a. Eq a => a -> NodeMap a -> Bool)
-> (forall a. Ord a => NodeMap a -> a)
-> (forall a. Ord a => NodeMap a -> a)
-> (forall a. Num a => NodeMap a -> a)
-> (forall a. Num a => NodeMap a -> a)
-> Foldable NodeMap
forall a. Eq a => a -> NodeMap a -> Bool
forall a. Num a => NodeMap a -> a
forall a. Ord a => NodeMap a -> a
forall m. Monoid m => NodeMap m -> m
forall a. NodeMap a -> Bool
forall a. NodeMap a -> Int
forall a. NodeMap a -> [a]
forall a. (a -> a -> a) -> NodeMap a -> a
forall m a. Monoid m => (a -> m) -> NodeMap a -> m
forall b a. (b -> a -> b) -> b -> NodeMap a -> b
forall a b. (a -> b -> b) -> b -> NodeMap a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => NodeMap m -> m
fold :: forall m. Monoid m => NodeMap m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> NodeMap a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> NodeMap a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> NodeMap a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> NodeMap a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> NodeMap a -> b
foldr :: forall a b. (a -> b -> b) -> b -> NodeMap a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> NodeMap a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> NodeMap a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> NodeMap a -> b
foldl :: forall b a. (b -> a -> b) -> b -> NodeMap a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> NodeMap a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> NodeMap a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> NodeMap a -> a
foldr1 :: forall a. (a -> a -> a) -> NodeMap a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> NodeMap a -> a
foldl1 :: forall a. (a -> a -> a) -> NodeMap a -> a
$ctoList :: forall a. NodeMap a -> [a]
toList :: forall a. NodeMap a -> [a]
$cnull :: forall a. NodeMap a -> Bool
null :: forall a. NodeMap a -> Bool
$clength :: forall a. NodeMap a -> Int
length :: forall a. NodeMap a -> Int
$celem :: forall a. Eq a => a -> NodeMap a -> Bool
elem :: forall a. Eq a => a -> NodeMap a -> Bool
$cmaximum :: forall a. Ord a => NodeMap a -> a
maximum :: forall a. Ord a => NodeMap a -> a
$cminimum :: forall a. Ord a => NodeMap a -> a
minimum :: forall a. Ord a => NodeMap a -> a
$csum :: forall a. Num a => NodeMap a -> a
sum :: forall a. Num a => NodeMap a -> a
$cproduct :: forall a. Num a => NodeMap a -> a
product :: forall a. Num a => NodeMap a -> a
Foldable)

-- | Transitive dependencies, including SOURCE edges
mkTransDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mkTransDeps :: [ModuleGraphNode]
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mkTransDeps = (Graph SummaryNode -> ReachabilityIndex SummaryNode)
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Graph SummaryNode -> ReachabilityIndex SummaryNode
forall node. Graph node -> ReachabilityIndex node
graphReachability {- module graph is acyclic -} ((Graph SummaryNode, NodeKey -> Maybe SummaryNode)
 -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode))
-> ([ModuleGraphNode]
    -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode))
-> [ModuleGraphNode]
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
False

-- | Transitive dependencies, ignoring SOURCE edges
mkTransLoopDeps :: [ModuleGraphNode] -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mkTransLoopDeps :: [ModuleGraphNode]
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mkTransLoopDeps = (Graph SummaryNode -> ReachabilityIndex SummaryNode)
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Graph SummaryNode -> ReachabilityIndex SummaryNode
forall node. Graph node -> ReachabilityIndex node
cyclicGraphReachability ((Graph SummaryNode, NodeKey -> Maybe SummaryNode)
 -> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode))
-> ([ModuleGraphNode]
    -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode))
-> [ModuleGraphNode]
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> [ModuleGraphNode]
-> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)
moduleGraphNodes Bool
True

-- | Transitive dependencies, but only following "normal" level 0 imports.
-- This graph can be used to query what the transitive dependencies of a particular
-- level are within a module.
mkTransZeroDeps :: [ModuleGraphNode] -> (ReachabilityIndex ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode)
mkTransZeroDeps :: [ModuleGraphNode]
-> (ReachabilityIndex ZeroSummaryNode,
    ZeroScopeKey -> Maybe ZeroSummaryNode)
mkTransZeroDeps = (Graph ZeroSummaryNode -> ReachabilityIndex ZeroSummaryNode)
-> (Graph ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode)
-> (ReachabilityIndex ZeroSummaryNode,
    ZeroScopeKey -> Maybe ZeroSummaryNode)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Graph ZeroSummaryNode -> ReachabilityIndex ZeroSummaryNode
forall node. Graph node -> ReachabilityIndex node
graphReachability {- module graph is acyclic -} ((Graph ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode)
 -> (ReachabilityIndex ZeroSummaryNode,
     ZeroScopeKey -> Maybe ZeroSummaryNode))
-> ([ModuleGraphNode]
    -> (Graph ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode))
-> [ModuleGraphNode]
-> (ReachabilityIndex ZeroSummaryNode,
    ZeroScopeKey -> Maybe ZeroSummaryNode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModuleGraphNode]
-> (Graph ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode)
moduleGraphNodesZero

-- | Transitive dependencies, but with the stage that each module is required at.
mkStageDeps :: [ModuleGraphNode] -> (ReachabilityIndex StageSummaryNode, (NodeKey, ModuleStage) -> Maybe StageSummaryNode)
mkStageDeps :: [ModuleGraphNode]
-> (ReachabilityIndex StageSummaryNode,
    (NodeKey, ModuleStage) -> Maybe StageSummaryNode)
mkStageDeps = (Graph StageSummaryNode -> ReachabilityIndex StageSummaryNode)
-> (Graph StageSummaryNode,
    (NodeKey, ModuleStage) -> Maybe StageSummaryNode)
-> (ReachabilityIndex StageSummaryNode,
    (NodeKey, ModuleStage) -> Maybe StageSummaryNode)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Graph StageSummaryNode -> ReachabilityIndex StageSummaryNode
forall node. Graph node -> ReachabilityIndex node
cyclicGraphReachability ((Graph StageSummaryNode,
  (NodeKey, ModuleStage) -> Maybe StageSummaryNode)
 -> (ReachabilityIndex StageSummaryNode,
     (NodeKey, ModuleStage) -> Maybe StageSummaryNode))
-> ([ModuleGraphNode]
    -> (Graph StageSummaryNode,
        (NodeKey, ModuleStage) -> Maybe StageSummaryNode))
-> [ModuleGraphNode]
-> (ReachabilityIndex StageSummaryNode,
    (NodeKey, ModuleStage) -> Maybe StageSummaryNode)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModuleGraphNode]
-> (Graph StageSummaryNode,
    (NodeKey, ModuleStage) -> Maybe StageSummaryNode)
moduleGraphNodesStages

type ZeroSummaryNode = Node Int ZeroScopeKey

zeroSummaryNodeKey :: ZeroSummaryNode -> Int
zeroSummaryNodeKey :: ZeroSummaryNode -> Int
zeroSummaryNodeKey = ZeroSummaryNode -> Int
forall key payload. Node key payload -> key
node_key

zeroSummaryNodeSummary :: ZeroSummaryNode -> ZeroScopeKey
zeroSummaryNodeSummary :: ZeroSummaryNode -> ZeroScopeKey
zeroSummaryNodeSummary = ZeroSummaryNode -> ZeroScopeKey
forall key payload. Node key payload -> payload
node_payload

-- | The 'ZeroScopeKey' indicates the different scopes which we can refer to in a zero-scope query.
data ZeroScopeKey = ModuleScope ModNodeKeyWithUid ImportLevel | UnitScope UnitId
  deriving (ZeroScopeKey -> ZeroScopeKey -> Bool
(ZeroScopeKey -> ZeroScopeKey -> Bool)
-> (ZeroScopeKey -> ZeroScopeKey -> Bool) -> Eq ZeroScopeKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ZeroScopeKey -> ZeroScopeKey -> Bool
== :: ZeroScopeKey -> ZeroScopeKey -> Bool
$c/= :: ZeroScopeKey -> ZeroScopeKey -> Bool
/= :: ZeroScopeKey -> ZeroScopeKey -> Bool
Eq, Eq ZeroScopeKey
Eq ZeroScopeKey =>
(ZeroScopeKey -> ZeroScopeKey -> Ordering)
-> (ZeroScopeKey -> ZeroScopeKey -> Bool)
-> (ZeroScopeKey -> ZeroScopeKey -> Bool)
-> (ZeroScopeKey -> ZeroScopeKey -> Bool)
-> (ZeroScopeKey -> ZeroScopeKey -> Bool)
-> (ZeroScopeKey -> ZeroScopeKey -> ZeroScopeKey)
-> (ZeroScopeKey -> ZeroScopeKey -> ZeroScopeKey)
-> Ord ZeroScopeKey
ZeroScopeKey -> ZeroScopeKey -> Bool
ZeroScopeKey -> ZeroScopeKey -> Ordering
ZeroScopeKey -> ZeroScopeKey -> ZeroScopeKey
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ZeroScopeKey -> ZeroScopeKey -> Ordering
compare :: ZeroScopeKey -> ZeroScopeKey -> Ordering
$c< :: ZeroScopeKey -> ZeroScopeKey -> Bool
< :: ZeroScopeKey -> ZeroScopeKey -> Bool
$c<= :: ZeroScopeKey -> ZeroScopeKey -> Bool
<= :: ZeroScopeKey -> ZeroScopeKey -> Bool
$c> :: ZeroScopeKey -> ZeroScopeKey -> Bool
> :: ZeroScopeKey -> ZeroScopeKey -> Bool
$c>= :: ZeroScopeKey -> ZeroScopeKey -> Bool
>= :: ZeroScopeKey -> ZeroScopeKey -> Bool
$cmax :: ZeroScopeKey -> ZeroScopeKey -> ZeroScopeKey
max :: ZeroScopeKey -> ZeroScopeKey -> ZeroScopeKey
$cmin :: ZeroScopeKey -> ZeroScopeKey -> ZeroScopeKey
min :: ZeroScopeKey -> ZeroScopeKey -> ZeroScopeKey
Ord)

instance Outputable ZeroScopeKey where
  ppr :: ZeroScopeKey -> SDoc
ppr (ModuleScope ModNodeKeyWithUid
mk ImportLevel
il) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ModuleScope" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModNodeKeyWithUid -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModNodeKeyWithUid
mk SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ImportLevel -> SDoc
forall a. Outputable a => a -> SDoc
ppr ImportLevel
il
  ppr (UnitScope UnitId
uid) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"UnitScope" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
uid

-- | Turn a list of graph nodes into an efficient queriable graph.
-- This graph only has edges between level-0 imports
--
-- This query answers the question. If I am looking at level n in module M then which
-- modules are visible?
--
-- If you are looking at level -1  then the reachable modules are those imported at splice and
-- then any modules those modules import at zero. (Ie the zero scope for those modules)
moduleGraphNodesZero ::
     [ModuleGraphNode]
  -> (Graph ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode)
moduleGraphNodesZero :: [ModuleGraphNode]
-> (Graph ZeroSummaryNode, ZeroScopeKey -> Maybe ZeroSummaryNode)
moduleGraphNodesZero [ModuleGraphNode]
summaries =
  ([ZeroSummaryNode] -> Graph ZeroSummaryNode
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [ZeroSummaryNode]
nodes, ZeroScopeKey -> Maybe ZeroSummaryNode
lookup_node)
  where
    nodes :: [ZeroSummaryNode]
nodes = (((ModuleGraphNode, ImportLevel), Int) -> Maybe ZeroSummaryNode)
-> [((ModuleGraphNode, ImportLevel), Int)] -> [ZeroSummaryNode]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((ModuleGraphNode, ImportLevel), Int) -> Maybe ZeroSummaryNode
go [((ModuleGraphNode, ImportLevel), Int)]
numbered_summaries

      where
        go :: (((ModuleGraphNode, ImportLevel)), Int) -> Maybe ZeroSummaryNode
        go :: ((ModuleGraphNode, ImportLevel), Int) -> Maybe ZeroSummaryNode
go (((ModuleNode [ModuleNodeEdge]
nks ModuleNodeInfo
ms), ImportLevel
s), Int
key) = ZeroSummaryNode -> Maybe ZeroSummaryNode
forall a. a -> Maybe a
Just (ZeroSummaryNode -> Maybe ZeroSummaryNode)
-> ZeroSummaryNode -> Maybe ZeroSummaryNode
forall a b. (a -> b) -> a -> b
$
               ZeroScopeKey -> Int -> [Int] -> ZeroSummaryNode
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode (ModNodeKeyWithUid -> ImportLevel -> ZeroScopeKey
ModuleScope (ModuleNodeInfo -> ModNodeKeyWithUid
mnKey ModuleNodeInfo
ms) ImportLevel
s) Int
key ([Int] -> ZeroSummaryNode) -> [Int] -> ZeroSummaryNode
forall a b. (a -> b) -> a -> b
$ [ZeroScopeKey] -> [Int]
out_edge_keys ([ZeroScopeKey] -> [Int]) -> [ZeroScopeKey] -> [Int]
forall a b. (a -> b) -> a -> b
$
                    (ModuleNodeEdge -> Maybe ZeroScopeKey)
-> [ModuleNodeEdge] -> [ZeroScopeKey]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ImportLevel -> ModuleNodeEdge -> Maybe ZeroScopeKey
classifyDeps ImportLevel
s) [ModuleNodeEdge]
nks
        go (((UnitNode [UnitId]
uids UnitId
uid), ImportLevel
_s), Int
key) =
          ZeroSummaryNode -> Maybe ZeroSummaryNode
forall a. a -> Maybe a
Just (ZeroSummaryNode -> Maybe ZeroSummaryNode)
-> ZeroSummaryNode -> Maybe ZeroSummaryNode
forall a b. (a -> b) -> a -> b
$ ZeroScopeKey -> Int -> [Int] -> ZeroSummaryNode
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode (UnitId -> ZeroScopeKey
UnitScope UnitId
uid) Int
key ((ZeroScopeKey -> Maybe Int) -> [ZeroScopeKey] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ZeroScopeKey -> Maybe Int
lookup_key ([ZeroScopeKey] -> [Int]) -> [ZeroScopeKey] -> [Int]
forall a b. (a -> b) -> a -> b
$ (UnitId -> ZeroScopeKey) -> [UnitId] -> [ZeroScopeKey]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> ZeroScopeKey
UnitScope [UnitId]
uids)
        go ((ModuleGraphNode, ImportLevel), Int)
_ = Maybe ZeroSummaryNode
forall a. Maybe a
Nothing

    -- This is the key part, a dependency edge also depends on the NormalLevel scope of an import.
    classifyDeps :: ImportLevel -> ModuleNodeEdge -> Maybe ZeroScopeKey
classifyDeps ImportLevel
s (ModuleNodeEdge ImportLevel
il (NodeKey_Module ModNodeKeyWithUid
k)) | ImportLevel
s ImportLevel -> ImportLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ImportLevel
il = ZeroScopeKey -> Maybe ZeroScopeKey
forall a. a -> Maybe a
Just (ModNodeKeyWithUid -> ImportLevel -> ZeroScopeKey
ModuleScope ModNodeKeyWithUid
k ImportLevel
NormalLevel)
    classifyDeps ImportLevel
s (ModuleNodeEdge ImportLevel
il (NodeKey_ExternalUnit UnitId
u)) | ImportLevel
s ImportLevel -> ImportLevel -> Bool
forall a. Eq a => a -> a -> Bool
== ImportLevel
il = ZeroScopeKey -> Maybe ZeroScopeKey
forall a. a -> Maybe a
Just (UnitId -> ZeroScopeKey
UnitScope UnitId
u)
    classifyDeps ImportLevel
_ ModuleNodeEdge
_ = Maybe ZeroScopeKey
forall a. Maybe a
Nothing

    numbered_summaries :: [((ModuleGraphNode, ImportLevel), Int)]
    numbered_summaries :: [((ModuleGraphNode, ImportLevel), Int)]
numbered_summaries = [(ModuleGraphNode, ImportLevel)]
-> [Int] -> [((ModuleGraphNode, ImportLevel), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (([(ModuleGraphNode
s, ImportLevel
l) | ModuleGraphNode
s <- [ModuleGraphNode]
summaries, ImportLevel
l <- [ImportLevel
SpliceLevel, ImportLevel
QuoteLevel, ImportLevel
NormalLevel]])) [Int
0..]

    lookup_node :: ZeroScopeKey -> Maybe ZeroSummaryNode
    lookup_node :: ZeroScopeKey -> Maybe ZeroSummaryNode
lookup_node ZeroScopeKey
key = ZeroScopeKey
-> Map ZeroScopeKey ZeroSummaryNode -> Maybe ZeroSummaryNode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ZeroScopeKey
key Map ZeroScopeKey ZeroSummaryNode
node_map

    lookup_key :: ZeroScopeKey -> Maybe Int
    lookup_key :: ZeroScopeKey -> Maybe Int
lookup_key = (ZeroSummaryNode -> Int) -> Maybe ZeroSummaryNode -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ZeroSummaryNode -> Int
zeroSummaryNodeKey (Maybe ZeroSummaryNode -> Maybe Int)
-> (ZeroScopeKey -> Maybe ZeroSummaryNode)
-> ZeroScopeKey
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ZeroScopeKey -> Maybe ZeroSummaryNode
lookup_node

    node_map :: Map ZeroScopeKey ZeroSummaryNode
    node_map :: Map ZeroScopeKey ZeroSummaryNode
node_map =
      [(ZeroScopeKey, ZeroSummaryNode)]
-> Map ZeroScopeKey ZeroSummaryNode
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (ZeroScopeKey
s, ZeroSummaryNode
node)
                   | ZeroSummaryNode
node <- [ZeroSummaryNode]
nodes
                   , let s :: ZeroScopeKey
s = ZeroSummaryNode -> ZeroScopeKey
zeroSummaryNodeSummary ZeroSummaryNode
node
                   ]

    out_edge_keys :: [ZeroScopeKey] -> [Int]
    out_edge_keys :: [ZeroScopeKey] -> [Int]
out_edge_keys = (ZeroScopeKey -> Maybe Int) -> [ZeroScopeKey] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ZeroScopeKey -> Maybe Int
lookup_key

type StageSummaryNode = Node Int (NodeKey, ModuleStage)

stageSummaryNodeKey :: StageSummaryNode -> Int
stageSummaryNodeKey :: StageSummaryNode -> Int
stageSummaryNodeKey = StageSummaryNode -> Int
forall key payload. Node key payload -> key
node_key

stageSummaryNodeSummary :: StageSummaryNode -> (NodeKey, ModuleStage)
stageSummaryNodeSummary :: StageSummaryNode -> (NodeKey, ModuleStage)
stageSummaryNodeSummary = StageSummaryNode -> (NodeKey, ModuleStage)
forall key payload. Node key payload -> payload
node_payload

-- | Turn a list of graph nodes into an efficient queriable graph.
-- This graph has edges between modules and the stage they are required at.
--
-- This graph can be used to answer the query, if I am compiling a module at stage
-- S, then what modules do I need at which stages for that?
-- Used by 'downsweep' in order to determine which modules need code generation if you
-- are using 'TemplateHaskell'.
--
-- The rules for this query can be read in more detail in the Explicit Level Imports proposal.
-- Briefly:
--  * If NoImplicitStagePersistence then Quote/Splice/Normal imports offset the required stage
--  * If ImplicitStagePersistence and TemplateHaskell then imported module are needed at all stages.
--  * Otherwise, an imported module is just needed at the normal stage.
--
--  * A module using TemplateHaskellQuotes required at C stage is also required at R
--    stage.
moduleGraphNodesStages ::
     [ModuleGraphNode]
  -> (Graph StageSummaryNode, (NodeKey, ModuleStage) -> Maybe StageSummaryNode)
moduleGraphNodesStages :: [ModuleGraphNode]
-> (Graph StageSummaryNode,
    (NodeKey, ModuleStage) -> Maybe StageSummaryNode)
moduleGraphNodesStages [ModuleGraphNode]
summaries =
  ([StageSummaryNode] -> Graph StageSummaryNode
forall key payload.
Uniquable key =>
[Node key payload] -> Graph (Node key payload)
graphFromEdgedVerticesUniq [StageSummaryNode]
nodes, (NodeKey, ModuleStage) -> Maybe StageSummaryNode
lookup_node)
  where
    nodes :: [StageSummaryNode]
nodes = (((ModuleGraphNode, ModuleStage), Int) -> StageSummaryNode)
-> [((ModuleGraphNode, ModuleStage), Int)] -> [StageSummaryNode]
forall a b. (a -> b) -> [a] -> [b]
map ((ModuleGraphNode, ModuleStage), Int) -> StageSummaryNode
go [((ModuleGraphNode, ModuleStage), Int)]
numbered_summaries

      where
        go :: (((ModuleGraphNode, ModuleStage)), Int) -> StageSummaryNode
        go :: ((ModuleGraphNode, ModuleStage), Int) -> StageSummaryNode
go ((ModuleGraphNode, ModuleStage)
s, Int
key) = (ModuleGraphNode, ModuleStage) -> StageSummaryNode
normal_case (ModuleGraphNode, ModuleStage)
s
          where
           normal_case :: (ModuleGraphNode, ModuleStage)  -> StageSummaryNode
           normal_case :: (ModuleGraphNode, ModuleStage) -> StageSummaryNode
normal_case ((m :: ModuleGraphNode
m@(ModuleNode [ModuleNodeEdge]
nks ModuleNodeInfo
ms), ModuleStage
s)) =
                  (NodeKey, ModuleStage) -> Int -> [Int] -> StageSummaryNode
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode ((ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
m, ModuleStage
s)) Int
key ([Int] -> StageSummaryNode) -> [Int] -> StageSummaryNode
forall a b. (a -> b) -> a -> b
$ [(NodeKey, ModuleStage)] -> [Int]
out_edge_keys ([(NodeKey, ModuleStage)] -> [Int])
-> [(NodeKey, ModuleStage)] -> [Int]
forall a b. (a -> b) -> a -> b
$
                       ModuleNodeInfo
-> ModuleStage -> NodeKey -> [(NodeKey, ModuleStage)]
forall {a}.
ModuleNodeInfo -> ModuleStage -> a -> [(a, ModuleStage)]
selfEdges ModuleNodeInfo
ms ModuleStage
s (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
m) [(NodeKey, ModuleStage)]
-> [(NodeKey, ModuleStage)] -> [(NodeKey, ModuleStage)]
forall a. [a] -> [a] -> [a]
++ (ModuleNodeEdge -> [(NodeKey, ModuleStage)])
-> [ModuleNodeEdge] -> [(NodeKey, ModuleStage)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ModuleNodeInfo
-> ModuleStage -> ModuleNodeEdge -> [(NodeKey, ModuleStage)]
classifyDeps ModuleNodeInfo
ms ModuleStage
s) [ModuleNodeEdge]
nks
           normal_case (ModuleGraphNode
m, ModuleStage
s) =
             (NodeKey, ModuleStage) -> Int -> [Int] -> StageSummaryNode
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode (ModuleGraphNode -> NodeKey
mkNodeKey ModuleGraphNode
m, ModuleStage
s) Int
key ([(NodeKey, ModuleStage)] -> [Int]
out_edge_keys ([(NodeKey, ModuleStage)] -> [Int])
-> ([NodeKey] -> [(NodeKey, ModuleStage)]) -> [NodeKey] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeKey -> (NodeKey, ModuleStage))
-> [NodeKey] -> [(NodeKey, ModuleStage)]
forall a b. (a -> b) -> [a] -> [b]
map (, ModuleStage
s) ([NodeKey] -> [Int]) -> [NodeKey] -> [Int]
forall a b. (a -> b) -> a -> b
$ Bool -> ModuleGraphNode -> [NodeKey]
mgNodeDependencies Bool
False ModuleGraphNode
m)

    isExplicitStageMS :: ModSummary -> Bool
    isExplicitStageMS :: ModSummary -> Bool
isExplicitStageMS ModSummary
ms = Bool -> Bool
not (Extension -> DynFlags -> Bool
xopt Extension
LangExt.ImplicitStagePersistence (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms))

    isTemplateHaskellQuotesMS :: ModSummary -> Bool
    isTemplateHaskellQuotesMS :: ModSummary -> Bool
isTemplateHaskellQuotesMS ModSummary
ms = Extension -> DynFlags -> Bool
xopt Extension
LangExt.TemplateHaskellQuotes (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms)

    -- Accounting for persistence within a module.
    -- If a module is required @ C and it persists an idenfifier, it's also required
    -- at R.
    selfEdges :: ModuleNodeInfo -> ModuleStage -> a -> [(a, ModuleStage)]
selfEdges (ModuleNodeCompile ModSummary
ms) ModuleStage
s a
self_key
      | Bool -> Bool
not (ModSummary -> Bool
isExplicitStageMS ModSummary
ms)
        Bool -> Bool -> Bool
&& (ModSummary -> Bool
isTemplateHaskellQuotesMS ModSummary
ms
            Bool -> Bool -> Bool
|| ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ModSummary
ms)
        = [(a
self_key, ModuleStage
s') | ModuleStage
s' <- ModuleStage -> [ModuleStage]
onlyFutureStages ModuleStage
s]
    selfEdges ModuleNodeInfo
_ ModuleStage
_ a
_ = []

    -- Case 1. No implicit stage persistnce is enabled
    classifyDeps :: ModuleNodeInfo
-> ModuleStage -> ModuleNodeEdge -> [(NodeKey, ModuleStage)]
classifyDeps (ModuleNodeCompile ModSummary
ms) ModuleStage
s (ModuleNodeEdge ImportLevel
il NodeKey
k)
      | ModSummary -> Bool
isExplicitStageMS ModSummary
ms = case ImportLevel
il of
                                ImportLevel
SpliceLevel -> [(NodeKey
k, ModuleStage -> ModuleStage
decModuleStage ModuleStage
s)]
                                ImportLevel
NormalLevel -> [(NodeKey
k, ModuleStage
s)]
                                ImportLevel
QuoteLevel  -> [(NodeKey
k, ModuleStage -> ModuleStage
incModuleStage ModuleStage
s)]
    -- Case 2a. TemplateHaskellQuotes case  (section 5.6 in the paper)
    classifyDeps (ModuleNodeCompile ModSummary
ms) ModuleStage
s (ModuleNodeEdge ImportLevel
_ NodeKey
k)
      | Bool -> Bool
not (ModSummary -> Bool
isExplicitStageMS ModSummary
ms)
      , Bool -> Bool
not (ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ModSummary
ms)
      , ModSummary -> Bool
isTemplateHaskellQuotesMS ModSummary
ms
      = [(NodeKey
k, ModuleStage
s') | ModuleStage
s' <- ModuleStage -> [ModuleStage]
nowAndFutureStages ModuleStage
s]
    -- Case 2b. Template haskell is enabled, with implicit stage persistence
    classifyDeps (ModuleNodeCompile ModSummary
ms) ModuleStage
_ (ModuleNodeEdge ImportLevel
_ NodeKey
k)
      | ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ModSummary
ms
      , Bool -> Bool
not (ModSummary -> Bool
isExplicitStageMS ModSummary
ms) =
        [(NodeKey
k, ModuleStage
s) | ModuleStage
s <- [ModuleStage]
allStages]
    -- Case 3. No template haskell, therefore no additional dependencies.
    classifyDeps ModuleNodeInfo
_ ModuleStage
s (ModuleNodeEdge ImportLevel
_ NodeKey
k) = [(NodeKey
k, ModuleStage
s)]


    numbered_summaries :: [((ModuleGraphNode, ModuleStage), Int)]
    numbered_summaries :: [((ModuleGraphNode, ModuleStage), Int)]
numbered_summaries = [(ModuleGraphNode, ModuleStage)]
-> [Int] -> [((ModuleGraphNode, ModuleStage), Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (([(ModuleGraphNode
s, ModuleStage
l) | ModuleGraphNode
s <- [ModuleGraphNode]
summaries, ModuleStage
l <- [ModuleStage]
allStages])) [Int
0..]

    lookup_node :: (NodeKey, ModuleStage) -> Maybe StageSummaryNode
    lookup_node :: (NodeKey, ModuleStage) -> Maybe StageSummaryNode
lookup_node (NodeKey, ModuleStage)
key = (NodeKey, ModuleStage)
-> Map (NodeKey, ModuleStage) StageSummaryNode
-> Maybe StageSummaryNode
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (NodeKey, ModuleStage)
key Map (NodeKey, ModuleStage) StageSummaryNode
node_map

    lookup_key ::  (NodeKey, ModuleStage) -> Maybe Int
    lookup_key :: (NodeKey, ModuleStage) -> Maybe Int
lookup_key = (StageSummaryNode -> Int) -> Maybe StageSummaryNode -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StageSummaryNode -> Int
stageSummaryNodeKey (Maybe StageSummaryNode -> Maybe Int)
-> ((NodeKey, ModuleStage) -> Maybe StageSummaryNode)
-> (NodeKey, ModuleStage)
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeKey, ModuleStage) -> Maybe StageSummaryNode
lookup_node

    node_map :: Map (NodeKey, ModuleStage) StageSummaryNode
    node_map :: Map (NodeKey, ModuleStage) StageSummaryNode
node_map =
      [((NodeKey, ModuleStage), StageSummaryNode)]
-> Map (NodeKey, ModuleStage) StageSummaryNode
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ ((NodeKey, ModuleStage)
s, StageSummaryNode
node)
                   | StageSummaryNode
node <- [StageSummaryNode]
nodes
                   , let s :: (NodeKey, ModuleStage)
s = StageSummaryNode -> (NodeKey, ModuleStage)
stageSummaryNodeSummary StageSummaryNode
node
                   ]

    out_edge_keys :: [(NodeKey, ModuleStage)] -> [Int]
    out_edge_keys :: [(NodeKey, ModuleStage)] -> [Int]
out_edge_keys = ((NodeKey, ModuleStage) -> Maybe Int)
-> [(NodeKey, ModuleStage)] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (NodeKey, ModuleStage) -> Maybe Int
lookup_key
        -- If we want keep_hi_boot_nodes, then we do lookup_key with
        -- IsBoot; else False


-- | Add an ExtendedModSummary to ModuleGraph. Assumes that the new ModSummary is
-- not an element of the ModuleGraph.
extendMG :: ModuleGraph -> ModuleGraphNode -> ModuleGraph
extendMG :: ModuleGraph -> ModuleGraphNode -> ModuleGraph
extendMG ModuleGraph{Bool
[ModuleGraphNode]
(ReachabilityIndex ZeroSummaryNode,
 ZeroScopeKey -> Maybe ZeroSummaryNode)
(ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
HomeModuleNameProvidersMap
mg_mss :: ModuleGraph -> [ModuleGraphNode]
mg_graph :: ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph :: ModuleGraph
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_zero_graph :: ModuleGraph
-> (ReachabilityIndex ZeroSummaryNode,
    ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_has_holes :: ModuleGraph -> Bool
mg_home_module_name_providers_map :: ModuleGraph -> HomeModuleNameProvidersMap
mg_mss :: [ModuleGraphNode]
mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_zero_graph :: (ReachabilityIndex ZeroSummaryNode,
 ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_has_holes :: Bool
mg_home_module_name_providers_map :: HomeModuleNameProvidersMap
..} ModuleGraphNode
node =
  ModuleGraph
    { mg_mss :: [ModuleGraphNode]
mg_mss = [ModuleGraphNode]
new_mss
    , mg_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_graph =  [ModuleGraphNode]
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mkTransDeps [ModuleGraphNode]
new_mss
    , mg_loop_graph :: (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mg_loop_graph = [ModuleGraphNode]
-> (ReachabilityIndex SummaryNode, NodeKey -> Maybe SummaryNode)
mkTransLoopDeps [ModuleGraphNode]
new_mss
    , mg_zero_graph :: (ReachabilityIndex ZeroSummaryNode,
 ZeroScopeKey -> Maybe ZeroSummaryNode)
mg_zero_graph = [ModuleGraphNode]
-> (ReachabilityIndex ZeroSummaryNode,
    ZeroScopeKey -> Maybe ZeroSummaryNode)
mkTransZeroDeps [ModuleGraphNode]
new_mss
    , mg_has_holes :: Bool
mg_has_holes = Bool
mg_has_holes Bool -> Bool -> Bool
|| Bool -> (HscSource -> Bool) -> Maybe HscSource -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False HscSource -> Bool
isHsigFile (ModuleNodeInfo -> Maybe HscSource
moduleNodeInfoHscSource (ModuleNodeInfo -> Maybe HscSource)
-> Maybe ModuleNodeInfo -> Maybe HscSource
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ModuleGraphNode -> Maybe ModuleNodeInfo
mgNodeIsModule ModuleGraphNode
node)
    , mg_home_module_name_providers_map :: HomeModuleNameProvidersMap
mg_home_module_name_providers_map = [ModuleGraphNode] -> HomeModuleNameProvidersMap
mkHomeModuleNameProvidersMap [ModuleGraphNode]
new_mss
    }
  where
    new_mss :: [ModuleGraphNode]
new_mss = ModuleGraphNode
node ModuleGraphNode -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. a -> [a] -> [a]
: [ModuleGraphNode]
mg_mss