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

module GHC.Unit.Module.Graph
   ( ModuleGraph
   , ModuleGraphNode(..)
   , emptyMG
   , mkModuleGraph
   , mkModuleGraph'
   , extendMG
   , extendMGInst
   , extendMG'
   , filterToposortToModules
   , mapMG
   , mgModSummaries
   , mgModSummaries'
   , mgExtendedModSummaries
   , mgElemModule
   , mgLookupModule
   , mgBootModules
   , needsTemplateHaskellOrQQ
   , isTemplateHaskellOrQQNonBoot
   , showModMsg
   )
where

import GHC.Prelude

import qualified GHC.LanguageExtensions as LangExt

import GHC.Data.Maybe
import GHC.Data.Graph.Directed ( SCC(..) )

import GHC.Driver.Backend
import GHC.Driver.Ppr
import GHC.Driver.Session

import GHC.Types.SourceFile ( hscSourceString )

import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Env
import GHC.Unit.Types
import GHC.Utils.Outputable

import System.FilePath

-- | 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 InstantiatedUnit
  -- | There is a module summary node for each module, signature, and boot module being built.
  | ModuleNode ExtendedModSummary

instance Outputable ModuleGraphNode where
  ppr :: ModuleGraphNode -> SDoc
ppr = \case
    InstantiationNode InstantiatedUnit
iuid -> InstantiatedUnit -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
iuid
    ModuleNode ExtendedModSummary
ems -> ExtendedModSummary -> SDoc
forall a. Outputable a => a -> SDoc
ppr ExtendedModSummary
ems

-- | 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 -> ModuleEnv ModSummary
mg_non_boot :: ModuleEnv ModSummary
    -- a map of all non-boot ModSummaries keyed by Modules
  , ModuleGraph -> ModuleSet
mg_boot :: ModuleSet
    -- a set of boot Modules
  , ModuleGraph -> Bool
mg_needs_th_or_qq :: !Bool
    -- does any of the modules in mg_mss require TemplateHaskell or
    -- QuasiQuotes?
  }

-- | Determines whether a set of modules requires Template Haskell or
-- Quasi Quotes
--
-- Note that if the session's 'DynFlags' enabled Template Haskell when
-- 'depanal' was called, then each module in the returned module graph will
-- have Template Haskell enabled whether it is actually needed or not.
needsTemplateHaskellOrQQ :: ModuleGraph -> Bool
needsTemplateHaskellOrQQ :: ModuleGraph -> Bool
needsTemplateHaskellOrQQ ModuleGraph
mg = ModuleGraph -> Bool
mg_needs_th_or_qq ModuleGraph
mg

