-- | A 'HomeUnitGraph' (HUG) collects information about all the home units.
-- Crucially, each node in a 'HomeUnitGraph' includes a 'HomePackageTable'.
--
-- Often, we don't want to query just a single 'HomePackageTable', but rather all
-- 'HomePackageTable's of all home units.
--
-- This module is responsible for maintaining this bridge between querying all
-- home units vs querying the home package table directly. Think 'lookupHug' vs
-- 'lookupHpt', 'hugAllInstances' vs 'hptAllInstances', where the @hug@ version
-- replies with information from all home units, and the @hpt@ version with
-- information pertaining to a single home unit.
--
-- Meant to be imported qualified as @HUG@.
-- Example usage:
--
-- @
-- import GHC.Unit.Home.Graph (HomeUnitGraph, HomeUnitEnv)
-- import qualified GHC.Unit.Home.Graph as HUG
-- usage = ... HUG.insertHug hug uid modname modinfo ...
-- @
module GHC.Unit.Home.Graph
  ( HomeUnitGraph
  , HomeUnitEnv(..)
  , mkHomeUnitEnv

  -- * Operations
  , addHomeModInfoToHug
  , restrictHug
  , renameUnitId
  , allUnits
  , updateUnitFlags

  -- ** Lookups
  , lookupHug
  , lookupHugByModule
  , lookupHugUnit

  -- ** Reachability
  , transitiveHomeDeps

  -- * Very important queries
  , allInstances
  , allFamInstances
  , allAnns
  , allCompleteSigs

  -- * Utilities
  , hugSCCs
  , hugFromList

  -- ** Printing
  , pprHomeUnitGraph
  , pprHomeUnitEnv

  -- * Auxiliary internal structure
  , UnitEnvGraph(..)
  , unitEnv_lookup_maybe
  , unitEnv_foldWithKey
  , unitEnv_singleton
  , unitEnv_adjust
  , unitEnv_keys
  , unitEnv_insert
  , unitEnv_new
  , unitEnv_lookup
  ) where

import GHC.Prelude

import GHC.Driver.DynFlags
import GHC.Unit.Home
import GHC.Unit.Home.ModInfo
import GHC.Unit.Home.PackageTable
import GHC.Unit.Module
import GHC.Unit.Module.ModIface
import GHC.Unit.State
import GHC.Utils.Outputable
import GHC.Utils.Panic

import GHC.Core.FamInstEnv

import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import GHC.Data.Maybe
import GHC.Data.Graph.Directed

import GHC.Types.Annotations
import GHC.Types.CompleteMatch
import GHC.Core.InstEnv


-- | Get all 'CompleteMatches' (arising from COMPLETE pragmas) present across
-- all home units.
allCompleteSigs :: HomeUnitGraph -> IO CompleteMatches
allCompleteSigs :: HomeUnitGraph -> IO CompleteMatches
allCompleteSigs HomeUnitGraph
hug = (HomeUnitEnv -> IO CompleteMatches -> IO CompleteMatches)
-> IO CompleteMatches -> HomeUnitGraph -> IO CompleteMatches
forall a b. (a -> b -> b) -> b -> UnitEnvGraph a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HomeUnitEnv -> IO CompleteMatches -> IO CompleteMatches
go (CompleteMatches -> IO CompleteMatches
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) HomeUnitGraph
hug where
  go :: HomeUnitEnv -> IO CompleteMatches -> IO CompleteMatches
go HomeUnitEnv
hue = (CompleteMatches -> CompleteMatches -> CompleteMatches)
-> IO CompleteMatches -> IO CompleteMatches -> IO CompleteMatches
forall a b c. (a -> b -> c) -> IO a -> IO b -> IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 CompleteMatches -> CompleteMatches -> CompleteMatches
forall a. [a] -> [a] -> [a]
(++) (HomePackageTable -> IO CompleteMatches
hptCompleteSigs (HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt HomeUnitEnv
hue))

