{-# 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
data ModuleGraphNode
= InstantiationNode InstantiatedUnit
| ModuleNode ExtendedModSummary
instance Outputable ModuleGraphNode where
ppr :: ModuleGraphNode -> SDoc
ppr = \case
InstantiationNode InstantiatedUnit
iuid -> forall a. Outputable a => a -> SDoc
ppr InstantiatedUnit
iuid
ModuleNode ExtendedModSummary
ems -> forall a. Outputable a => a -> SDoc
ppr ExtendedModSummary
ems
data ModuleGraph = ModuleGraph
{ ModuleGraph -> [ModuleGraphNode]
mg_mss :: [ModuleGraphNode]
, ModuleGraph -> ModuleEnv ModSummary
mg_non_boot :: !(ModuleEnv ModSummary)
, ModuleGraph -> ModuleSet
mg_boot :: !ModuleSet
, ModuleGraph -> Bool
mg_needs_th_or_qq :: !Bool
}
needsTemplateHaskellOrQQ :: ModuleGraph -> Bool
needsTemplateHaskellOrQQ :: ModuleGraph -> Bool
needsTemplateHaskellOrQQ ModuleGraph
mg = ModuleGraph -> Bool
mg_needs_th_or_qq ModuleGraph
mg
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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ModuleGraphNode]
mg_mss 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 = 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 = forall a. Module -> ModuleEnv a -> Bool
elemModuleEnv Module
m ModuleEnv ModSummary
mg_non_boot
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 = 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 [] 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 forall a. Eq a => a -> a -> Bool
== IsBootInterface
NotBoot)
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 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 -> 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 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleGraph -> ExtendedModSummary -> ModuleGraph
extendMG) ModuleGraph
emptyMG
mkModuleGraph' :: [ModuleGraphNode] -> ModuleGraph
mkModuleGraph' :: [ModuleGraphNode] -> ModuleGraph
mkModuleGraph' = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> b -> a -> c
flip ModuleGraph -> ModuleGraphNode -> ModuleGraph
extendMG') ModuleGraph
emptyMG
filterToposortToModules
:: [SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules :: [SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> SCC a -> Maybe (SCC b)
mapMaybeSCC forall a b. (a -> b) -> a -> b
$ \case
InstantiationNode InstantiatedUnit
_ -> forall a. Maybe a
Nothing
ModuleNode (ExtendedModSummary ModSummary
node [InstantiatedUnit]
_) -> forall a. a -> Maybe a
Just ModSummary
node
where
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 -> forall vertex. vertex -> SCC vertex
AcyclicSCC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe b
f a
a
CyclicSCC [a]
as -> case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe a -> Maybe b
f [a]
as of
[] -> forall a. Maybe a
Nothing
[b
a] -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall vertex. vertex -> SCC vertex
AcyclicSCC b
a
[b]
as -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> 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) =
forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$
[ String -> SDoc
text (String
mod_str forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (forall a. Ord a => a -> a -> a
max Int
0 (Int
16 forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
mod_str)) Char
' ')
, Char -> SDoc
char Char
'('
, String -> SDoc
text (String -> String
op forall a b. (a -> b) -> a -> b
$ ModSummary -> String
msHsFilePath ModSummary
mod_summary) SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
','
] 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 = forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
mod_summary)
mod_str :: String
mod_str = forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags ModuleName
mod forall a. [a] -> [a] -> [a]
++ HscSource -> String
hscSourceString (ModSummary -> HscSource
ms_hsc_src ModSummary
mod_summary)
dyn_file :: String
dyn_file = String -> String
op 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 forall a b. (a -> b) -> a -> b
$ ModSummary -> String
msObjFilePath ModSummary
mod_summary)