-- | 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]
ModuleSet
ModuleEnv ModSummary
mg_needs_th_or_qq :: Bool
mg_boot :: ModuleSet
mg_non_boot :: ModuleEnv ModSummary
mg_mss :: [ModuleGraphNode]
mg_needs_th_or_qq :: ModuleGraph -> Bool
mg_boot :: ModuleGraph -> ModuleSet
mg_non_boot :: ModuleGraph -> ModuleEnv ModSummary
mg_mss :: ModuleGraph -> [ModuleGraphNode]
..} = ModuleGraph
mg
  { mg_mss :: [ModuleGraphNode]
mg_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 (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 InstantiatedUnit
iuid -> InstantiatedUnit -> ModuleGraphNode
InstantiationNode InstantiatedUnit
iuid
      ModuleNode (ExtendedModSummary ModSummary
ms [InstantiatedUnit]
bds) -> ExtendedModSummary -> ModuleGraphNode
ModuleNode (ModSummary -> [InstantiatedUnit] -> ExtendedModSummary
ExtendedModSummary (ModSummary -> ModSummary
f ModSummary
ms) [InstantiatedUnit]
bds)
  , mg_non_boot :: ModuleEnv ModSummary
mg_non_boot = (ModSummary -> ModSummary)
-> ModuleEnv ModSummary -> ModuleEnv ModSummary
forall a b. (a -> b) -> ModuleEnv a -> ModuleEnv b
mapModuleEnv ModSummary -> ModSummary
f ModuleEnv ModSummary
mg_non_boot
  }

mgBootModules :: ModuleGraph -> ModuleSet
mgBootModules :: ModuleGraph -> ModuleSet
mgBootModules ModuleGraph{Bool
[ModuleGraphNode]
ModuleSet
ModuleEnv ModSummary
mg_needs_th_or_qq :: Bool
mg_boot :: ModuleSet
mg_non_boot :: ModuleEnv ModSummary
mg_mss :: [ModuleGraphNode]
mg_needs_th_or_qq :: ModuleGraph -> Bool
mg_boot :: ModuleGraph -> ModuleSet
mg_non_boot :: ModuleGraph -> ModuleEnv ModSummary
mg_mss :: ModuleGraph -> [ModuleGraphNode]
..} = ModuleSet
mg_boot

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

mgExtendedModSummaries :: ModuleGraph -> [ExtendedModSummary]
mgExtendedModSummaries :: ModuleGraph -> [ExtendedModSummary]
mgExtendedModSummaries ModuleGraph
mg = [ ExtendedModSummary
ems | ModuleNode ExtendedModSummary
ems <- ModuleGraph -> [ModuleGraphNode]
mgModSummaries' ModuleGraph
mg ]

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

mgElemModule :: ModuleGraph -> Module -> Bool
mgElemModule :: ModuleGraph -> Module -> Bool
mgElemModule ModuleGraph{Bool
[ModuleGraphNode]
ModuleSet
ModuleEnv ModSummary
mg_needs_th_or_qq :: Bool
mg_boot :: ModuleSet
mg_non_boot :: ModuleEnv ModSummary
mg_mss :: [ModuleGraphNode]
mg_needs_th_or_qq :: ModuleGraph -> Bool
mg_boot :: ModuleGraph -> ModuleSet
mg_non_boot :: ModuleGraph -> ModuleEnv ModSummary
mg_mss :: ModuleGraph -> [ModuleGraphNode]
..} Module
m = Module -> ModuleEnv ModSummary -> Bool
forall a. Module -> ModuleEnv a -> Bool
elemModuleEnv Module
m ModuleEnv ModSummary
mg_non_boot

-- | Look up a ModSummary in the ModuleGraph
mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary
mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary
mgLookupModule ModuleGraph{Bool
[ModuleGraphNode]
ModuleSet
ModuleEnv ModSummary
mg_needs_th_or_qq :: Bool
mg_boot :: ModuleSet
mg_non_boot :: ModuleEnv ModSummary
mg_mss :: [ModuleGraphNode]
mg_needs_th_or_qq :: ModuleGraph -> Bool
mg_boot :: ModuleGraph -> ModuleSet
mg_non_boot :: ModuleGraph -> ModuleEnv ModSummary
mg_mss :: ModuleGraph -> [ModuleGraphNode]
..} Module
m = ModuleEnv ModSummary -> Module -> Maybe ModSummary
forall a. ModuleEnv a -> Module -> Maybe a
lookupModuleEnv ModuleEnv ModSummary
mg_non_boot Module
m

emptyMG :: ModuleGraph
emptyMG :: ModuleGraph
emptyMG = [ModuleGraphNode]
-> ModuleEnv ModSummary -> ModuleSet -> Bool -> ModuleGraph
ModuleGraph [] ModuleEnv ModSummary
forall a. ModuleEnv a
emptyModuleEnv ModuleSet
emptyModuleSet Bool
False

isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool
isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ModSummary
ms =
  (Extension -> DynFlags -> Bool
xopt Extension
LangExt.TemplateHaskell (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms)
    Bool -> Bool -> Bool
|| Extension -> DynFlags -> Bool
xopt Extension
LangExt.QuasiQuotes (ModSummary -> DynFlags
ms_hspp_opts ModSummary
ms)) Bool -> Bool -> Bool
&&
  (ModSummary -> IsBootInterface
isBootSummary ModSummary
ms IsBootInterface -> IsBootInterface -> Bool
forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot)

-- | Add an ExtendedModSummary to ModuleGraph. Assumes that the new ModSummary is
-- not an element of the ModuleGraph.
extendMG :: ModuleGraph -> ExtendedModSummary -> ModuleGraph
extendMG :: ModuleGraph -> ExtendedModSummary -> ModuleGraph
extendMG ModuleGraph{Bool
[ModuleGraphNode]
ModuleSet
ModuleEnv ModSummary
mg_needs_th_or_qq :: Bool
mg_boot :: ModuleSet
mg_non_boot :: ModuleEnv ModSummary
mg_mss :: [ModuleGraphNode]
mg_needs_th_or_qq :: ModuleGraph -> Bool
mg_boot :: ModuleGraph -> ModuleSet
mg_non_boot :: ModuleGraph -> ModuleEnv ModSummary
mg_mss :: ModuleGraph -> [ModuleGraphNode]
..} ems :: ExtendedModSummary
ems@(ExtendedModSummary ModSummary
ms [InstantiatedUnit]
_) = ModuleGraph
  { mg_mss :: [ModuleGraphNode]
mg_mss = ExtendedModSummary -> ModuleGraphNode
ModuleNode ExtendedModSummary
ems ModuleGraphNode -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. a -> [a] -> [a]
: [ModuleGraphNode]
mg_mss
  , mg_non_boot :: ModuleEnv ModSummary
mg_non_boot = case ModSummary -> IsBootInterface
isBootSummary ModSummary
ms of
      IsBootInterface
IsBoot -> ModuleEnv ModSummary
mg_non_boot
      IsBootInterface
NotBoot -> ModuleEnv ModSummary
-> Module -> ModSummary -> ModuleEnv ModSummary
forall a. ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnv ModuleEnv ModSummary
mg_non_boot (ModSummary -> Module
ms_mod ModSummary
ms) ModSummary
ms
  , mg_boot :: ModuleSet
mg_boot = case ModSummary -> IsBootInterface
isBootSummary ModSummary
ms of
      IsBootInterface
NotBoot -> ModuleSet
mg_boot
      IsBootInterface
IsBoot -> ModuleSet -> Module -> ModuleSet
extendModuleSet ModuleSet
mg_boot (ModSummary -> Module
ms_mod ModSummary
ms)
  , mg_needs_th_or_qq :: Bool
mg_needs_th_or_qq = Bool
mg_needs_th_or_qq Bool -> Bool -> Bool
|| ModSummary -> Bool
isTemplateHaskellOrQQNonBoot ModSummary
ms
  }

extendMGInst :: ModuleGraph -> InstantiatedUnit -> ModuleGraph
extendMGInst :: ModuleGraph -> InstantiatedUnit -> ModuleGraph
extendMGInst ModuleGraph
mg InstantiatedUnit
depUnitId = ModuleGraph
mg
  { mg_mss :: [ModuleGraphNode]
mg_mss = InstantiatedUnit -> ModuleGraphNode
InstantiationNode InstantiatedUnit
depUnitId ModuleGraphNode -> [ModuleGraphNode] -> [ModuleGraphNode]
forall a. a -> [a] -> [a]
: ModuleGraph -> [ModuleGraphNode]
mg_mss ModuleGraph
mg
  }

extendMG' :: ModuleGraph -> ModuleGraphNode -> ModuleGraph
extendMG' :: ModuleGraph -> ModuleGraphNode -> ModuleGraph
extendMG' ModuleGraph
mg = \case
  InstantiationNode InstantiatedUnit
depUnitId -> ModuleGraph -> InstantiatedUnit -> ModuleGraph
extendMGInst ModuleGraph
mg InstantiatedUnit
depUnitId
  ModuleNode ExtendedModSummary
ems -> ModuleGraph -> ExtendedModSummary -> ModuleGraph
extendMG ModuleGraph
mg ExtendedModSummary
ems

mkModuleGraph :: [ExtendedModSummary] -> ModuleGraph
mkModuleGraph :: [ExtendedModSummary] -> ModuleGraph
mkModuleGraph = (ExtendedModSummary -> ModuleGraph -> ModuleGraph)
-> ModuleGraph -> [ExtendedModSummary] -> ModuleGraph
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((ModuleGraph -> ExtendedModSummary -> ModuleGraph)
-> ExtendedModSummary -> ModuleGraph -> ModuleGraph
forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleGraph -> ExtendedModSummary -> ModuleGraph
extendMG) ModuleGraph
emptyMG

mkModuleGraph' :: [ModuleGraphNode] -> ModuleGraph
mkModuleGraph' :: [ModuleGraphNode] -> ModuleGraph
mkModuleGraph' = (ModuleGraphNode -> ModuleGraph -> ModuleGraph)
-> ModuleGraph -> [ModuleGraphNode] -> ModuleGraph
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

-- | 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 ModSummary]
filterToposortToModules :: [SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules = (SCC ModuleGraphNode -> Maybe (SCC ModSummary))
-> [SCC ModuleGraphNode] -> [SCC ModSummary]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((SCC ModuleGraphNode -> Maybe (SCC ModSummary))
 -> [SCC ModuleGraphNode] -> [SCC ModSummary])
-> (SCC ModuleGraphNode -> Maybe (SCC ModSummary))
-> [SCC ModuleGraphNode]
-> [SCC ModSummary]
forall a b. (a -> b) -> a -> b
$ (ModuleGraphNode -> Maybe ModSummary)
-> SCC ModuleGraphNode -> Maybe (SCC ModSummary)
forall a b. (a -> Maybe b) -> SCC a -> Maybe (SCC b)
mapMaybeSCC ((ModuleGraphNode -> Maybe ModSummary)
 -> SCC ModuleGraphNode -> Maybe (SCC ModSummary))
-> (ModuleGraphNode -> Maybe ModSummary)
-> SCC ModuleGraphNode
-> Maybe (SCC ModSummary)
forall a b. (a -> b) -> a -> b
$ \case
  InstantiationNode InstantiatedUnit
_ -> Maybe ModSummary
forall a. Maybe a
Nothing
  ModuleNode (ExtendedModSummary ModSummary
node [InstantiatedUnit]
_) -> ModSummary -> Maybe ModSummary
forall a. a -> Maybe a
Just ModSummary
node
  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

showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc
showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc
showModMsg DynFlags
_ Bool
_ (InstantiationNode InstantiatedUnit
indef_unit) =
  Indefinite UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Indefinite UnitId -> SDoc) -> Indefinite UnitId -> SDoc