-- | Find all the instance declarations (of classes and families) from
-- the Home Package Table filtered by the provided predicate function.
-- Used in @tcRnImports@, to select the instances that are in the
-- transitive closure of imports from the currently compiled module.
allInstances :: HomeUnitGraph -> IO (InstEnv, [FamInst])
allInstances :: HomeUnitGraph -> IO (InstEnv, [FamInst])
allInstances HomeUnitGraph
hug = (HomeUnitEnv -> IO (InstEnv, [FamInst]) -> IO (InstEnv, [FamInst]))
-> IO (InstEnv, [FamInst])
-> HomeUnitGraph
-> IO (InstEnv, [FamInst])
forall a b. (a -> b -> b) -> b -> UnitEnvGraph a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HomeUnitEnv -> IO (InstEnv, [FamInst]) -> IO (InstEnv, [FamInst])
go ((InstEnv, [FamInst]) -> IO (InstEnv, [FamInst])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstEnv
emptyInstEnv, [])) HomeUnitGraph
hug where
  go :: HomeUnitEnv -> IO (InstEnv, [FamInst]) -> IO (InstEnv, [FamInst])
go HomeUnitEnv
hue = ((InstEnv, [FamInst])
 -> (InstEnv, [FamInst]) -> (InstEnv, [FamInst]))