forall a b. (a -> b) -> a -> b
$ InstantiatedUnit -> Indefinite UnitId
forall unit. GenInstantiatedUnit unit -> Indefinite unit
instUnitInstanceOf InstantiatedUnit
indef_unit
showModMsg DynFlags
dflags Bool
recomp (ModuleNode (ExtendedModSummary ModSummary
mod_summary [InstantiatedUnit]
_)) =
  if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_HideSourcePaths DynFlags
dflags
      then String -> SDoc
text String
mod_str
      else [SDoc] -> SDoc
hsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$
         [ String -> SDoc
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 (t :: * -> *) a. Foldable t => t a -> Int
length String
mod_str)) Char
' ')
         , Char -> SDoc
char Char
'('
         , String -> SDoc
text (String -> String
op (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ModSummary -> String
msHsFilePath ModSummary
mod_summary) SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
','
         ] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
         if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildDynamicToo DynFlags
dflags
            then [ String -> SDoc
text String
obj_file SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
','
                 , String -> SDoc
text String
dyn_file
                 , Char -> SDoc
char Char
')'
                 ]
            else [ String -> SDoc
text String
obj_file, Char -> SDoc
char Char
')' ]
  where
    op :: String -> String
op       = String -> String
normalise
    mod :: ModuleName
mod      = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod_summary)
    mod_str :: String
mod_str  = DynFlags -> ModuleName -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags ModuleName
mod String -> String -> String
forall a. [a] -> [a] -> [a]
++ HscSource -> String
hscSourceString (ModSummary -> HscSource
ms_hsc_src ModSummary
mod_summary)
    dyn_file :: String
dyn_file = String -> String
op (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ModSummary -> DynFlags -> String
msDynObjFilePath ModSummary
mod_summary DynFlags
dflags
    obj_file :: String
obj_file = case DynFlags -> Backend
backend DynFlags
dflags of
                Backend
Interpreter | Bool
recomp -> String
"interpreted"
                Backend
NoBackend            -> String
"nothing"
                Backend
_                    -> (String -> String
op (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ModSummary -> String
msObjFilePath ModSummary
mod_summary)