-> IO (InstEnv, [FamInst])
-> IO (InstEnv, [FamInst])
-> IO (InstEnv, [FamInst])
forall a b c. (a -> b -> c) -> IO a -> IO b -> IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (\(InstEnv
a,[FamInst]
b) (InstEnv
a',[FamInst]
b') -> (InstEnv
a InstEnv -> InstEnv -> InstEnv
`unionInstEnv` InstEnv
a', [FamInst]
b [FamInst] -> [FamInst] -> [FamInst]
forall a. [a] -> [a] -> [a]
++ [FamInst]
b'))
                  (HomePackageTable -> IO (InstEnv, [FamInst])
hptAllInstances (HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt HomeUnitEnv
hue))

allFamInstances :: HomeUnitGraph -> IO (ModuleEnv FamInstEnv)
allFamInstances :: HomeUnitGraph -> IO (ModuleEnv FamInstEnv)
allFamInstances HomeUnitGraph
hug = (HomeUnitEnv
 -> IO (ModuleEnv FamInstEnv) -> IO (ModuleEnv FamInstEnv))
-> IO (ModuleEnv FamInstEnv)
-> HomeUnitGraph
-> IO (ModuleEnv FamInstEnv)
forall a b. (a -> b -> b) -> b -> UnitEnvGraph a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HomeUnitEnv
-> IO (ModuleEnv FamInstEnv) -> IO (ModuleEnv FamInstEnv)
go (ModuleEnv FamInstEnv -> IO (ModuleEnv FamInstEnv)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleEnv FamInstEnv
forall a. ModuleEnv a
emptyModuleEnv) HomeUnitGraph
hug where
  go :: HomeUnitEnv
-> IO (ModuleEnv FamInstEnv) -> IO (ModuleEnv FamInstEnv)
go HomeUnitEnv
hue = (ModuleEnv FamInstEnv
 -> ModuleEnv FamInstEnv -> ModuleEnv FamInstEnv)
-> IO (ModuleEnv FamInstEnv)
-> IO (ModuleEnv FamInstEnv)
-> IO (ModuleEnv FamInstEnv)
forall a b c. (a -> b -> c) -> IO a -> IO b -> IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ModuleEnv FamInstEnv
-> ModuleEnv FamInstEnv -> ModuleEnv FamInstEnv
forall a. ModuleEnv a -> ModuleEnv a -> ModuleEnv a
plusModuleEnv (HomePackageTable -> IO (ModuleEnv FamInstEnv)
hptAllFamInstances (HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt HomeUnitEnv
hue))

allAnns :: HomeUnitGraph -> IO AnnEnv
allAnns :: HomeUnitGraph -> IO AnnEnv
allAnns HomeUnitGraph
hug = (HomeUnitEnv -> IO AnnEnv -> IO AnnEnv)
-> IO AnnEnv -> HomeUnitGraph -> IO AnnEnv
forall a b. (a -> b -> b) -> b -> UnitEnvGraph a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HomeUnitEnv -> IO AnnEnv -> IO AnnEnv
go (AnnEnv -> IO AnnEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AnnEnv
emptyAnnEnv) HomeUnitGraph
hug where
  go :: HomeUnitEnv -> IO AnnEnv -> IO AnnEnv
go HomeUnitEnv
hue = (AnnEnv -> AnnEnv -> AnnEnv) -> IO AnnEnv -> IO AnnEnv -> IO AnnEnv
forall a b c. (a -> b -> c) -> IO a -> IO b -> IO c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 AnnEnv -> AnnEnv -> AnnEnv
plusAnnEnv (HomePackageTable -> IO AnnEnv
hptAllAnnotations (HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt HomeUnitEnv
hue))

--------------------------------------------------------------------------------
-- HomeUnitGraph (HUG)
--------------------------------------------------------------------------------

type HomeUnitGraph = UnitEnvGraph HomeUnitEnv

data HomeUnitEnv = HomeUnitEnv
  { HomeUnitEnv -> UnitState
homeUnitEnv_units     :: !UnitState
      -- ^ External units

  , HomeUnitEnv -> Maybe [UnitDatabase UnitId]
homeUnitEnv_unit_dbs :: !(Maybe [UnitDatabase UnitId])
      -- ^ Stack of unit databases for the target platform.
      --
      -- This field is populated with the result of `initUnits`.
      --
      -- 'Nothing' means the databases have never been read from disk.
      --
      -- Usually we don't reload the databases from disk if they are
      -- cached, even if the database flags changed!

  , HomeUnitEnv -> DynFlags
homeUnitEnv_dflags :: DynFlags
    -- ^ The dynamic flag settings
  , HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt :: HomePackageTable
    -- ^ The home package table describes already-compiled
    -- home-package modules, /excluding/ the module we
    -- are compiling right now.
    -- (In one-shot mode the current module is the only
    -- home-package module, so homeUnitEnv_hpt is empty.  All other
    -- modules count as \"external-package\" modules.
    -- However, even in GHCi mode, hi-boot interfaces are
    -- demand-loaded into the external-package table.)
    --
    -- 'homeUnitEnv_hpt' is not mutable because we only demand-load
    -- external packages; the home package is eagerly
    -- loaded, module by module, by the compilation manager.
    --
    -- The HPT may contain modules compiled earlier by @--make@
    -- but not actually below the current module in the dependency
    -- graph.
    --
    -- (This changes a previous invariant: changed Jan 05.)

  , HomeUnitEnv -> Maybe HomeUnit
homeUnitEnv_home_unit :: !(Maybe HomeUnit)
    -- ^ Home-unit
  }

mkHomeUnitEnv :: UnitState -> Maybe [UnitDatabase UnitId] -> DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv
mkHomeUnitEnv :: UnitState
-> Maybe [UnitDatabase UnitId]
-> DynFlags
-> HomePackageTable
-> Maybe HomeUnit
-> HomeUnitEnv
mkHomeUnitEnv UnitState
us Maybe [UnitDatabase UnitId]
dbs DynFlags
dflags HomePackageTable
hpt Maybe HomeUnit
home_unit = HomeUnitEnv
  { homeUnitEnv_units :: UnitState
homeUnitEnv_units = UnitState
us
  , homeUnitEnv_unit_dbs :: Maybe [UnitDatabase UnitId]
homeUnitEnv_unit_dbs = Maybe [UnitDatabase UnitId]
dbs
  , homeUnitEnv_dflags :: DynFlags
homeUnitEnv_dflags = DynFlags
dflags
  , homeUnitEnv_hpt :: HomePackageTable
homeUnitEnv_hpt = HomePackageTable
hpt
  , homeUnitEnv_home_unit :: Maybe HomeUnit
homeUnitEnv_home_unit = Maybe HomeUnit
home_unit
  }

--------------------------------------------------------------------------------
-- * Operations on HUG
--------------------------------------------------------------------------------

-- | Add an entry to the 'HomePackageTable' under the unit of that entry.
addHomeModInfoToHug :: HomeModInfo -> HomeUnitGraph -> IO ()
addHomeModInfoToHug :: HomeModInfo -> HomeUnitGraph -> IO ()
addHomeModInfoToHug HomeModInfo
hmi HomeUnitGraph
hug =
  case UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv
forall v. UnitId -> UnitEnvGraph v -> Maybe v
unitEnv_lookup_maybe UnitId
hmi_unit HomeUnitGraph
hug of
    Maybe HomeUnitEnv
Nothing -> String -> SDoc -> IO ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"addHomeInfoToHug" (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
hmi_mod)
    Just HomeUnitEnv
hue -> do
      HomeModInfo -> HomePackageTable -> IO ()
addHomeModInfoToHpt HomeModInfo
hmi (HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt HomeUnitEnv
hue)
  where
    hmi_mod :: Module
    hmi_mod :: Module
hmi_mod  = ModIface_ 'ModIfaceFinal -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module (HomeModInfo -> ModIface_ 'ModIfaceFinal
hm_iface HomeModInfo
hmi)
    hmi_unit :: UnitId
hmi_unit = Unit -> UnitId
toUnitId (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
hmi_mod)

-- | Thin each HPT variable to only contain keys from the given dependencies.
-- This is used at the end of upsweep to make sure that only completely successfully loaded
-- modules are visible for subsequent operations.
restrictHug :: [(UnitId, [HomeModInfo])] -> HomeUnitGraph -> IO ()
restrictHug :: [(UnitId, [HomeModInfo])] -> HomeUnitGraph -> IO ()
restrictHug [(UnitId, [HomeModInfo])]
deps HomeUnitGraph
hug = (IO () -> UnitId -> HomeUnitEnv -> IO ())
-> IO () -> HomeUnitGraph -> IO ()
forall b a. (b -> UnitId -> a -> b) -> b -> UnitEnvGraph a -> b
unitEnv_foldWithKey (\IO ()
k UnitId
uid HomeUnitEnv
hue -> UnitId -> HomeUnitEnv -> IO ()
restrict_one UnitId
uid HomeUnitEnv
hue IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
k) (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) HomeUnitGraph
hug
  where
    deps_map :: Map UnitId [HomeModInfo]
deps_map = [(UnitId, [HomeModInfo])] -> Map UnitId [HomeModInfo]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(UnitId, [HomeModInfo])]
deps
    restrict_one :: UnitId -> HomeUnitEnv -> IO ()
restrict_one UnitId
uid HomeUnitEnv
hue  =
      HomePackageTable -> [HomeModInfo] -> IO ()
restrictHpt (HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt HomeUnitEnv
hue) ([HomeModInfo]
-> UnitId -> Map UnitId [HomeModInfo] -> [HomeModInfo]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] UnitId
uid Map UnitId [HomeModInfo]
deps_map)

-- | Rename a unit id in the 'HomeUnitGraph'
--
-- @'renameUnitId' oldUnit newUnit hug@, if @oldUnit@ is not found in @hug@, returns 'Nothing'.
-- If it exists, the result maps @newUnit@ to the 'HomeUnitEnv' of the
-- @oldUnit@ (and @oldUnit@ is removed from @hug@)
renameUnitId :: UnitId -> UnitId -> HomeUnitGraph -> Maybe HomeUnitGraph
renameUnitId :: UnitId -> UnitId -> HomeUnitGraph -> Maybe HomeUnitGraph
renameUnitId UnitId
oldUnit UnitId
newUnit HomeUnitGraph
hug = case UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv
forall v. UnitId -> UnitEnvGraph v -> Maybe v
unitEnv_lookup_maybe UnitId
oldUnit HomeUnitGraph
hug of
  Maybe HomeUnitEnv
Nothing -> Maybe HomeUnitGraph
forall a. Maybe a
Nothing
  Just HomeUnitEnv
oldHue -> HomeUnitGraph -> Maybe HomeUnitGraph
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HomeUnitGraph -> Maybe HomeUnitGraph)
-> HomeUnitGraph -> Maybe HomeUnitGraph
forall a b. (a -> b) -> a -> b
$
    UnitId -> HomeUnitEnv -> HomeUnitGraph -> HomeUnitGraph
forall v. UnitId -> v -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_insert UnitId
newUnit HomeUnitEnv
oldHue (HomeUnitGraph -> HomeUnitGraph) -> HomeUnitGraph -> HomeUnitGraph
forall a b. (a -> b) -> a -> b
$
    UnitId -> HomeUnitGraph -> HomeUnitGraph
forall v. UnitId -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_delete UnitId
oldUnit HomeUnitGraph
hug

-- | Retrieve all 'UnitId's of units in the 'HomeUnitGraph'.
allUnits :: HomeUnitGraph -> Set.Set UnitId
allUnits :: HomeUnitGraph -> Set UnitId
allUnits = HomeUnitGraph -> Set UnitId
forall v. UnitEnvGraph v -> Set UnitId
unitEnv_keys

-- | Set the 'DynFlags' of the 'HomeUnitEnv' for unit in the 'HomeModuleGraph'
updateUnitFlags :: UnitId -> (DynFlags -> DynFlags) -> HomeUnitGraph -> HomeUnitGraph
updateUnitFlags :: UnitId -> (DynFlags -> DynFlags) -> HomeUnitGraph -> HomeUnitGraph
updateUnitFlags UnitId
uid DynFlags -> DynFlags
f = (HomeUnitEnv -> HomeUnitEnv)
-> UnitId -> HomeUnitGraph -> HomeUnitGraph
forall v. (v -> v) -> UnitId -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_adjust HomeUnitEnv -> HomeUnitEnv
update UnitId
uid
  where
    update :: HomeUnitEnv -> HomeUnitEnv
update HomeUnitEnv
hue = HomeUnitEnv
hue { homeUnitEnv_dflags = f (homeUnitEnv_dflags hue) }

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

-- | Compute the transitive closure of a unit in the 'HomeUnitGraph'.
-- If the argument unit is not present in the graph returns Nothing.
transitiveHomeDeps :: UnitId -> HomeUnitGraph -> Maybe [UnitId]
transitiveHomeDeps :: UnitId -> HomeUnitGraph -> Maybe [UnitId]
transitiveHomeDeps UnitId
uid HomeUnitGraph
hug = case UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv
lookupHugUnit UnitId
uid HomeUnitGraph
hug of
  Maybe HomeUnitEnv
Nothing -> Maybe [UnitId]
forall a. Maybe a
Nothing
  Just HomeUnitEnv
hue -> [UnitId] -> Maybe [UnitId]
forall a. a -> Maybe a
Just ([UnitId] -> Maybe [UnitId]) -> [UnitId] -> Maybe [UnitId]
forall a b. (a -> b) -> a -> b
$
    Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList (Set UnitId -> [UnitId] -> Set UnitId
loop (UnitId -> Set UnitId
forall a. a -> Set a
Set.singleton UnitId
uid) (UnitState -> [UnitId]
homeUnitDepends (HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
hue)))
    where
      loop :: Set UnitId -> [UnitId] -> Set UnitId
loop Set UnitId
acc [] = Set UnitId
acc
      loop Set UnitId
acc (UnitId
uid:[UnitId]
uids)
        | UnitId
uid UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UnitId
acc = Set UnitId -> [UnitId] -> Set UnitId
loop Set UnitId
acc [UnitId]
uids
        | Bool
otherwise =
          let hue :: [UnitId]
hue = UnitState -> [UnitId]
homeUnitDepends
                    (UnitState -> [UnitId])
-> (Maybe HomeUnitEnv -> UnitState)
-> Maybe HomeUnitEnv
-> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HomeUnitEnv -> UnitState
homeUnitEnv_units
                    (HomeUnitEnv -> UnitState)
-> (Maybe HomeUnitEnv -> HomeUnitEnv)
-> Maybe HomeUnitEnv
-> UnitState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe HomeUnitEnv -> HomeUnitEnv
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"transitiveHomeDeps: homeUnitDepends of unit not found in hug"
                    (Maybe HomeUnitEnv -> [UnitId]) -> Maybe HomeUnitEnv -> [UnitId]
forall a b. (a -> b) -> a -> b
$ UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv
lookupHugUnit UnitId
uid HomeUnitGraph
hug
          in Set UnitId -> [UnitId] -> Set UnitId
loop (UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => a -> Set a -> Set a
Set.insert UnitId
uid Set UnitId
acc) ([UnitId]
hue [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [UnitId]
uids)

--------------------------------------------------------------------------------
-- ** Lookups
--------------------------------------------------------------------------------

-- | Lookup the 'HomeModInfo' of a 'Module' in the 'HomeUnitGraph' given its
-- 'UnitId' and 'ModuleName' (via the 'HomePackageTable' of the corresponding unit)
lookupHug :: HomeUnitGraph -> UnitId -> ModuleName -> IO (Maybe HomeModInfo)
lookupHug :: HomeUnitGraph -> UnitId -> ModuleName -> IO (Maybe HomeModInfo)
lookupHug HomeUnitGraph
hug UnitId
uid ModuleName
mod = do
  case UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv
forall v. UnitId -> UnitEnvGraph v -> Maybe v
unitEnv_lookup_maybe UnitId
uid HomeUnitGraph
hug of
    -- Really, here we want "lookup HPT" rather than unitEnvLookup
    Maybe HomeUnitEnv
Nothing -> Maybe HomeModInfo -> IO (Maybe HomeModInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe HomeModInfo
forall a. Maybe a
Nothing
    Just HomeUnitEnv
hue -> HomePackageTable -> ModuleName -> IO (Maybe HomeModInfo)
lookupHpt (HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt HomeUnitEnv
hue) ModuleName
mod

-- | Lookup the 'HomeModInfo' of a 'Module' in the 'HomeUnitGraph' (via the 'HomePackageTable' of the corresponding unit)
lookupHugByModule :: Module -> HomeUnitGraph -> IO (Maybe HomeModInfo)
lookupHugByModule :: Module -> HomeUnitGraph -> IO (Maybe HomeModInfo)
lookupHugByModule Module
mod HomeUnitGraph
hug
  | Bool
otherwise = do
      case UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv
forall v. UnitId -> UnitEnvGraph v -> Maybe v
unitEnv_lookup_maybe (Unit -> UnitId
toUnitId (Unit -> UnitId) -> Unit -> UnitId
forall a b. (a -> b) -> a -> b
$ Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod) HomeUnitGraph
hug of
        Maybe HomeUnitEnv
Nothing -> Maybe HomeModInfo -> IO (Maybe HomeModInfo)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe HomeModInfo
forall a. Maybe a
Nothing
        Just HomeUnitEnv
env -> HomePackageTable -> Module -> IO (Maybe HomeModInfo)
lookupHptByModule (HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt HomeUnitEnv
env) Module
mod

-- | Lookup a 'HomeUnitEnv' by 'UnitId' in a 'HomeUnitGraph'
lookupHugUnit :: UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv
lookupHugUnit :: UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv
lookupHugUnit = UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv
forall v. UnitId -> UnitEnvGraph v -> Maybe v
unitEnv_lookup_maybe

--------------------------------------------------------------------------------
-- * Internal representation map
--------------------------------------------------------------------------------
-- Note: we purposefully do not export functions like "elems" to maintain a
-- good clean interface with the HUG.

type UnitEnvGraphKey = UnitId

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

unitEnv_new :: Map UnitEnvGraphKey v -> UnitEnvGraph v
unitEnv_new :: forall v. Map UnitId v -> UnitEnvGraph v
unitEnv_new Map UnitId v
m =
  UnitEnvGraph
    { unitEnv_graph :: Map UnitId v
unitEnv_graph = Map UnitId v
m
    }

unitEnv_insert :: UnitEnvGraphKey -> v -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_insert :: forall v. UnitId -> v -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_insert UnitId
unitId v
env UnitEnvGraph v
unitEnv = UnitEnvGraph v
unitEnv
  { unitEnv_graph = Map.insert unitId env (unitEnv_graph unitEnv)
  }

unitEnv_delete :: UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_delete :: forall v. UnitId -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_delete UnitId
uid UnitEnvGraph v
unitEnv =
    UnitEnvGraph v
unitEnv
      { unitEnv_graph = Map.delete uid (unitEnv_graph unitEnv)
      }

unitEnv_adjust :: (v -> v) -> UnitEnvGraphKey -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_adjust :: forall v. (v -> v) -> UnitId -> UnitEnvGraph v -> UnitEnvGraph v
unitEnv_adjust v -> v
f UnitId
uid UnitEnvGraph v
unitEnv = UnitEnvGraph v
unitEnv
  { unitEnv_graph = Map.adjust f uid (unitEnv_graph unitEnv)
  }

unitEnv_singleton :: UnitEnvGraphKey -> v -> UnitEnvGraph v
unitEnv_singleton :: forall v. UnitId -> v -> UnitEnvGraph v
unitEnv_singleton UnitId
active v
m = UnitEnvGraph
  { unitEnv_graph :: Map UnitId v
unitEnv_graph = UnitId -> v -> Map UnitId v
forall k a. k -> a -> Map k a
Map.singleton UnitId
active v
m
  }

unitEnv_lookup_maybe :: UnitEnvGraphKey -> UnitEnvGraph v -> Maybe v
unitEnv_lookup_maybe :: forall v. UnitId -> UnitEnvGraph v -> Maybe v
unitEnv_lookup_maybe UnitId
u UnitEnvGraph v
env = UnitId -> Map UnitId v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
u (UnitEnvGraph v -> Map UnitId v
forall v. UnitEnvGraph v -> Map UnitId v
unitEnv_graph UnitEnvGraph v
env)

unitEnv_keys :: UnitEnvGraph v -> Set.Set UnitEnvGraphKey
unitEnv_keys :: forall v. UnitEnvGraph v -> Set UnitId
unitEnv_keys UnitEnvGraph v
env = Map UnitId v -> Set UnitId
forall k a. Map k a -> Set k
Map.keysSet (UnitEnvGraph v -> Map UnitId v
forall v. UnitEnvGraph v -> Map UnitId v
unitEnv_graph UnitEnvGraph v
env)

unitEnv_foldWithKey :: (b -> UnitEnvGraphKey -> a -> b) -> b -> UnitEnvGraph a -> b
unitEnv_foldWithKey :: forall b a. (b -> UnitId -> a -> b) -> b -> UnitEnvGraph a -> b
unitEnv_foldWithKey b -> UnitId -> a -> b
f b
z (UnitEnvGraph Map UnitId a
g)= (b -> UnitId -> a -> b) -> b -> Map UnitId a -> b
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' b -> UnitId -> a -> b
f b
z Map UnitId a
g

unitEnv_lookup :: UnitEnvGraphKey -> UnitEnvGraph v -> v
unitEnv_lookup :: forall v. UnitId -> UnitEnvGraph v -> v
unitEnv_lookup UnitId
u UnitEnvGraph v
env = String -> Maybe v -> v
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"unitEnv_lookup" (Maybe v -> v) -> Maybe v -> v
forall a b. (a -> b) -> a -> b
$ UnitId -> UnitEnvGraph v -> Maybe v
forall v. UnitId -> UnitEnvGraph v -> Maybe v
unitEnv_lookup_maybe UnitId
u UnitEnvGraph v
env

--------------------------------------------------------------------------------
-- * Utilities
--------------------------------------------------------------------------------

hugSCCs :: HomeUnitGraph -> [SCC UnitId]
hugSCCs :: HomeUnitGraph -> [SCC UnitId]
hugSCCs HomeUnitGraph
hug = [SCC UnitId]
sccs where
  mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId
  mkNode :: (UnitId, HomeUnitEnv) -> Node UnitId UnitId
mkNode (UnitId
uid, HomeUnitEnv
hue) = UnitId -> UnitId -> [UnitId] -> Node UnitId UnitId
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode UnitId
uid UnitId
uid (UnitState -> [UnitId]
homeUnitDepends (HomeUnitEnv -> UnitState
homeUnitEnv_units HomeUnitEnv
hue))
  nodes :: [Node UnitId UnitId]
nodes = ((UnitId, HomeUnitEnv) -> Node UnitId UnitId)
-> [(UnitId, HomeUnitEnv)] -> [Node UnitId UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, HomeUnitEnv) -> Node UnitId UnitId
mkNode (Map UnitId HomeUnitEnv -> [(UnitId, HomeUnitEnv)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map UnitId HomeUnitEnv -> [(UnitId, HomeUnitEnv)])
-> Map UnitId HomeUnitEnv -> [(UnitId, HomeUnitEnv)]
forall a b. (a -> b) -> a -> b
$ HomeUnitGraph -> Map UnitId HomeUnitEnv
forall v. UnitEnvGraph v -> Map UnitId v
unitEnv_graph HomeUnitGraph
hug)

  sccs :: [SCC UnitId]
sccs = [Node UnitId UnitId] -> [SCC UnitId]
forall key payload. Ord key => [Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesOrd [Node UnitId UnitId]
nodes

hugFromList :: [(UnitId, HomeUnitEnv)] -> HomeUnitGraph
hugFromList :: [(UnitId, HomeUnitEnv)] -> HomeUnitGraph
hugFromList = Map UnitId HomeUnitEnv -> HomeUnitGraph
forall v. Map UnitId v -> UnitEnvGraph v
UnitEnvGraph (Map UnitId HomeUnitEnv -> HomeUnitGraph)
-> ([(UnitId, HomeUnitEnv)] -> Map UnitId HomeUnitEnv)
-> [(UnitId, HomeUnitEnv)]
-> HomeUnitGraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(UnitId, HomeUnitEnv)] -> Map UnitId HomeUnitEnv
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList

pprHomeUnitGraph :: HomeUnitGraph -> IO SDoc
pprHomeUnitGraph :: HomeUnitGraph -> IO SDoc
pprHomeUnitGraph HomeUnitGraph
unitEnv = do
  docs <- ((UnitId, HomeUnitEnv) -> IO SDoc)
-> [(UnitId, HomeUnitEnv)] -> IO [SDoc]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(UnitId
k, HomeUnitEnv
v) -> UnitId -> HomeUnitEnv -> IO SDoc
pprHomeUnitEnv UnitId
k HomeUnitEnv
v) ([(UnitId, HomeUnitEnv)] -> IO [SDoc])
-> [(UnitId, HomeUnitEnv)] -> IO [SDoc]
forall a b. (a -> b) -> a -> b
$ Map UnitId HomeUnitEnv -> [(UnitId, HomeUnitEnv)]
forall k a. Map k a -> [(k, a)]
Map.assocs (Map UnitId HomeUnitEnv -> [(UnitId, HomeUnitEnv)])
-> Map UnitId HomeUnitEnv -> [(UnitId, HomeUnitEnv)]
forall a b. (a -> b) -> a -> b
$ HomeUnitGraph -> Map UnitId HomeUnitEnv
forall v. UnitEnvGraph v -> Map UnitId v
unitEnv_graph HomeUnitGraph
unitEnv
  return $ vcat docs

pprHomeUnitEnv :: UnitId -> HomeUnitEnv -> IO SDoc
pprHomeUnitEnv :: UnitId -> HomeUnitEnv -> IO SDoc
pprHomeUnitEnv UnitId
uid HomeUnitEnv
env = do
  hptDoc <- HomePackageTable -> IO SDoc
pprHPT (HomePackageTable -> IO SDoc) -> HomePackageTable -> IO SDoc
forall a b. (a -> b) -> a -> b
$ HomeUnitEnv -> HomePackageTable
homeUnitEnv_hpt HomeUnitEnv
env
  return $
    ppr uid <+> text "(flags:" <+> ppr (homeUnitId_ $ homeUnitEnv_dflags env) <> text "," <+> ppr (fmap homeUnitId $ homeUnitEnv_home_unit env) <> text ")" <+> text "->"
    $$ nest 4 hptDoc