{-# LANGUAGE LambdaCase #-}
module GHC.Unit.State (
module GHC.Unit.Info,
UnitState(..),
PreloadUnitClosure,
UnitDatabase (..),
UnitErr (..),
emptyUnitState,
initUnits,
readUnitDatabases,
readUnitDatabase,
getUnitDbRefs,
resolveUnitDatabase,
listUnitInfo,
UnitInfoMap,
lookupUnit,
lookupUnit',
unsafeLookupUnit,
lookupUnitId,
lookupUnitId',
unsafeLookupUnitId,
lookupPackageName,
resolvePackageImport,
improveUnit,
searchPackageId,
listVisibleModuleNames,
lookupModuleInAllUnits,
lookupModuleWithSuggestions,
lookupModulePackage,
lookupPluginModuleWithSuggestions,
requirementMerges,
LookupResult(..),
ModuleSuggestion(..),
ModuleOrigin(..),
UnusableUnit(..),
UnusableUnitReason(..),
pprReason,
closeUnitDeps,
closeUnitDeps',
mayThrowUnitErr,
ShHoleSubst,
renameHoleUnit,
renameHoleModule,
renameHoleUnit',
renameHoleModule',
instUnitToUnit,
instModuleToModule,
pprFlag,
pprUnits,
pprUnitsSimple,
pprUnitIdForUser,
pprUnitInfoForUser,
pprModuleMap,
pprWithUnitState,
unwireUnit)
where
import GHC.Prelude
import GHC.Driver.DynFlags
import GHC.Platform
import GHC.Platform.Ways
import GHC.Unit.Database
import GHC.Unit.Info
import GHC.Unit.Ppr
import GHC.Unit.Types
import GHC.Unit.Module
import GHC.Unit.Home
import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
import GHC.Types.Unique.Set
import GHC.Types.Unique.DSet
import GHC.Types.Unique.Map
import GHC.Types.Unique
import GHC.Types.PkgQual
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable as Outputable
import GHC.Data.Maybe
import System.Environment ( getEnv )
import GHC.Data.FastString
import qualified GHC.Data.ShortText as ST
import GHC.Utils.Logger
import GHC.Utils.Error
import GHC.Utils.Exception
import System.Directory
import System.FilePath as FilePath
import Control.Monad
import Data.Graph (stronglyConnComp, SCC(..))
import Data.Char ( toUpper )
import Data.List ( intersperse, partition, sortBy, isSuffixOf, sortOn )
import Data.Set (Set)
import Data.Monoid (First(..))
import qualified Data.Semigroup as Semigroup
import qualified Data.Set as Set
import Control.Applicative
data ModuleOrigin =
ModHidden
| ModUnusable !UnusableUnit
| ModOrigin {
ModuleOrigin -> Maybe Bool
fromOrigUnit :: Maybe Bool
, ModuleOrigin -> [UnitInfo]
fromExposedReexport :: [UnitInfo]
, ModuleOrigin -> [UnitInfo]
fromHiddenReexport :: [UnitInfo]
, ModuleOrigin -> Bool
fromPackageFlag :: Bool
}
data UnusableUnit = UnusableUnit
{ UnusableUnit -> Unit
uuUnit :: !Unit
, UnusableUnit -> UnusableUnitReason
uuReason :: !UnusableUnitReason
, UnusableUnit -> Bool
uuIsReexport :: !Bool
}
instance Outputable ModuleOrigin where
ppr :: ModuleOrigin -> SDoc
ppr ModuleOrigin
ModHidden = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hidden module"
ppr (ModUnusable UnusableUnit
_) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"unusable module"
ppr (ModOrigin Maybe Bool
e [UnitInfo]
res [UnitInfo]
rhs Bool
f) = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma (
(case Maybe Bool
e of
Maybe Bool
Nothing -> []
Just Bool
False -> [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hidden package"]
Just Bool
True -> [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"exposed package"]) [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
(if [UnitInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitInfo]
res
then []
else [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"reexport by" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep ((UnitInfo -> SDoc) -> [UnitInfo] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Unit -> SDoc) -> (UnitInfo -> Unit) -> UnitInfo -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> Unit
mkUnit) [UnitInfo]
res)]) [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
(if [UnitInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitInfo]
rhs
then []
else [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"hidden reexport by" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
[SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
sep ((UnitInfo -> SDoc) -> [UnitInfo] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Unit -> SDoc) -> (UnitInfo -> Unit) -> UnitInfo -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> Unit
mkUnit) [UnitInfo]
res)]) [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
(if Bool
f then [String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"package flag"] else [])
))
fromExposedModules :: Bool -> ModuleOrigin
fromExposedModules :: Bool -> ModuleOrigin
fromExposedModules Bool
e = Maybe Bool -> [UnitInfo] -> [UnitInfo] -> Bool -> ModuleOrigin
ModOrigin (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
e) [] [] Bool
False
fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin
fromReexportedModules :: Bool -> UnitInfo -> ModuleOrigin
fromReexportedModules Bool
True UnitInfo
pkg = Maybe Bool -> [UnitInfo] -> [UnitInfo] -> Bool -> ModuleOrigin
ModOrigin Maybe Bool
forall a. Maybe a
Nothing [UnitInfo
pkg] [] Bool
False
fromReexportedModules Bool
False UnitInfo
pkg = Maybe Bool -> [UnitInfo] -> [UnitInfo] -> Bool -> ModuleOrigin
ModOrigin Maybe Bool
forall a. Maybe a
Nothing [] [UnitInfo
pkg] Bool
False
fromFlag :: ModuleOrigin
fromFlag :: ModuleOrigin
fromFlag = Maybe Bool -> [UnitInfo] -> [UnitInfo] -> Bool -> ModuleOrigin
ModOrigin Maybe Bool
forall a. Maybe a
Nothing [] [] Bool
True
instance Semigroup ModuleOrigin where
x :: ModuleOrigin
x@(ModOrigin Maybe Bool
e [UnitInfo]
res [UnitInfo]
rhs Bool
f) <> :: ModuleOrigin -> ModuleOrigin -> ModuleOrigin
<> y :: ModuleOrigin
y@(ModOrigin Maybe Bool
e' [UnitInfo]
res' [UnitInfo]
rhs' Bool
f') =
Maybe Bool -> [UnitInfo] -> [UnitInfo] -> Bool -> ModuleOrigin
ModOrigin (Maybe Bool -> Maybe Bool -> Maybe Bool
g Maybe Bool
e Maybe Bool
e') ([UnitInfo]
res [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ [UnitInfo]
res') ([UnitInfo]
rhs [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ [UnitInfo]
rhs') (Bool
f Bool -> Bool -> Bool
|| Bool
f')
where g :: Maybe Bool -> Maybe Bool -> Maybe Bool
g (Just Bool
b) (Just Bool
b')
| Bool
b Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b' = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
b
| Bool
otherwise = String -> SDoc -> Maybe Bool
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"ModOrigin: package both exposed/hidden" (SDoc -> Maybe Bool) -> SDoc -> Maybe Bool
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"x: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> ModuleOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleOrigin
x SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"y: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> ModuleOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleOrigin
y
g Maybe Bool
Nothing Maybe Bool
x = Maybe Bool
x
g Maybe Bool
x Maybe Bool
Nothing = Maybe Bool
x
ModuleOrigin
x <> ModuleOrigin
y = String -> SDoc -> ModuleOrigin
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"ModOrigin: module origin mismatch" (SDoc -> ModuleOrigin) -> SDoc -> ModuleOrigin
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"x: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> ModuleOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleOrigin
x SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"y: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> ModuleOrigin -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleOrigin
y
instance Monoid ModuleOrigin where
mempty :: ModuleOrigin
mempty = Maybe Bool -> [UnitInfo] -> [UnitInfo] -> Bool -> ModuleOrigin
ModOrigin Maybe Bool
forall a. Maybe a
Nothing [] [] Bool
False
mappend :: ModuleOrigin -> ModuleOrigin -> ModuleOrigin
mappend = ModuleOrigin -> ModuleOrigin -> ModuleOrigin
forall a. Semigroup a => a -> a -> a
(Semigroup.<>)
originVisible :: ModuleOrigin -> Bool
originVisible :: ModuleOrigin -> Bool
originVisible ModuleOrigin
ModHidden = Bool
False
originVisible (ModUnusable UnusableUnit
_) = Bool
False
originVisible (ModOrigin Maybe Bool
b [UnitInfo]
res [UnitInfo]
_ Bool
f) = Maybe Bool
b Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Bool -> Bool -> Bool
|| Bool -> Bool
not ([UnitInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitInfo]
res) Bool -> Bool -> Bool
|| Bool
f
originEmpty :: ModuleOrigin -> Bool
originEmpty :: ModuleOrigin -> Bool
originEmpty (ModOrigin Maybe Bool
Nothing [] [] Bool
False) = Bool
True
originEmpty ModuleOrigin
_ = Bool
False
type PreloadUnitClosure = UniqSet UnitId
type VisibilityMap = UniqMap Unit UnitVisibility
data UnitVisibility = UnitVisibility
{ UnitVisibility -> Bool
uv_expose_all :: Bool
, UnitVisibility -> [(ModuleName, ModuleName)]
uv_renamings :: [(ModuleName, ModuleName)]
, UnitVisibility -> First FastString
uv_package_name :: First FastString
, UnitVisibility -> UniqMap ModuleName (Set InstantiatedModule)
uv_requirements :: UniqMap ModuleName (Set InstantiatedModule)
, UnitVisibility -> Maybe PackageArg
uv_explicit :: Maybe PackageArg
}
instance Outputable UnitVisibility where
ppr :: UnitVisibility -> SDoc
ppr (UnitVisibility {
uv_expose_all :: UnitVisibility -> Bool
uv_expose_all = Bool
b,
uv_renamings :: UnitVisibility -> [(ModuleName, ModuleName)]
uv_renamings = [(ModuleName, ModuleName)]
rns,
uv_package_name :: UnitVisibility -> First FastString
uv_package_name = First Maybe FastString
mb_pn,
uv_requirements :: UnitVisibility -> UniqMap ModuleName (Set InstantiatedModule)
uv_requirements = UniqMap ModuleName (Set InstantiatedModule)
reqs,
uv_explicit :: UnitVisibility -> Maybe PackageArg
uv_explicit = Maybe PackageArg
explicit
}) = (Bool, [(ModuleName, ModuleName)], Maybe FastString,
UniqMap ModuleName (Set InstantiatedModule), Maybe PackageArg)
-> SDoc
forall a. Outputable a => a -> SDoc
ppr (Bool
b, [(ModuleName, ModuleName)]
rns, Maybe FastString
mb_pn, UniqMap ModuleName (Set InstantiatedModule)
reqs, Maybe PackageArg
explicit)
instance Semigroup UnitVisibility where
UnitVisibility
uv1 <> :: UnitVisibility -> UnitVisibility -> UnitVisibility
<> UnitVisibility
uv2
= UnitVisibility
{ uv_expose_all :: Bool
uv_expose_all = UnitVisibility -> Bool
uv_expose_all UnitVisibility
uv1 Bool -> Bool -> Bool
|| UnitVisibility -> Bool
uv_expose_all UnitVisibility
uv2
, uv_renamings :: [(ModuleName, ModuleName)]
uv_renamings = UnitVisibility -> [(ModuleName, ModuleName)]
uv_renamings UnitVisibility
uv1 [(ModuleName, ModuleName)]
-> [(ModuleName, ModuleName)] -> [(ModuleName, ModuleName)]
forall a. [a] -> [a] -> [a]
++ UnitVisibility -> [(ModuleName, ModuleName)]
uv_renamings UnitVisibility
uv2
, uv_package_name :: First FastString
uv_package_name = First FastString -> First FastString -> First FastString
forall a. Monoid a => a -> a -> a
mappend (UnitVisibility -> First FastString
uv_package_name UnitVisibility
uv1) (UnitVisibility -> First FastString
uv_package_name UnitVisibility
uv2)
, uv_requirements :: UniqMap ModuleName (Set InstantiatedModule)
uv_requirements = (Set InstantiatedModule
-> Set InstantiatedModule -> Set InstantiatedModule)
-> UniqMap ModuleName (Set InstantiatedModule)
-> UniqMap ModuleName (Set InstantiatedModule)
-> UniqMap ModuleName (Set InstantiatedModule)
forall a k.
(a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a
plusUniqMap_C Set InstantiatedModule
-> Set InstantiatedModule -> Set InstantiatedModule
forall a. Ord a => Set a -> Set a -> Set a
Set.union (UnitVisibility -> UniqMap ModuleName (Set InstantiatedModule)
uv_requirements UnitVisibility
uv2) (UnitVisibility -> UniqMap ModuleName (Set InstantiatedModule)
uv_requirements UnitVisibility
uv1)
, uv_explicit :: Maybe PackageArg
uv_explicit = UnitVisibility -> Maybe PackageArg
uv_explicit UnitVisibility
uv1 Maybe PackageArg -> Maybe PackageArg -> Maybe PackageArg
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> UnitVisibility -> Maybe PackageArg
uv_explicit UnitVisibility
uv2
}
instance Monoid UnitVisibility where
mempty :: UnitVisibility
mempty = UnitVisibility
{ uv_expose_all :: Bool
uv_expose_all = Bool
False
, uv_renamings :: [(ModuleName, ModuleName)]
uv_renamings = []
, uv_package_name :: First FastString
uv_package_name = Maybe FastString -> First FastString
forall a. Maybe a -> First a
First Maybe FastString
forall a. Maybe a
Nothing
, uv_requirements :: UniqMap ModuleName (Set InstantiatedModule)
uv_requirements = UniqMap ModuleName (Set InstantiatedModule)
forall k a. UniqMap k a
emptyUniqMap
, uv_explicit :: Maybe PackageArg
uv_explicit = Maybe PackageArg
forall a. Maybe a
Nothing
}
mappend :: UnitVisibility -> UnitVisibility -> UnitVisibility
mappend = UnitVisibility -> UnitVisibility -> UnitVisibility
forall a. Semigroup a => a -> a -> a
(Semigroup.<>)
data UnitConfig = UnitConfig
{ UnitConfig -> ArchOS
unitConfigPlatformArchOS :: !ArchOS
, UnitConfig -> Ways
unitConfigWays :: !Ways
, UnitConfig -> Bool
unitConfigAllowVirtual :: !Bool
, UnitConfig -> String
unitConfigProgramName :: !String
, UnitConfig -> String
unitConfigGlobalDB :: !FilePath
, UnitConfig -> String
unitConfigGHCDir :: !FilePath
, UnitConfig -> String
unitConfigDBName :: !String
, UnitConfig -> [UnitId]
unitConfigAutoLink :: ![UnitId]
, UnitConfig -> Bool
unitConfigDistrustAll :: !Bool
, UnitConfig -> Bool
unitConfigHideAll :: !Bool
, UnitConfig -> Bool
unitConfigHideAllPlugins :: !Bool
, UnitConfig -> Maybe [UnitDatabase UnitId]
unitConfigDBCache :: Maybe [UnitDatabase UnitId]
, UnitConfig -> [PackageDBFlag]
unitConfigFlagsDB :: [PackageDBFlag]
, UnitConfig -> [PackageFlag]
unitConfigFlagsExposed :: [PackageFlag]
, UnitConfig -> [IgnorePackageFlag]
unitConfigFlagsIgnored :: [IgnorePackageFlag]
, UnitConfig -> [TrustFlag]
unitConfigFlagsTrusted :: [TrustFlag]
, UnitConfig -> [PackageFlag]
unitConfigFlagsPlugins :: [PackageFlag]
, UnitConfig -> Set UnitId
unitConfigHomeUnits :: Set.Set UnitId
}
initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> UnitConfig
initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> Set UnitId -> UnitConfig
initUnitConfig DynFlags
dflags Maybe [UnitDatabase UnitId]
cached_dbs Set UnitId
home_units =
let !hu_id :: UnitId
hu_id = DynFlags -> UnitId
homeUnitId_ DynFlags
dflags
!hu_instanceof :: Maybe UnitId
hu_instanceof = DynFlags -> Maybe UnitId
homeUnitInstanceOf_ DynFlags
dflags
!hu_instantiations :: [(ModuleName, Module)]
hu_instantiations = DynFlags -> [(ModuleName, Module)]
homeUnitInstantiations_ DynFlags
dflags
autoLink :: [UnitId]
autoLink
| Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_AutoLinkPackages DynFlags
dflags) = []
| Bool
otherwise = (UnitId -> Bool) -> [UnitId] -> [UnitId]
forall a. (a -> Bool) -> [a] -> [a]
filter (UnitId
hu_id UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/=) [UnitId
ghcInternalUnitId, UnitId
rtsUnitId]
allow_virtual_units :: Bool
allow_virtual_units = case (Maybe UnitId
hu_instanceof, [(ModuleName, Module)]
hu_instantiations) of
(Just UnitId
u, [(ModuleName, Module)]
is) -> UnitId
u UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
hu_id Bool -> Bool -> Bool
&& ((ModuleName, Module) -> Bool) -> [(ModuleName, Module)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Module -> Bool
forall u. GenModule (GenUnit u) -> Bool
isHoleModule (Module -> Bool)
-> ((ModuleName, Module) -> Module) -> (ModuleName, Module) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, Module) -> Module
forall a b. (a, b) -> b
snd) [(ModuleName, Module)]
is
(Maybe UnitId, [(ModuleName, Module)])
_ -> Bool
False
in UnitConfig
{ unitConfigPlatformArchOS :: ArchOS
unitConfigPlatformArchOS = Platform -> ArchOS
platformArchOS (DynFlags -> Platform
targetPlatform DynFlags
dflags)
, unitConfigProgramName :: String
unitConfigProgramName = DynFlags -> String
programName DynFlags
dflags
, unitConfigWays :: Ways
unitConfigWays = DynFlags -> Ways
ways DynFlags
dflags
, unitConfigAllowVirtual :: Bool
unitConfigAllowVirtual = Bool
allow_virtual_units
, unitConfigGlobalDB :: String
unitConfigGlobalDB = DynFlags -> String
globalPackageDatabasePath DynFlags
dflags
, unitConfigGHCDir :: String
unitConfigGHCDir = DynFlags -> String
topDir DynFlags
dflags
, unitConfigDBName :: String
unitConfigDBName = String
"package.conf.d"
, unitConfigAutoLink :: [UnitId]
unitConfigAutoLink = [UnitId]
autoLink
, unitConfigDistrustAll :: Bool
unitConfigDistrustAll = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_DistrustAllPackages DynFlags
dflags
, unitConfigHideAll :: Bool
unitConfigHideAll = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_HideAllPackages DynFlags
dflags
, unitConfigHideAllPlugins :: Bool
unitConfigHideAllPlugins = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_HideAllPluginPackages DynFlags
dflags
, unitConfigDBCache :: Maybe [UnitDatabase UnitId]
unitConfigDBCache = Maybe [UnitDatabase UnitId]
cached_dbs
, unitConfigFlagsDB :: [PackageDBFlag]
unitConfigFlagsDB = (PackageDBFlag -> PackageDBFlag)
-> [PackageDBFlag] -> [PackageDBFlag]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe String -> PackageDBFlag -> PackageDBFlag
offsetPackageDb (DynFlags -> Maybe String
workingDirectory DynFlags
dflags)) ([PackageDBFlag] -> [PackageDBFlag])
-> [PackageDBFlag] -> [PackageDBFlag]
forall a b. (a -> b) -> a -> b
$ DynFlags -> [PackageDBFlag]
packageDBFlags DynFlags
dflags
, unitConfigFlagsExposed :: [PackageFlag]
unitConfigFlagsExposed = DynFlags -> [PackageFlag]
packageFlags DynFlags
dflags
, unitConfigFlagsIgnored :: [IgnorePackageFlag]
unitConfigFlagsIgnored = DynFlags -> [IgnorePackageFlag]
ignorePackageFlags DynFlags
dflags
, unitConfigFlagsTrusted :: [TrustFlag]
unitConfigFlagsTrusted = DynFlags -> [TrustFlag]
trustFlags DynFlags
dflags
, unitConfigFlagsPlugins :: [PackageFlag]
unitConfigFlagsPlugins = DynFlags -> [PackageFlag]
pluginPackageFlags DynFlags
dflags
, unitConfigHomeUnits :: Set UnitId
unitConfigHomeUnits = Set UnitId
home_units
}
where
offsetPackageDb :: Maybe FilePath -> PackageDBFlag -> PackageDBFlag
offsetPackageDb :: Maybe String -> PackageDBFlag -> PackageDBFlag
offsetPackageDb (Just String
offset) (PackageDB (PkgDbPath String
p)) | String -> Bool
isRelative String
p = PkgDbRef -> PackageDBFlag
PackageDB (String -> PkgDbRef
PkgDbPath (String
offset String -> String -> String
</> String
p))
offsetPackageDb Maybe String
_ PackageDBFlag
p = PackageDBFlag
p
type ModuleNameProvidersMap =
UniqMap ModuleName (UniqMap Module ModuleOrigin)
data UnitState = UnitState {
UnitState -> UnitInfoMap
unitInfoMap :: UnitInfoMap,
UnitState -> PreloadUnitClosure
preloadClosure :: PreloadUnitClosure,
UnitState -> UniqFM PackageName UnitId
packageNameMap :: UniqFM PackageName UnitId,
UnitState -> UniqMap UnitId UnitId
wireMap :: UniqMap UnitId UnitId,
UnitState -> UniqMap UnitId UnitId
unwireMap :: UniqMap UnitId UnitId,
UnitState -> [UnitId]
preloadUnits :: [UnitId],
UnitState -> [(Unit, Maybe PackageArg)]
explicitUnits :: [(Unit, Maybe PackageArg)],
UnitState -> [UnitId]
homeUnitDepends :: [UnitId],
UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap :: !ModuleNameProvidersMap,
UnitState -> ModuleNameProvidersMap
pluginModuleNameProvidersMap :: !ModuleNameProvidersMap,
UnitState -> UniqMap ModuleName [InstantiatedModule]
requirementContext :: UniqMap ModuleName [InstantiatedModule],
UnitState -> Bool
allowVirtualUnits :: !Bool
}
emptyUnitState :: UnitState
emptyUnitState :: UnitState
emptyUnitState = UnitState {
unitInfoMap :: UnitInfoMap
unitInfoMap = UnitInfoMap
forall k a. UniqMap k a
emptyUniqMap,
preloadClosure :: PreloadUnitClosure
preloadClosure = PreloadUnitClosure
forall a. UniqSet a
emptyUniqSet,
packageNameMap :: UniqFM PackageName UnitId
packageNameMap = UniqFM PackageName UnitId
forall {k} (key :: k) elt. UniqFM key elt
emptyUFM,
wireMap :: UniqMap UnitId UnitId
wireMap = UniqMap UnitId UnitId
forall k a. UniqMap k a
emptyUniqMap,
unwireMap :: UniqMap UnitId UnitId
unwireMap = UniqMap UnitId UnitId
forall k a. UniqMap k a
emptyUniqMap,
preloadUnits :: [UnitId]
preloadUnits = [],
explicitUnits :: [(Unit, Maybe PackageArg)]
explicitUnits = [],
homeUnitDepends :: [UnitId]
homeUnitDepends = [],
moduleNameProvidersMap :: ModuleNameProvidersMap
moduleNameProvidersMap = ModuleNameProvidersMap
forall k a. UniqMap k a
emptyUniqMap,
pluginModuleNameProvidersMap :: ModuleNameProvidersMap
pluginModuleNameProvidersMap = ModuleNameProvidersMap
forall k a. UniqMap k a
emptyUniqMap,
requirementContext :: UniqMap ModuleName [InstantiatedModule]
requirementContext = UniqMap ModuleName [InstantiatedModule]
forall k a. UniqMap k a
emptyUniqMap,
allowVirtualUnits :: Bool
allowVirtualUnits = Bool
False
}
data UnitDatabase unit = UnitDatabase
{ forall unit. UnitDatabase unit -> String
unitDatabasePath :: FilePath
, forall unit. UnitDatabase unit -> [GenUnitInfo unit]
unitDatabaseUnits :: [GenUnitInfo unit]
}
instance Outputable u => Outputable (UnitDatabase u) where
ppr :: UnitDatabase u -> SDoc
ppr (UnitDatabase String
fp [GenUnitInfo u]
_u) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"DB:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
fp
type UnitInfoMap = UniqMap UnitId UnitInfo
lookupUnit :: UnitState -> Unit -> Maybe UnitInfo
lookupUnit :: UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
pkgs = Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo
lookupUnit' (UnitState -> Bool
allowVirtualUnits UnitState
pkgs) (UnitState -> UnitInfoMap
unitInfoMap UnitState
pkgs) (UnitState -> PreloadUnitClosure
preloadClosure UnitState
pkgs)
lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo
lookupUnit' :: Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo
lookupUnit' Bool
allowOnTheFlyInst UnitInfoMap
pkg_map PreloadUnitClosure
closure Unit
u = case Unit
u of
Unit
HoleUnit -> String -> Maybe UnitInfo
forall a. HasCallStack => String -> a
error String
"Hole unit"
RealUnit Definite UnitId
i -> UnitInfoMap -> UnitId -> Maybe UnitInfo
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UnitInfoMap
pkg_map (Definite UnitId -> UnitId
forall unit. Definite unit -> unit
unDefinite Definite UnitId
i)
VirtUnit GenInstantiatedUnit UnitId
i
| Bool
allowOnTheFlyInst
->
(UnitInfo -> UnitInfo) -> Maybe UnitInfo -> Maybe UnitInfo
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UnitInfoMap
-> PreloadUnitClosure
-> [(ModuleName, Module)]
-> UnitInfo
-> UnitInfo
renameUnitInfo UnitInfoMap
pkg_map PreloadUnitClosure
closure (GenInstantiatedUnit UnitId -> [(ModuleName, Module)]
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit UnitId
i))
(UnitInfoMap -> UnitId -> Maybe UnitInfo
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UnitInfoMap
pkg_map (GenInstantiatedUnit UnitId -> UnitId
forall unit. GenInstantiatedUnit unit -> unit
instUnitInstanceOf GenInstantiatedUnit UnitId
i))
| Bool
otherwise
->
UnitInfoMap -> UnitId -> Maybe UnitInfo
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UnitInfoMap
pkg_map (GenInstantiatedUnit UnitId -> UnitId
virtualUnitId GenInstantiatedUnit UnitId
i)
lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo
lookupUnitId :: UnitState -> UnitId -> Maybe UnitInfo
lookupUnitId UnitState
state UnitId
uid = UnitInfoMap -> UnitId -> Maybe UnitInfo
lookupUnitId' (UnitState -> UnitInfoMap
unitInfoMap UnitState
state) UnitId
uid
lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo
lookupUnitId' :: UnitInfoMap -> UnitId -> Maybe UnitInfo
lookupUnitId' UnitInfoMap
db UnitId
uid = UnitInfoMap -> UnitId -> Maybe UnitInfo
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UnitInfoMap
db UnitId
uid
unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo
unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo
unsafeLookupUnit UnitState
state Unit
u = case UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
state Unit
u of
Just UnitInfo
info -> UnitInfo
info
Maybe UnitInfo
Nothing -> String -> SDoc -> UnitInfo
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unsafeLookupUnit" (Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unit
u)
unsafeLookupUnitId :: HasDebugCallStack => UnitState -> UnitId -> UnitInfo
unsafeLookupUnitId :: HasDebugCallStack => UnitState -> UnitId -> UnitInfo
unsafeLookupUnitId UnitState
state UnitId
uid = case UnitState -> UnitId -> Maybe UnitInfo
lookupUnitId UnitState
state UnitId
uid of
Just UnitInfo
info -> UnitInfo
info
Maybe UnitInfo
Nothing -> String -> SDoc -> UnitInfo
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unsafeLookupUnitId" (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
uid)
lookupPackageName :: UnitState -> PackageName -> Maybe UnitId
lookupPackageName :: UnitState -> PackageName -> Maybe UnitId
lookupPackageName UnitState
pkgstate PackageName
n = UniqFM PackageName UnitId -> PackageName -> Maybe UnitId
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (UnitState -> UniqFM PackageName UnitId
packageNameMap UnitState
pkgstate) PackageName
n
searchPackageId :: UnitState -> PackageId -> [UnitInfo]
searchPackageId :: UnitState -> PackageId -> [UnitInfo]
searchPackageId UnitState
pkgstate PackageId
pid = (UnitInfo -> Bool) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter ((PackageId
pid PackageId -> PackageId -> Bool
forall a. Eq a => a -> a -> Bool
==) (PackageId -> Bool) -> (UnitInfo -> PackageId) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> PackageId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> srcpkgid
unitPackageId)
(UnitState -> [UnitInfo]
listUnitInfo UnitState
pkgstate)
resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
resolvePackageImport UnitState
unit_st ModuleName
mn PackageName
pn = do
providers <- (ModuleOrigin -> Bool)
-> UniqMap Module ModuleOrigin -> UniqMap Module ModuleOrigin
forall a k. (a -> Bool) -> UniqMap k a -> UniqMap k a
filterUniqMap ModuleOrigin -> Bool
originVisible (UniqMap Module ModuleOrigin -> UniqMap Module ModuleOrigin)
-> Maybe (UniqMap Module ModuleOrigin)
-> Maybe (UniqMap Module ModuleOrigin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModuleNameProvidersMap
-> ModuleName -> Maybe (UniqMap Module ModuleOrigin)
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap (UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap UnitState
unit_st) ModuleName
mn
let candidates_uid = ((Module, ModuleOrigin) -> [UnitId])
-> [(Module, ModuleOrigin)] -> [UnitId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Module, ModuleOrigin) -> [UnitId]
to_uid ([(Module, ModuleOrigin)] -> [UnitId])
-> [(Module, ModuleOrigin)] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ ((Module, ModuleOrigin) -> Module)
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Module, ModuleOrigin) -> Module
forall a b. (a, b) -> a
fst ([(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)])
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall a b. (a -> b) -> a -> b
$ UniqMap Module ModuleOrigin -> [(Module, ModuleOrigin)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UniqMap Module ModuleOrigin
providers
let candidates_units = (UnitInfo -> (PackageName, UnitId))
-> [UnitInfo] -> [(PackageName, UnitId)]
forall a b. (a -> b) -> [a] -> [b]
map (\UnitInfo
ui -> ((UnitInfo -> PackageName
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName UnitInfo
ui), UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
ui))
([UnitInfo] -> [(PackageName, UnitId)])
-> [UnitInfo] -> [(PackageName, UnitId)]
forall a b. (a -> b) -> a -> b
$ (UnitId -> Maybe UnitInfo) -> [UnitId] -> [UnitInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\UnitId
uid -> UnitInfoMap -> UnitId -> Maybe UnitInfo
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap (UnitState -> UnitInfoMap
unitInfoMap UnitState
unit_st) UnitId
uid) [UnitId]
candidates_uid
lookup pn candidates_units
where
to_uid :: (Module, ModuleOrigin) -> [UnitId]
to_uid :: (Module, ModuleOrigin) -> [UnitId]
to_uid (Module
mod, ModOrigin Maybe Bool
mo [UnitInfo]
re_exps [UnitInfo]
_ Bool
_) =
case Maybe Bool
mo of
Just Bool
True -> (Unit -> UnitId
toUnitId (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
mod)) UnitId -> [UnitId] -> [UnitId]
forall a. a -> [a] -> [a]
: (UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
re_exps
Maybe Bool
_ -> (UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
re_exps
to_uid (Module, ModuleOrigin)
_ = []
mkUnitInfoMap :: [UnitInfo] -> UnitInfoMap
mkUnitInfoMap :: [UnitInfo] -> UnitInfoMap
mkUnitInfoMap [UnitInfo]
infos = (UnitInfoMap -> UnitInfo -> UnitInfoMap)
-> UnitInfoMap -> [UnitInfo] -> UnitInfoMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UnitInfoMap -> UnitInfo -> UnitInfoMap
forall {srcpkgid} {srcpkgname}.
UniqMap
UnitId
(GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module)
-> GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
-> UniqMap
UnitId
(GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module)
add UnitInfoMap
forall k a. UniqMap k a
emptyUniqMap [UnitInfo]
infos
where
mkVirt :: GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
-> UnitId
mkVirt GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
p = GenInstantiatedUnit UnitId -> UnitId
virtualUnitId (UnitId -> [(ModuleName, Module)] -> GenInstantiatedUnit UnitId
forall u.
IsUnitId u =>
u -> GenInstantiations u -> GenInstantiatedUnit u
mkInstantiatedUnit (GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
-> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitInstanceOf GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
p) (GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
-> [(ModuleName, Module)]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [(modulename, mod)]
unitInstantiations GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
p))
add :: UniqMap
UnitId
(GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module)
-> GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
-> UniqMap
UnitId
(GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module)
add UniqMap
UnitId
(GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module)
pkg_map GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
p
| Bool -> Bool
not ([(ModuleName, Module)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
-> [(ModuleName, Module)]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [(modulename, mod)]
unitInstantiations GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
p))
= UniqMap
UnitId
(GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module)
-> UnitId
-> GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
-> UniqMap
UnitId
(GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module)
forall k a. Uniquable k => UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap (UniqMap
UnitId
(GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module)
-> UnitId
-> GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
-> UniqMap
UnitId
(GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module)
forall k a. Uniquable k => UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap UniqMap
UnitId
(GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module)
pkg_map (GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
-> UnitId
forall {srcpkgid} {srcpkgname}.
GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
-> UnitId
mkVirt GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
p) GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
p)
(GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
-> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
p) GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
p
| Bool
otherwise
= UniqMap
UnitId
(GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module)
-> UnitId
-> GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
-> UniqMap
UnitId
(GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module)
forall k a. Uniquable k => UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap UniqMap
UnitId
(GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module)
pkg_map (GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
-> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
p) GenericUnitInfo srcpkgid srcpkgname UnitId ModuleName Module
p
listUnitInfo :: UnitState -> [UnitInfo]
listUnitInfo :: UnitState -> [UnitInfo]
listUnitInfo UnitState
state = UnitInfoMap -> [UnitInfo]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap (UnitState -> UnitInfoMap
unitInfoMap UnitState
state)
initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
initUnits :: Logger
-> DynFlags
-> Maybe [UnitDatabase UnitId]
-> Set UnitId
-> IO
([UnitDatabase UnitId], UnitState, HomeUnit,
Maybe PlatformConstants)
initUnits Logger
logger DynFlags
dflags Maybe [UnitDatabase UnitId]
cached_dbs Set UnitId
home_units = do
let forceUnitInfoMap :: (UnitState, b) -> ()
forceUnitInfoMap (UnitState
state, b
_) = UnitState -> UnitInfoMap
unitInfoMap UnitState
state UnitInfoMap -> () -> ()
forall a b. a -> b -> b
`seq` ()
(unit_state,dbs) <- Logger
-> SDoc
-> ((UnitState, [UnitDatabase UnitId]) -> ())
-> IO (UnitState, [UnitDatabase UnitId])
-> IO (UnitState, [UnitDatabase UnitId])
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"initializing unit database")
(UnitState, [UnitDatabase UnitId]) -> ()
forall {b}. (UnitState, b) -> ()
forceUnitInfoMap
(IO (UnitState, [UnitDatabase UnitId])
-> IO (UnitState, [UnitDatabase UnitId]))
-> IO (UnitState, [UnitDatabase UnitId])
-> IO (UnitState, [UnitDatabase UnitId])
forall a b. (a -> b) -> a -> b
$ Logger -> UnitConfig -> IO (UnitState, [UnitDatabase UnitId])
mkUnitState Logger
logger (DynFlags -> Maybe [UnitDatabase UnitId] -> Set UnitId -> UnitConfig
initUnitConfig DynFlags
dflags Maybe [UnitDatabase UnitId]
cached_dbs Set UnitId
home_units)
putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
FormatText (updSDocContext (\SDocContext
ctx -> SDocContext
ctx {sdocLineLength = 200})
$ pprModuleMap (moduleNameProvidersMap unit_state))
let home_unit = UnitState
-> UnitId -> Maybe UnitId -> [(ModuleName, Module)] -> HomeUnit
mkHomeUnit UnitState
unit_state
(DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
(DynFlags -> Maybe UnitId
homeUnitInstanceOf_ DynFlags
dflags)
(DynFlags -> [(ModuleName, Module)]
homeUnitInstantiations_ DynFlags
dflags)
mconstants <- if homeUnitId_ dflags == rtsUnitId
then do
lookupPlatformConstants (includePathsGlobal (includePaths dflags))
else
case lookupUnitId unit_state rtsUnitId of
Maybe UnitInfo
Nothing -> Maybe PlatformConstants -> IO (Maybe PlatformConstants)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PlatformConstants
forall a. Maybe a
Nothing
Just UnitInfo
info -> [String] -> IO (Maybe PlatformConstants)
lookupPlatformConstants ((ShortText -> String) -> [ShortText] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShortText -> String
ST.unpack (UnitInfo -> [ShortText]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitIncludeDirs UnitInfo
info))
return (dbs,unit_state,home_unit,mconstants)
mkHomeUnit
:: UnitState
-> UnitId
-> Maybe UnitId
-> [(ModuleName, Module)]
-> HomeUnit
mkHomeUnit :: UnitState
-> UnitId -> Maybe UnitId -> [(ModuleName, Module)] -> HomeUnit
mkHomeUnit UnitState
unit_state UnitId
hu_id Maybe UnitId
hu_instanceof [(ModuleName, Module)]
hu_instantiations_ =
let
wmap :: UniqMap UnitId UnitId
wmap = UnitState -> UniqMap UnitId UnitId
wireMap UnitState
unit_state
hu_instantiations :: [(ModuleName, Module)]
hu_instantiations = ((ModuleName, Module) -> (ModuleName, Module))
-> [(ModuleName, Module)] -> [(ModuleName, Module)]
forall a b. (a -> b) -> [a] -> [b]
map ((Module -> Module) -> (ModuleName, Module) -> (ModuleName, Module)
forall a b. (a -> b) -> (ModuleName, a) -> (ModuleName, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UniqMap UnitId UnitId -> Module -> Module
upd_wired_in_mod UniqMap UnitId UnitId
wmap)) [(ModuleName, Module)]
hu_instantiations_
in case (Maybe UnitId
hu_instanceof, [(ModuleName, Module)]
hu_instantiations) of
(Maybe UnitId
Nothing,[]) -> UnitId -> Maybe (UnitId, [(ModuleName, Module)]) -> HomeUnit
forall u. UnitId -> Maybe (u, GenInstantiations u) -> GenHomeUnit u
DefiniteHomeUnit UnitId
hu_id Maybe (UnitId, [(ModuleName, Module)])
forall a. Maybe a
Nothing
(Maybe UnitId
Nothing, [(ModuleName, Module)]
_) -> GhcException -> HomeUnit
forall a. GhcException -> a
throwGhcException (GhcException -> HomeUnit) -> GhcException -> HomeUnit
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError (String
"Use of -instantiated-with requires -this-component-id")
(Just UnitId
_, []) -> GhcException -> HomeUnit
forall a. GhcException -> a
throwGhcException (GhcException -> HomeUnit) -> GhcException -> HomeUnit
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError (String
"Use of -this-component-id requires -instantiated-with")
(Just UnitId
u, [(ModuleName, Module)]
is)
| ((ModuleName, Module) -> Bool) -> [(ModuleName, Module)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Module -> Bool
forall u. GenModule (GenUnit u) -> Bool
isHoleModule (Module -> Bool)
-> ((ModuleName, Module) -> Module) -> (ModuleName, Module) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, Module) -> Module
forall a b. (a, b) -> b
snd) [(ModuleName, Module)]
is Bool -> Bool -> Bool
&& UnitId
u UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
hu_id
-> UnitId -> [(ModuleName, Module)] -> HomeUnit
forall u. UnitId -> GenInstantiations u -> GenHomeUnit u
IndefiniteHomeUnit UnitId
u [(ModuleName, Module)]
is
| Bool
otherwise
-> UnitId -> Maybe (UnitId, [(ModuleName, Module)]) -> HomeUnit
forall u. UnitId -> Maybe (u, GenInstantiations u) -> GenHomeUnit u
DefiniteHomeUnit UnitId
hu_id ((UnitId, [(ModuleName, Module)])
-> Maybe (UnitId, [(ModuleName, Module)])
forall a. a -> Maybe a
Just (UnitId
u, [(ModuleName, Module)]
is))
readUnitDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId]
readUnitDatabases :: Logger -> UnitConfig -> IO [UnitDatabase UnitId]
readUnitDatabases Logger
logger UnitConfig
cfg = do
conf_refs <- UnitConfig -> IO [PkgDbRef]
getUnitDbRefs UnitConfig
cfg
confs <- liftM catMaybes $ mapM (resolveUnitDatabase cfg) conf_refs
mapM (readUnitDatabase logger cfg) confs
getUnitDbRefs :: UnitConfig -> IO [PkgDbRef]
getUnitDbRefs :: UnitConfig -> IO [PkgDbRef]
getUnitDbRefs UnitConfig
cfg = do
let system_conf_refs :: [PkgDbRef]
system_conf_refs = [PkgDbRef
UserPkgDb, PkgDbRef
GlobalPkgDb]
e_pkg_path <- IO String -> IO (Either IOException String)
forall a. IO a -> IO (Either IOException a)
tryIO (String -> IO String
getEnv (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper (UnitConfig -> String
unitConfigProgramName UnitConfig
cfg) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_PACKAGE_PATH")
let base_conf_refs = case Either IOException String
e_pkg_path of
Left IOException
_ -> [PkgDbRef]
system_conf_refs
Right String
path
| Just (String
xs, Char
x) <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
snocView String
path, Char -> Bool
isSearchPathSeparator Char
x
-> (String -> PkgDbRef) -> [String] -> [PkgDbRef]
forall a b. (a -> b) -> [a] -> [b]
map String -> PkgDbRef
PkgDbPath (String -> [String]
splitSearchPath String
xs) [PkgDbRef] -> [PkgDbRef] -> [PkgDbRef]
forall a. [a] -> [a] -> [a]
++ [PkgDbRef]
system_conf_refs
| Bool
otherwise
-> (String -> PkgDbRef) -> [String] -> [PkgDbRef]
forall a b. (a -> b) -> [a] -> [b]
map String -> PkgDbRef
PkgDbPath (String -> [String]
splitSearchPath String
path)
return $ reverse (foldr doFlag base_conf_refs (unitConfigFlagsDB cfg))
where
doFlag :: PackageDBFlag -> [PkgDbRef] -> [PkgDbRef]
doFlag (PackageDB PkgDbRef
p) [PkgDbRef]
dbs = PkgDbRef
p PkgDbRef -> [PkgDbRef] -> [PkgDbRef]
forall a. a -> [a] -> [a]
: [PkgDbRef]
dbs
doFlag PackageDBFlag
NoUserPackageDB [PkgDbRef]
dbs = (PkgDbRef -> Bool) -> [PkgDbRef] -> [PkgDbRef]
forall a. (a -> Bool) -> [a] -> [a]
filter PkgDbRef -> Bool
isNotUser [PkgDbRef]
dbs
doFlag PackageDBFlag
NoGlobalPackageDB [PkgDbRef]
dbs = (PkgDbRef -> Bool) -> [PkgDbRef] -> [PkgDbRef]
forall a. (a -> Bool) -> [a] -> [a]
filter PkgDbRef -> Bool
isNotGlobal [PkgDbRef]
dbs
doFlag PackageDBFlag
ClearPackageDBs [PkgDbRef]
_ = []
isNotUser :: PkgDbRef -> Bool
isNotUser PkgDbRef
UserPkgDb = Bool
False
isNotUser PkgDbRef
_ = Bool
True
isNotGlobal :: PkgDbRef -> Bool
isNotGlobal PkgDbRef
GlobalPkgDb = Bool
False
isNotGlobal PkgDbRef
_ = Bool
True
resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe FilePath)
resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe String)
resolveUnitDatabase UnitConfig
cfg PkgDbRef
GlobalPkgDb = Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (UnitConfig -> String
unitConfigGlobalDB UnitConfig
cfg)
resolveUnitDatabase UnitConfig
cfg PkgDbRef
UserPkgDb = MaybeT IO String -> IO (Maybe String)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO String -> IO (Maybe String))
-> MaybeT IO String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
dir <- String -> ArchOS -> MaybeT IO String
versionedAppDir (UnitConfig -> String
unitConfigProgramName UnitConfig
cfg) (UnitConfig -> ArchOS
unitConfigPlatformArchOS UnitConfig
cfg)
let pkgconf = String
dir String -> String -> String
</> UnitConfig -> String
unitConfigDBName UnitConfig
cfg
exist <- tryMaybeT $ doesDirectoryExist pkgconf
if exist then return pkgconf else mzero
resolveUnitDatabase UnitConfig
_ (PkgDbPath String
name) = Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
name
readUnitDatabase :: Logger -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId)
readUnitDatabase :: Logger -> UnitConfig -> String -> IO (UnitDatabase UnitId)
readUnitDatabase Logger
logger UnitConfig
cfg String
conf_file = do
isdir <- String -> IO Bool
doesDirectoryExist String
conf_file
proto_pkg_configs <-
if isdir
then readDirStyleUnitInfo conf_file
else do
isfile <- doesFileExist conf_file
if isfile
then do
mpkgs <- tryReadOldFileStyleUnitInfo
case mpkgs of
Just [DbUnitInfo]
pkgs -> [DbUnitInfo] -> IO [DbUnitInfo]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [DbUnitInfo]
pkgs
Maybe [DbUnitInfo]
Nothing -> GhcException -> IO [DbUnitInfo]
forall a. GhcException -> IO a
throwGhcExceptionIO (GhcException -> IO [DbUnitInfo])
-> GhcException -> IO [DbUnitInfo]
forall a b. (a -> b) -> a -> b
$ String -> GhcException
InstallationError (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$
String
"ghc no longer supports single-file style package " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"databases (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
conf_file String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
") use 'ghc-pkg init' to create the database with " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"the correct format."
else throwGhcExceptionIO $ InstallationError $
"can't find a package database at " ++ conf_file
let
conf_file' = String -> String
dropTrailingPathSeparator String
conf_file
top_dir = UnitConfig -> String
unitConfigGHCDir UnitConfig
cfg
pkgroot = String -> String
takeDirectory String
conf_file'
pkg_configs1 = (DbUnitInfo -> UnitInfo) -> [DbUnitInfo] -> [UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> UnitInfo -> UnitInfo
mungeUnitInfo String
top_dir String
pkgroot (UnitInfo -> UnitInfo)
-> (DbUnitInfo -> UnitInfo) -> DbUnitInfo -> UnitInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitKey -> UnitId) -> GenUnitInfo UnitKey -> UnitInfo
forall v u.
IsUnitId v =>
(u -> v) -> GenUnitInfo u -> GenUnitInfo v
mapUnitInfo (\(UnitKey FastString
x) -> FastString -> UnitId
UnitId FastString
x) (GenUnitInfo UnitKey -> UnitInfo)
-> (DbUnitInfo -> GenUnitInfo UnitKey) -> DbUnitInfo -> UnitInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DbUnitInfo -> GenUnitInfo UnitKey
mkUnitKeyInfo)
[DbUnitInfo]
proto_pkg_configs
return $ UnitDatabase conf_file' pkg_configs1
where
readDirStyleUnitInfo :: String -> IO [DbUnitInfo]
readDirStyleUnitInfo String
conf_dir = do
let filename :: String
filename = String
conf_dir String -> String -> String
</> String
"package.cache"
cache_exists <- String -> IO Bool
doesFileExist String
filename
if cache_exists
then do
debugTraceMsg logger 2 $ text "Using binary package database:" <+> text filename
readPackageDbForGhc filename
else do
debugTraceMsg logger 2 $ text "There is no package.cache in"
<+> text conf_dir
<> text ", checking if the database is empty"
db_empty <- all (not . isSuffixOf ".conf")
<$> getDirectoryContents conf_dir
if db_empty
then do
debugTraceMsg logger 3 $ text "There are no .conf files in"
<+> text conf_dir <> text ", treating"
<+> text "package database as empty"
return []
else
throwGhcExceptionIO $ InstallationError $
"there is no package.cache in " ++ conf_dir ++
" even though package database is not empty"
tryReadOldFileStyleUnitInfo :: IO (Maybe [DbUnitInfo])
tryReadOldFileStyleUnitInfo = do
content <- String -> IO String
readFile String
conf_file IO String -> (IOException -> IO String) -> IO String
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
_ -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
""
if take 2 content == "[]"
then do
let conf_dir = String
conf_file String -> String -> String
<.> String
"d"
direxists <- doesDirectoryExist conf_dir
if direxists
then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
liftM Just (readDirStyleUnitInfo conf_dir)
else return (Just [])
else return Nothing
distrustAllUnits :: [UnitInfo] -> [UnitInfo]
distrustAllUnits :: [UnitInfo] -> [UnitInfo]
distrustAllUnits [UnitInfo]
pkgs = (UnitInfo -> UnitInfo) -> [UnitInfo] -> [UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitInfo
forall {srcpkgid} {srcpkgname} {uid} {modulename} {mod}.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo srcpkgid srcpkgname uid modulename mod
distrust [UnitInfo]
pkgs
where
distrust :: GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo srcpkgid srcpkgname uid modulename mod
distrust GenericUnitInfo srcpkgid srcpkgname uid modulename mod
pkg = GenericUnitInfo srcpkgid srcpkgname uid modulename mod
pkg{ unitIsTrusted = False }
mungeUnitInfo :: FilePath -> FilePath
-> UnitInfo -> UnitInfo
mungeUnitInfo :: String -> String -> UnitInfo -> UnitInfo
mungeUnitInfo String
top_dir String
pkgroot =
UnitInfo -> UnitInfo
mungeDynLibFields
(UnitInfo -> UnitInfo)
-> (UnitInfo -> UnitInfo) -> UnitInfo -> UnitInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortText -> ShortText -> UnitInfo -> UnitInfo
forall a b c d e.
ShortText
-> ShortText
-> GenericUnitInfo a b c d e
-> GenericUnitInfo a b c d e
mungeUnitInfoPaths (String -> ShortText
ST.pack String
top_dir) (String -> ShortText
ST.pack String
pkgroot)
mungeDynLibFields :: UnitInfo -> UnitInfo
mungeDynLibFields :: UnitInfo -> UnitInfo
mungeDynLibFields UnitInfo
pkg =
UnitInfo
pkg {
unitLibraryDynDirs = case unitLibraryDynDirs pkg of
[] -> UnitInfo -> [ShortText]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [ShortText]
unitLibraryDirs UnitInfo
pkg
[ShortText]
ds -> [ShortText]
ds
}
applyTrustFlag
:: UnitPrecedenceMap
-> UnusableUnits
-> [UnitInfo]
-> TrustFlag
-> MaybeErr UnitErr [UnitInfo]
applyTrustFlag :: UnitPrecedenceMap
-> UnusableUnits
-> [UnitInfo]
-> TrustFlag
-> MaybeErr UnitErr [UnitInfo]
applyTrustFlag UnitPrecedenceMap
prec_map UnusableUnits
unusable [UnitInfo]
pkgs TrustFlag
flag =
case TrustFlag
flag of
TrustPackage String
str ->
case UnitPrecedenceMap
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] ([UnitInfo], [UnitInfo])
selectPackages UnitPrecedenceMap
prec_map (String -> PackageArg
PackageArg String
str) [UnitInfo]
pkgs UnusableUnits
unusable of
Left [(UnitInfo, UnusableUnitReason)]
ps -> UnitErr -> MaybeErr UnitErr [UnitInfo]
forall err val. err -> MaybeErr err val
Failed (TrustFlag -> [(UnitInfo, UnusableUnitReason)] -> UnitErr
TrustFlagErr TrustFlag
flag [(UnitInfo, UnusableUnitReason)]
ps)
Right ([UnitInfo]
ps,[UnitInfo]
qs) -> [UnitInfo] -> MaybeErr UnitErr [UnitInfo]
forall err val. val -> MaybeErr err val
Succeeded ((UnitInfo -> UnitInfo) -> [UnitInfo] -> [UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitInfo
forall {srcpkgid} {srcpkgname} {uid} {modulename} {mod}.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo srcpkgid srcpkgname uid modulename mod
trust [UnitInfo]
ps [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ [UnitInfo]
qs)
where trust :: GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo srcpkgid srcpkgname uid modulename mod
trust GenericUnitInfo srcpkgid srcpkgname uid modulename mod
p = GenericUnitInfo srcpkgid srcpkgname uid modulename mod
p {unitIsTrusted=True}
DistrustPackage String
str ->
case UnitPrecedenceMap
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] ([UnitInfo], [UnitInfo])
selectPackages UnitPrecedenceMap
prec_map (String -> PackageArg
PackageArg String
str) [UnitInfo]
pkgs UnusableUnits
unusable of
Left [(UnitInfo, UnusableUnitReason)]
ps -> UnitErr -> MaybeErr UnitErr [UnitInfo]
forall err val. err -> MaybeErr err val
Failed (TrustFlag -> [(UnitInfo, UnusableUnitReason)] -> UnitErr
TrustFlagErr TrustFlag
flag [(UnitInfo, UnusableUnitReason)]
ps)
Right ([UnitInfo]
ps,[UnitInfo]
qs) -> [UnitInfo] -> MaybeErr UnitErr [UnitInfo]
forall err val. val -> MaybeErr err val
Succeeded ([UnitInfo] -> [UnitInfo]
distrustAllUnits [UnitInfo]
ps [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ [UnitInfo]
qs)
applyPackageFlag
:: UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> UnusableUnits
-> Bool
-> [UnitInfo]
-> VisibilityMap
-> PackageFlag
-> MaybeErr UnitErr VisibilityMap
applyPackageFlag :: UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> UnusableUnits
-> Bool
-> [UnitInfo]
-> VisibilityMap
-> PackageFlag
-> MaybeErr UnitErr VisibilityMap
applyPackageFlag UnitPrecedenceMap
prec_map UnitInfoMap
pkg_map PreloadUnitClosure
closure UnusableUnits
unusable Bool
no_hide_others [UnitInfo]
pkgs VisibilityMap
vm PackageFlag
flag =
case PackageFlag
flag of
ExposePackage String
_ PackageArg
arg (ModRenaming Bool
b [(ModuleName, ModuleName)]
rns) ->
case UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo]
findPackages UnitPrecedenceMap
prec_map UnitInfoMap
pkg_map PreloadUnitClosure
closure PackageArg
arg [UnitInfo]
pkgs UnusableUnits
unusable of
Left [(UnitInfo, UnusableUnitReason)]
ps -> UnitErr -> MaybeErr UnitErr VisibilityMap
forall err val. err -> MaybeErr err val
Failed (PackageFlag -> [(UnitInfo, UnusableUnitReason)] -> UnitErr
PackageFlagErr PackageFlag
flag [(UnitInfo, UnusableUnitReason)]
ps)
Right (UnitInfo
p:[UnitInfo]
_) -> VisibilityMap -> MaybeErr UnitErr VisibilityMap
forall err val. val -> MaybeErr err val
Succeeded VisibilityMap
vm'
where
n :: FastString
n = UnitInfo -> FastString
fsPackageName UnitInfo
p
reqs :: UniqMap ModuleName (Set InstantiatedModule)
reqs | UnitIdArg Unit
orig_uid <- PackageArg
arg = Unit -> UniqMap ModuleName (Set InstantiatedModule)
forall {u}.
GenUnit u
-> UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))
collectHoles Unit
orig_uid
| Bool
otherwise = UniqMap ModuleName (Set InstantiatedModule)
forall k a. UniqMap k a
emptyUniqMap
collectHoles :: GenUnit u
-> UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))
collectHoles GenUnit u
uid = case GenUnit u
uid of
GenUnit u
HoleUnit -> UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))
forall k a. UniqMap k a
emptyUniqMap
RealUnit {} -> UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))
forall k a. UniqMap k a
emptyUniqMap
VirtUnit GenInstantiatedUnit u
indef ->
let local :: [UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))]
local = [ ModuleName
-> Set (GenModule (GenInstantiatedUnit u))
-> UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))
forall k a. Uniquable k => k -> a -> UniqMap k a
unitUniqMap
(GenModule (GenUnit u) -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule (GenUnit u)
mod)
(GenModule (GenInstantiatedUnit u)
-> Set (GenModule (GenInstantiatedUnit u))
forall a. a -> Set a
Set.singleton (GenModule (GenInstantiatedUnit u)
-> Set (GenModule (GenInstantiatedUnit u)))
-> GenModule (GenInstantiatedUnit u)
-> Set (GenModule (GenInstantiatedUnit u))
forall a b. (a -> b) -> a -> b
$ GenInstantiatedUnit u
-> ModuleName -> GenModule (GenInstantiatedUnit u)
forall unit. unit -> ModuleName -> GenModule unit
Module GenInstantiatedUnit u
indef ModuleName
mod_name)
| (ModuleName
mod_name, GenModule (GenUnit u)
mod) <- GenInstantiatedUnit u -> GenInstantiations u
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit u
indef
, GenModule (GenUnit u) -> Bool
forall u. GenModule (GenUnit u) -> Bool
isHoleModule GenModule (GenUnit u)
mod ]
recurse :: [UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))]
recurse = [ GenUnit u
-> UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))
collectHoles (GenModule (GenUnit u) -> GenUnit u
forall unit. GenModule unit -> unit
moduleUnit GenModule (GenUnit u)
mod)
| (ModuleName
_, GenModule (GenUnit u)
mod) <- GenInstantiatedUnit u -> GenInstantiations u
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit u
indef ]
in (Set (GenModule (GenInstantiatedUnit u))
-> Set (GenModule (GenInstantiatedUnit u))
-> Set (GenModule (GenInstantiatedUnit u)))
-> [UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))]
-> UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))
forall a k. (a -> a -> a) -> [UniqMap k a] -> UniqMap k a
plusUniqMapListWith Set (GenModule (GenInstantiatedUnit u))
-> Set (GenModule (GenInstantiatedUnit u))
-> Set (GenModule (GenInstantiatedUnit u))
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))]
-> UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u))))
-> [UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))]
-> UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))
forall a b. (a -> b) -> a -> b
$ [UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))]
local [UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))]
-> [UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))]
-> [UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))]
forall a. [a] -> [a] -> [a]
++ [UniqMap ModuleName (Set (GenModule (GenInstantiatedUnit u)))]
recurse
uv :: UnitVisibility
uv = UnitVisibility
{ uv_expose_all :: Bool
uv_expose_all = Bool
b
, uv_renamings :: [(ModuleName, ModuleName)]
uv_renamings = [(ModuleName, ModuleName)]
rns
, uv_package_name :: First FastString
uv_package_name = Maybe FastString -> First FastString
forall a. Maybe a -> First a
First (FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
n)
, uv_requirements :: UniqMap ModuleName (Set InstantiatedModule)
uv_requirements = UniqMap ModuleName (Set InstantiatedModule)
reqs
, uv_explicit :: Maybe PackageArg
uv_explicit = PackageArg -> Maybe PackageArg
forall a. a -> Maybe a
Just PackageArg
arg
}
vm' :: VisibilityMap
vm' = (UnitVisibility -> UnitVisibility -> UnitVisibility)
-> VisibilityMap -> Unit -> UnitVisibility -> VisibilityMap
forall k a.
Uniquable k =>
(a -> a -> a) -> UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap_C UnitVisibility -> UnitVisibility -> UnitVisibility
forall a. Monoid a => a -> a -> a
mappend VisibilityMap
vm_cleared (UnitInfo -> Unit
mkUnit UnitInfo
p) UnitVisibility
uv
vm_cleared :: VisibilityMap
vm_cleared | Bool
no_hide_others = VisibilityMap
vm
| ((ModuleName, ModuleName)
_:[(ModuleName, ModuleName)]
_) <- [(ModuleName, ModuleName)]
rns = VisibilityMap
vm
| Bool
otherwise = (Unit -> UnitVisibility -> Bool) -> VisibilityMap -> VisibilityMap
forall k a. (k -> a -> Bool) -> UniqMap k a -> UniqMap k a
filterWithKeyUniqMap
(\Unit
k UnitVisibility
uv -> Unit
k Unit -> Unit -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> Unit
mkUnit UnitInfo
p
Bool -> Bool -> Bool
|| Maybe FastString -> First FastString
forall a. Maybe a -> First a
First (FastString -> Maybe FastString
forall a. a -> Maybe a
Just FastString
n) First FastString -> First FastString -> Bool
forall a. Eq a => a -> a -> Bool
/= UnitVisibility -> First FastString
uv_package_name UnitVisibility
uv) VisibilityMap
vm
Either [(UnitInfo, UnusableUnitReason)] [UnitInfo]
_ -> String -> MaybeErr UnitErr VisibilityMap
forall a. HasCallStack => String -> a
panic String
"applyPackageFlag"
HidePackage String
str ->
case UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo]
findPackages UnitPrecedenceMap
prec_map UnitInfoMap
pkg_map PreloadUnitClosure
closure (String -> PackageArg
PackageArg String
str) [UnitInfo]
pkgs UnusableUnits
unusable of
Left [(UnitInfo, UnusableUnitReason)]
ps -> UnitErr -> MaybeErr UnitErr VisibilityMap
forall err val. err -> MaybeErr err val
Failed (PackageFlag -> [(UnitInfo, UnusableUnitReason)] -> UnitErr
PackageFlagErr PackageFlag
flag [(UnitInfo, UnusableUnitReason)]
ps)
Right [UnitInfo]
ps -> VisibilityMap -> MaybeErr UnitErr VisibilityMap
forall err val. val -> MaybeErr err val
Succeeded (VisibilityMap -> MaybeErr UnitErr VisibilityMap)
-> VisibilityMap -> MaybeErr UnitErr VisibilityMap
forall a b. (a -> b) -> a -> b
$ (VisibilityMap -> Unit -> VisibilityMap)
-> VisibilityMap -> [Unit] -> VisibilityMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' VisibilityMap -> Unit -> VisibilityMap
forall k a. Uniquable k => UniqMap k a -> k -> UniqMap k a
delFromUniqMap VisibilityMap
vm ((UnitInfo -> Unit) -> [UnitInfo] -> [Unit]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> Unit
mkUnit [UnitInfo]
ps)
findPackages :: UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> PackageArg -> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)]
[UnitInfo]
findPackages :: UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo]
findPackages UnitPrecedenceMap
prec_map UnitInfoMap
pkg_map PreloadUnitClosure
closure PackageArg
arg [UnitInfo]
pkgs UnusableUnits
unusable
= let ps :: [UnitInfo]
ps = (UnitInfo -> Maybe UnitInfo) -> [UnitInfo] -> [UnitInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PackageArg -> UnitInfo -> Maybe UnitInfo
finder PackageArg
arg) [UnitInfo]
pkgs
in if [UnitInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitInfo]
ps
then [(UnitInfo, UnusableUnitReason)]
-> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo]
forall a b. a -> Either a b
Left (((UnitInfo, UnusableUnitReason)
-> Maybe (UnitInfo, UnusableUnitReason))
-> [(UnitInfo, UnusableUnitReason)]
-> [(UnitInfo, UnusableUnitReason)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(UnitInfo
x,UnusableUnitReason
y) -> PackageArg -> UnitInfo -> Maybe UnitInfo
finder PackageArg
arg UnitInfo
x Maybe UnitInfo
-> (UnitInfo -> Maybe (UnitInfo, UnusableUnitReason))
-> Maybe (UnitInfo, UnusableUnitReason)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \UnitInfo
x' -> (UnitInfo, UnusableUnitReason)
-> Maybe (UnitInfo, UnusableUnitReason)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitInfo
x',UnusableUnitReason
y))
(UnusableUnits -> [(UnitInfo, UnusableUnitReason)]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap UnusableUnits
unusable))
else [UnitInfo] -> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo]
forall a b. b -> Either a b
Right (UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
sortByPreference UnitPrecedenceMap
prec_map [UnitInfo]
ps)
where
finder :: PackageArg -> UnitInfo -> Maybe UnitInfo
finder (PackageArg String
str) UnitInfo
p
= if String -> UnitInfo -> Bool
matchingStr String
str UnitInfo
p
then UnitInfo -> Maybe UnitInfo
forall a. a -> Maybe a
Just UnitInfo
p
else Maybe UnitInfo
forall a. Maybe a
Nothing
finder (UnitIdArg Unit
uid) UnitInfo
p
= case Unit
uid of
RealUnit (Definite UnitId
iuid)
| UnitId
iuid UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
p
-> UnitInfo -> Maybe UnitInfo
forall a. a -> Maybe a
Just UnitInfo
p
VirtUnit GenInstantiatedUnit UnitId
inst
| GenInstantiatedUnit UnitId -> UnitId
forall unit. GenInstantiatedUnit unit -> unit
instUnitInstanceOf GenInstantiatedUnit UnitId
inst UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
p
-> UnitInfo -> Maybe UnitInfo
forall a. a -> Maybe a
Just (UnitInfoMap
-> PreloadUnitClosure
-> [(ModuleName, Module)]
-> UnitInfo
-> UnitInfo
renameUnitInfo UnitInfoMap
pkg_map PreloadUnitClosure
closure (GenInstantiatedUnit UnitId -> [(ModuleName, Module)]
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit UnitId
inst) UnitInfo
p)
Unit
_ -> Maybe UnitInfo
forall a. Maybe a
Nothing
selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)]
([UnitInfo], [UnitInfo])
selectPackages :: UnitPrecedenceMap
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] ([UnitInfo], [UnitInfo])
selectPackages UnitPrecedenceMap
prec_map PackageArg
arg [UnitInfo]
pkgs UnusableUnits
unusable
= let matches :: UnitInfo -> Bool
matches = PackageArg -> UnitInfo -> Bool
matching PackageArg
arg
([UnitInfo]
ps,[UnitInfo]
rest) = (UnitInfo -> Bool) -> [UnitInfo] -> ([UnitInfo], [UnitInfo])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition UnitInfo -> Bool
matches [UnitInfo]
pkgs
in if [UnitInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitInfo]
ps
then [(UnitInfo, UnusableUnitReason)]
-> Either [(UnitInfo, UnusableUnitReason)] ([UnitInfo], [UnitInfo])
forall a b. a -> Either a b
Left (((UnitInfo, UnusableUnitReason) -> Bool)
-> [(UnitInfo, UnusableUnitReason)]
-> [(UnitInfo, UnusableUnitReason)]
forall a. (a -> Bool) -> [a] -> [a]
filter (UnitInfo -> Bool
matches(UnitInfo -> Bool)
-> ((UnitInfo, UnusableUnitReason) -> UnitInfo)
-> (UnitInfo, UnusableUnitReason)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(UnitInfo, UnusableUnitReason) -> UnitInfo
forall a b. (a, b) -> a
fst) (UnusableUnits -> [(UnitInfo, UnusableUnitReason)]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap UnusableUnits
unusable))
else ([UnitInfo], [UnitInfo])
-> Either [(UnitInfo, UnusableUnitReason)] ([UnitInfo], [UnitInfo])
forall a b. b -> Either a b
Right (UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
sortByPreference UnitPrecedenceMap
prec_map [UnitInfo]
ps, [UnitInfo]
rest)
renameUnitInfo :: UnitInfoMap -> PreloadUnitClosure -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo
renameUnitInfo :: UnitInfoMap
-> PreloadUnitClosure
-> [(ModuleName, Module)]
-> UnitInfo
-> UnitInfo
renameUnitInfo UnitInfoMap
pkg_map PreloadUnitClosure
closure [(ModuleName, Module)]
insts UnitInfo
conf =
let hsubst :: UniqFM ModuleName Module
hsubst = [(ModuleName, Module)] -> UniqFM ModuleName Module
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [(ModuleName, Module)]
insts
smod :: Module -> Module
smod = UnitInfoMap
-> PreloadUnitClosure
-> UniqFM ModuleName Module
-> Module
-> Module
renameHoleModule' UnitInfoMap
pkg_map PreloadUnitClosure
closure UniqFM ModuleName Module
hsubst
new_insts :: [(ModuleName, Module)]
new_insts = ((ModuleName, Module) -> (ModuleName, Module))
-> [(ModuleName, Module)] -> [(ModuleName, Module)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ModuleName
k,Module
v) -> (ModuleName
k,Module -> Module
smod Module
v)) (UnitInfo -> [(ModuleName, Module)]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [(modulename, mod)]
unitInstantiations UnitInfo
conf)
in UnitInfo
conf {
unitInstantiations = new_insts,
unitExposedModules = map (\(ModuleName
mod_name, Maybe Module
mb_mod) -> (ModuleName
mod_name, (Module -> Module) -> Maybe Module -> Maybe Module
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Module -> Module
smod Maybe Module
mb_mod))
(unitExposedModules conf)
}
matchingStr :: String -> UnitInfo -> Bool
matchingStr :: String -> UnitInfo -> Bool
matchingStr String
str UnitInfo
p
= String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> String
forall u. GenUnitInfo u -> String
unitPackageIdString UnitInfo
p
Bool -> Bool -> Bool
|| String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> String
forall u. GenUnitInfo u -> String
unitPackageNameString UnitInfo
p
matchingId :: UnitId -> UnitInfo -> Bool
matchingId :: UnitId -> UnitInfo -> Bool
matchingId UnitId
uid UnitInfo
p = UnitId
uid UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
p
matching :: PackageArg -> UnitInfo -> Bool
matching :: PackageArg -> UnitInfo -> Bool
matching (PackageArg String
str) = String -> UnitInfo -> Bool
matchingStr String
str
matching (UnitIdArg (RealUnit (Definite UnitId
uid))) = UnitId -> UnitInfo -> Bool
matchingId UnitId
uid
matching (UnitIdArg Unit
_) = \UnitInfo
_ -> Bool
False
sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
sortByPreference :: UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
sortByPreference UnitPrecedenceMap
prec_map = (UnitInfo -> UnitInfo -> Ordering) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((UnitInfo -> UnitInfo -> Ordering)
-> UnitInfo -> UnitInfo -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (UnitPrecedenceMap -> UnitInfo -> UnitInfo -> Ordering
compareByPreference UnitPrecedenceMap
prec_map))
compareByPreference
:: UnitPrecedenceMap
-> UnitInfo
-> UnitInfo
-> Ordering
compareByPreference :: UnitPrecedenceMap -> UnitInfo -> UnitInfo -> Ordering
compareByPreference UnitPrecedenceMap
prec_map UnitInfo
pkg UnitInfo
pkg'
= case (UnitInfo -> Version) -> UnitInfo -> UnitInfo -> Ordering
forall a t. Ord a => (t -> a) -> t -> t -> Ordering
comparing UnitInfo -> Version
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Version
unitPackageVersion UnitInfo
pkg UnitInfo
pkg' of
Ordering
GT -> Ordering
GT
Ordering
EQ | Just Int
prec <- UnitPrecedenceMap -> UnitId -> Maybe Int
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UnitPrecedenceMap
prec_map (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
pkg)
, Just Int
prec' <- UnitPrecedenceMap -> UnitId -> Maybe Int
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UnitPrecedenceMap
prec_map (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
pkg')
-> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
prec Int
prec'
| Bool
otherwise
-> Ordering
EQ
Ordering
LT -> Ordering
LT
comparing :: Ord a => (t -> a) -> t -> t -> Ordering
comparing :: forall a t. Ord a => (t -> a) -> t -> t -> Ordering
comparing t -> a
f t
a t
b = t -> a
f t
a a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` t -> a
f t
b
pprFlag :: PackageFlag -> SDoc
pprFlag :: PackageFlag -> SDoc
pprFlag PackageFlag
flag = case PackageFlag
flag of
HidePackage String
p -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-hide-package " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
p
ExposePackage String
doc PackageArg
_ ModRenaming
_ -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
doc
pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag TrustFlag
flag = case TrustFlag
flag of
TrustPackage String
p -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-trust " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
p
DistrustPackage String
p -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-distrust " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
p
type WiringMap = UniqMap UnitId UnitId
findWiredInUnits
:: Logger
-> UnitPrecedenceMap
-> [UnitInfo]
-> VisibilityMap
-> IO ([UnitInfo],
WiringMap)
findWiredInUnits :: Logger
-> UnitPrecedenceMap
-> [UnitInfo]
-> VisibilityMap
-> IO ([UnitInfo], UniqMap UnitId UnitId)
findWiredInUnits Logger
logger UnitPrecedenceMap
prec_map [UnitInfo]
pkgs VisibilityMap
vis_map = do
let
matches :: UnitInfo -> UnitId -> Bool
UnitInfo
pc matches :: UnitInfo -> UnitId -> Bool
`matches` UnitId
pid = UnitInfo -> PackageName
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName UnitInfo
pc PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== FastString -> PackageName
PackageName (UnitId -> FastString
unitIdFS UnitId
pid)
findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo))
findWiredInUnit :: [UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo))
findWiredInUnit [UnitInfo]
pkgs UnitId
wired_pkg = [IO (Maybe (UnitId, UnitInfo))] -> IO (Maybe (UnitId, UnitInfo))
forall (m :: * -> *) (f :: * -> *) a.
(Monad m, Foldable f) =>
f (m (Maybe a)) -> m (Maybe a)
firstJustsM [[UnitInfo] -> IO (Maybe (UnitId, UnitInfo))
try [UnitInfo]
all_exposed_ps, [UnitInfo] -> IO (Maybe (UnitId, UnitInfo))
try [UnitInfo]
all_ps, IO (Maybe (UnitId, UnitInfo))
notfound]
where
all_ps :: [UnitInfo]
all_ps = [ UnitInfo
p | UnitInfo
p <- [UnitInfo]
pkgs, UnitInfo
p UnitInfo -> UnitId -> Bool
`matches` UnitId
wired_pkg ]
all_exposed_ps :: [UnitInfo]
all_exposed_ps = [ UnitInfo
p | UnitInfo
p <- [UnitInfo]
all_ps, (UnitInfo -> Unit
mkUnit UnitInfo
p) Unit -> VisibilityMap -> Bool
forall k a. Uniquable k => k -> UniqMap k a -> Bool
`elemUniqMap` VisibilityMap
vis_map ]
try :: [UnitInfo] -> IO (Maybe (UnitId, UnitInfo))
try [UnitInfo]
ps = case UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
sortByPreference UnitPrecedenceMap
prec_map [UnitInfo]
ps of
UnitInfo
p:[UnitInfo]
_ -> (UnitId, UnitInfo) -> Maybe (UnitId, UnitInfo)
forall a. a -> Maybe a
Just ((UnitId, UnitInfo) -> Maybe (UnitId, UnitInfo))
-> IO (UnitId, UnitInfo) -> IO (Maybe (UnitId, UnitInfo))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnitInfo -> IO (UnitId, UnitInfo)
pick UnitInfo
p
[UnitInfo]
_ -> Maybe (UnitId, UnitInfo) -> IO (Maybe (UnitId, UnitInfo))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (UnitId, UnitInfo)
forall a. Maybe a
Nothing
notfound :: IO (Maybe (UnitId, UnitInfo))
notfound = do
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"wired-in package "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (UnitId -> FastString
unitIdFS UnitId
wired_pkg)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" not found."
Maybe (UnitId, UnitInfo) -> IO (Maybe (UnitId, UnitInfo))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (UnitId, UnitInfo)
forall a. Maybe a
Nothing
pick :: UnitInfo -> IO (UnitId, UnitInfo)
pick :: UnitInfo -> IO (UnitId, UnitInfo)
pick UnitInfo
pkg = do
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"wired-in package "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (UnitId -> FastString
unitIdFS UnitId
wired_pkg)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
" mapped to "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
pkg)
(UnitId, UnitInfo) -> IO (UnitId, UnitInfo)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitId
wired_pkg, UnitInfo
pkg)
mb_wired_in_pkgs <- (UnitId -> IO (Maybe (UnitId, UnitInfo)))
-> [UnitId] -> IO [Maybe (UnitId, UnitInfo)]
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 ([UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo))
findWiredInUnit [UnitInfo]
pkgs) [UnitId]
wiredInUnitIds
let
wired_in_pkgs = [Maybe (UnitId, UnitInfo)] -> [(UnitId, UnitInfo)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (UnitId, UnitInfo)]
mb_wired_in_pkgs
wiredInMap :: UniqMap UnitId UnitId
wiredInMap = [(UnitId, UnitId)] -> UniqMap UnitId UnitId
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap
[ (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
realUnitInfo, UnitId
wiredInUnitId)
| (UnitId
wiredInUnitId, UnitInfo
realUnitInfo) <- [(UnitId, UnitInfo)]
wired_in_pkgs
, Bool -> Bool
not (UnitInfo -> Bool
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Bool
unitIsIndefinite UnitInfo
realUnitInfo)
]
updateWiredInDependencies [GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module]
pkgs = (GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module
-> GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module)
-> [GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module]
-> [GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module]
forall a b. (a -> b) -> [a] -> [b]
map (GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module
-> GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module
forall {srcpkgid} {srcpkgname} {modulename}.
GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module
-> GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module
upd_deps (GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module
-> GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module)
-> (GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module
-> GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module)
-> GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module
-> GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module
-> GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module
forall {srcpkgid} {srcpkgname} {modulename} {mod}.
GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
-> GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
upd_pkg) [GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module]
pkgs
where upd_pkg :: GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
-> GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
upd_pkg GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
pkg
| Just UnitId
wiredInUnitId <- UniqMap UnitId UnitId -> UnitId -> Maybe UnitId
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UniqMap UnitId UnitId
wiredInMap (GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
pkg)
= GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
pkg { unitId = wiredInUnitId
, unitInstanceOf = wiredInUnitId
}
| Bool
otherwise
= GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
pkg
upd_deps :: GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module
-> GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module
upd_deps GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module
pkg = GenericUnitInfo srcpkgid srcpkgname UnitId modulename Module
pkg {
unitDepends = map (upd_wired_in wiredInMap) (unitDepends pkg),
unitExposedModules
= map (\(modulename
k,Maybe Module
v) -> (modulename
k, (Module -> Module) -> Maybe Module -> Maybe Module
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UniqMap UnitId UnitId -> Module -> Module
upd_wired_in_mod UniqMap UnitId UnitId
wiredInMap) Maybe Module
v))
(unitExposedModules pkg)
}
return (updateWiredInDependencies pkgs, wiredInMap)
upd_wired_in_mod :: WiringMap -> Module -> Module
upd_wired_in_mod :: UniqMap UnitId UnitId -> Module -> Module
upd_wired_in_mod UniqMap UnitId UnitId
wiredInMap (Module Unit
uid ModuleName
m) = Unit -> ModuleName -> Module
forall unit. unit -> ModuleName -> GenModule unit
Module (UniqMap UnitId UnitId -> Unit -> Unit
upd_wired_in_uid UniqMap UnitId UnitId
wiredInMap Unit
uid) ModuleName
m
upd_wired_in_uid :: WiringMap -> Unit -> Unit
upd_wired_in_uid :: UniqMap UnitId UnitId -> Unit -> Unit
upd_wired_in_uid UniqMap UnitId UnitId
wiredInMap Unit
u = case Unit
u of
Unit
HoleUnit -> Unit
forall uid. GenUnit uid
HoleUnit
RealUnit (Definite UnitId
uid) -> Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite (UniqMap UnitId UnitId -> UnitId -> UnitId
upd_wired_in UniqMap UnitId UnitId
wiredInMap UnitId
uid))
VirtUnit GenInstantiatedUnit UnitId
indef_uid ->
GenInstantiatedUnit UnitId -> Unit
forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit (GenInstantiatedUnit UnitId -> Unit)
-> GenInstantiatedUnit UnitId -> Unit
forall a b. (a -> b) -> a -> b
$ UnitId -> [(ModuleName, Module)] -> GenInstantiatedUnit UnitId
forall u.
IsUnitId u =>
u -> GenInstantiations u -> GenInstantiatedUnit u
mkInstantiatedUnit
(GenInstantiatedUnit UnitId -> UnitId
forall unit. GenInstantiatedUnit unit -> unit
instUnitInstanceOf GenInstantiatedUnit UnitId
indef_uid)
(((ModuleName, Module) -> (ModuleName, Module))
-> [(ModuleName, Module)] -> [(ModuleName, Module)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ModuleName
x,Module
y) -> (ModuleName
x,UniqMap UnitId UnitId -> Module -> Module
upd_wired_in_mod UniqMap UnitId UnitId
wiredInMap Module
y)) (GenInstantiatedUnit UnitId -> [(ModuleName, Module)]
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit UnitId
indef_uid))
upd_wired_in :: WiringMap -> UnitId -> UnitId
upd_wired_in :: UniqMap UnitId UnitId -> UnitId -> UnitId
upd_wired_in UniqMap UnitId UnitId
wiredInMap UnitId
key
| Just UnitId
key' <- UniqMap UnitId UnitId -> UnitId -> Maybe UnitId
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UniqMap UnitId UnitId
wiredInMap UnitId
key = UnitId
key'
| Bool
otherwise = UnitId
key
updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap
updateVisibilityMap :: UniqMap UnitId UnitId -> VisibilityMap -> VisibilityMap
updateVisibilityMap UniqMap UnitId UnitId
wiredInMap VisibilityMap
vis_map = (VisibilityMap -> (UnitId, UnitId) -> VisibilityMap)
-> VisibilityMap -> [(UnitId, UnitId)] -> VisibilityMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' VisibilityMap -> (UnitId, UnitId) -> VisibilityMap
f VisibilityMap
vis_map (UniqMap UnitId UnitId -> [(UnitId, UnitId)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UniqMap UnitId UnitId
wiredInMap)
where f :: VisibilityMap -> (UnitId, UnitId) -> VisibilityMap
f VisibilityMap
vm (UnitId
from, UnitId
to) = case VisibilityMap -> Unit -> Maybe UnitVisibility
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap VisibilityMap
vis_map (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
from)) of
Maybe UnitVisibility
Nothing -> VisibilityMap
vm
Just UnitVisibility
r -> VisibilityMap -> Unit -> UnitVisibility -> VisibilityMap
forall k a. Uniquable k => UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap (VisibilityMap -> Unit -> VisibilityMap
forall k a. Uniquable k => UniqMap k a -> k -> UniqMap k a
delFromUniqMap VisibilityMap
vm (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
from)))
(Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
to)) UnitVisibility
r
data UnusableUnitReason
=
IgnoredWithFlag
| BrokenDependencies [UnitId]
| CyclicDependencies [UnitId]
| IgnoredDependencies [UnitId]
| ShadowedDependencies [UnitId]
instance Outputable UnusableUnitReason where
ppr :: UnusableUnitReason -> SDoc
ppr UnusableUnitReason
IgnoredWithFlag = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"[ignored with flag]"
ppr (BrokenDependencies [UnitId]
uids) = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"broken" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [UnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
uids)
ppr (CyclicDependencies [UnitId]
uids) = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cyclic" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [UnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
uids)
ppr (IgnoredDependencies [UnitId]
uids) = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ignored" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [UnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
uids)
ppr (ShadowedDependencies [UnitId]
uids) = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"shadowed" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [UnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
uids)
type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason)
pprReason :: SDoc -> UnusableUnitReason -> SDoc
pprReason :: SDoc -> UnusableUnitReason -> SDoc
pprReason SDoc
pref UnusableUnitReason
reason = case UnusableUnitReason
reason of
UnusableUnitReason
IgnoredWithFlag ->
SDoc
pref SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ignored due to an -ignore-package flag"
BrokenDependencies [UnitId]
deps ->
SDoc
pref SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"unusable due to missing dependencies:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ((UnitId -> SDoc) -> [UnitId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
deps))
CyclicDependencies [UnitId]
deps ->
SDoc
pref SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"unusable due to cyclic dependencies:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ((UnitId -> SDoc) -> [UnitId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
deps))
IgnoredDependencies [UnitId]
deps ->
SDoc
pref SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"unusable because the -ignore-package flag was used to " String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"ignore at least one of its dependencies:") SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ((UnitId -> SDoc) -> [UnitId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
deps))
ShadowedDependencies [UnitId]
deps ->
SDoc
pref SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"unusable due to shadowed dependencies:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ((UnitId -> SDoc) -> [UnitId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
deps))
reportCycles :: Logger -> [SCC UnitInfo] -> IO ()
reportCycles :: Logger -> [SCC UnitInfo] -> IO ()
reportCycles Logger
logger [SCC UnitInfo]
sccs = (SCC UnitInfo -> IO ()) -> [SCC UnitInfo] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SCC UnitInfo -> IO ()
report [SCC UnitInfo]
sccs
where
report :: SCC UnitInfo -> IO ()
report (AcyclicSCC UnitInfo
_) = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
report (CyclicSCC [UnitInfo]
vs) =
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"these packages are involved in a cycle:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ((UnitInfo -> SDoc) -> [UnitInfo] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnitId -> SDoc) -> (UnitInfo -> UnitId) -> UnitInfo -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId) [UnitInfo]
vs))
reportUnusable :: Logger -> UnusableUnits -> IO ()
reportUnusable :: Logger -> UnusableUnits -> IO ()
reportUnusable Logger
logger UnusableUnits
pkgs = ((UnitId, (UnitInfo, UnusableUnitReason)) -> IO ())
-> [(UnitId, (UnitInfo, UnusableUnitReason))] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UnitId, (UnitInfo, UnusableUnitReason)) -> IO ()
report (UnusableUnits -> [(UnitId, (UnitInfo, UnusableUnitReason))]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UnusableUnits
pkgs)
where
report :: (UnitId, (UnitInfo, UnusableUnitReason)) -> IO ()
report (UnitId
ipid, (UnitInfo
_, UnusableUnitReason
reason)) =
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
SDoc -> UnusableUnitReason -> SDoc
pprReason
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"package" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
ipid SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is") UnusableUnitReason
reason
type RevIndex = UniqMap UnitId [UnitId]
reverseDeps :: UnitInfoMap -> RevIndex
reverseDeps :: UnitInfoMap -> RevIndex
reverseDeps UnitInfoMap
db = ((UnitId, UnitInfo) -> RevIndex -> RevIndex)
-> RevIndex -> UnitInfoMap -> RevIndex
forall k a b. ((k, a) -> b -> b) -> b -> UniqMap k a -> b
nonDetFoldUniqMap (UnitId, UnitInfo) -> RevIndex -> RevIndex
go RevIndex
forall k a. UniqMap k a
emptyUniqMap UnitInfoMap
db
where
go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex
go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex
go (UnitId
_uid, UnitInfo
pkg) RevIndex
r = (RevIndex -> UnitId -> RevIndex)
-> RevIndex -> [UnitId] -> RevIndex
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (UnitId -> RevIndex -> UnitId -> RevIndex
forall {k} {a}.
Uniquable k =>
a -> UniqMap k [a] -> k -> UniqMap k [a]
go' (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
pkg)) RevIndex
r (UnitInfo -> [UnitId]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends UnitInfo
pkg)
go' :: a -> UniqMap k [a] -> k -> UniqMap k [a]
go' a
from UniqMap k [a]
r k
to = ([a] -> [a] -> [a]) -> UniqMap k [a] -> k -> [a] -> UniqMap k [a]
forall k a.
Uniquable k =>
(a -> a -> a) -> UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap_C [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) UniqMap k [a]
r k
to [a
from]
removeUnits :: [UnitId] -> RevIndex
-> UnitInfoMap
-> (UnitInfoMap, [UnitInfo])
removeUnits :: [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits [UnitId]
uids RevIndex
index UnitInfoMap
m = [UnitId] -> (UnitInfoMap, [UnitInfo]) -> (UnitInfoMap, [UnitInfo])
go [UnitId]
uids (UnitInfoMap
m,[])
where
go :: [UnitId] -> (UnitInfoMap, [UnitInfo]) -> (UnitInfoMap, [UnitInfo])
go [] (UnitInfoMap
m,[UnitInfo]
pkgs) = (UnitInfoMap
m,[UnitInfo]
pkgs)
go (UnitId
uid:[UnitId]
uids) (UnitInfoMap
m,[UnitInfo]
pkgs)
| Just UnitInfo
pkg <- UnitInfoMap -> UnitId -> Maybe UnitInfo
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UnitInfoMap
m UnitId
uid
= case RevIndex -> UnitId -> Maybe [UnitId]
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap RevIndex
index UnitId
uid of
Maybe [UnitId]
Nothing -> [UnitId] -> (UnitInfoMap, [UnitInfo]) -> (UnitInfoMap, [UnitInfo])
go [UnitId]
uids (UnitInfoMap -> UnitId -> UnitInfoMap
forall k a. Uniquable k => UniqMap k a -> k -> UniqMap k a
delFromUniqMap UnitInfoMap
m UnitId
uid, UnitInfo
pkgUnitInfo -> [UnitInfo] -> [UnitInfo]
forall a. a -> [a] -> [a]
:[UnitInfo]
pkgs)
Just [UnitId]
rdeps -> [UnitId] -> (UnitInfoMap, [UnitInfo]) -> (UnitInfoMap, [UnitInfo])
go ([UnitId]
rdeps [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [UnitId]
uids) (UnitInfoMap -> UnitId -> UnitInfoMap
forall k a. Uniquable k => UniqMap k a -> k -> UniqMap k a
delFromUniqMap UnitInfoMap
m UnitId
uid, UnitInfo
pkgUnitInfo -> [UnitInfo] -> [UnitInfo]
forall a. a -> [a] -> [a]
:[UnitInfo]
pkgs)
| Bool
otherwise
= [UnitId] -> (UnitInfoMap, [UnitInfo]) -> (UnitInfoMap, [UnitInfo])
go [UnitId]
uids (UnitInfoMap
m,[UnitInfo]
pkgs)
depsNotAvailable :: UnitInfoMap
-> UnitInfo
-> [UnitId]
depsNotAvailable :: UnitInfoMap -> UnitInfo -> [UnitId]
depsNotAvailable UnitInfoMap
pkg_map UnitInfo
pkg = (UnitId -> Bool) -> [UnitId] -> [UnitId]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (UnitId -> Bool) -> UnitId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId -> UnitInfoMap -> Bool
forall k a. Uniquable k => k -> UniqMap k a -> Bool
`elemUniqMap` UnitInfoMap
pkg_map)) (UnitInfo -> [UnitId]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends UnitInfo
pkg)
depsAbiMismatch :: UnitInfoMap
-> UnitInfo
-> [UnitId]
depsAbiMismatch :: UnitInfoMap -> UnitInfo -> [UnitId]
depsAbiMismatch UnitInfoMap
pkg_map UnitInfo
pkg = ((UnitId, ShortText) -> UnitId)
-> [(UnitId, ShortText)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, ShortText) -> UnitId
forall a b. (a, b) -> a
fst ([(UnitId, ShortText)] -> [UnitId])
-> ([(UnitId, ShortText)] -> [(UnitId, ShortText)])
-> [(UnitId, ShortText)]
-> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UnitId, ShortText) -> Bool)
-> [(UnitId, ShortText)] -> [(UnitId, ShortText)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((UnitId, ShortText) -> Bool) -> (UnitId, ShortText) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId, ShortText) -> Bool
abiMatch) ([(UnitId, ShortText)] -> [UnitId])
-> [(UnitId, ShortText)] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ UnitInfo -> [(UnitId, ShortText)]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [(uid, ShortText)]
unitAbiDepends UnitInfo
pkg
where
abiMatch :: (UnitId, ShortText) -> Bool
abiMatch (UnitId
dep_uid, ShortText
abi)
| Just UnitInfo
dep_pkg <- UnitInfoMap -> UnitId -> Maybe UnitInfo
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UnitInfoMap
pkg_map UnitId
dep_uid
= UnitInfo -> ShortText
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> ShortText
unitAbiHash UnitInfo
dep_pkg ShortText -> ShortText -> Bool
forall a. Eq a => a -> a -> Bool
== ShortText
abi
| Bool
otherwise
= Bool
False
ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits
ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits
ignoreUnits [IgnorePackageFlag]
flags [UnitInfo]
pkgs = [(UnitId, (UnitInfo, UnusableUnitReason))] -> UnusableUnits
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap ((IgnorePackageFlag -> [(UnitId, (UnitInfo, UnusableUnitReason))])
-> [IgnorePackageFlag]
-> [(UnitId, (UnitInfo, UnusableUnitReason))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap IgnorePackageFlag -> [(UnitId, (UnitInfo, UnusableUnitReason))]
doit [IgnorePackageFlag]
flags)
where
doit :: IgnorePackageFlag -> [(UnitId, (UnitInfo, UnusableUnitReason))]
doit (IgnorePackage String
str) =
case (UnitInfo -> Bool) -> [UnitInfo] -> ([UnitInfo], [UnitInfo])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (String -> UnitInfo -> Bool
matchingStr String
str) [UnitInfo]
pkgs of
([UnitInfo]
ps, [UnitInfo]
_) -> [ (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
p, (UnitInfo
p, UnusableUnitReason
IgnoredWithFlag))
| UnitInfo
p <- [UnitInfo]
ps ]
type UnitPrecedenceMap = UniqMap UnitId Int
mergeDatabases :: Logger -> [UnitDatabase UnitId]
-> IO (UnitInfoMap, UnitPrecedenceMap)
mergeDatabases :: Logger
-> [UnitDatabase UnitId] -> IO (UnitInfoMap, UnitPrecedenceMap)
mergeDatabases Logger
logger = ((UnitInfoMap, UnitPrecedenceMap)
-> (Int, UnitDatabase UnitId)
-> IO (UnitInfoMap, UnitPrecedenceMap))
-> (UnitInfoMap, UnitPrecedenceMap)
-> [(Int, UnitDatabase UnitId)]
-> IO (UnitInfoMap, UnitPrecedenceMap)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (UnitInfoMap, UnitPrecedenceMap)
-> (Int, UnitDatabase UnitId)
-> IO (UnitInfoMap, UnitPrecedenceMap)
merge (UnitInfoMap
forall k a. UniqMap k a
emptyUniqMap, UnitPrecedenceMap
forall k a. UniqMap k a
emptyUniqMap) ([(Int, UnitDatabase UnitId)]
-> IO (UnitInfoMap, UnitPrecedenceMap))
-> ([UnitDatabase UnitId] -> [(Int, UnitDatabase UnitId)])
-> [UnitDatabase UnitId]
-> IO (UnitInfoMap, UnitPrecedenceMap)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [UnitDatabase UnitId] -> [(Int, UnitDatabase UnitId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..]
where
merge :: (UnitInfoMap, UnitPrecedenceMap)
-> (Int, UnitDatabase UnitId)
-> IO (UnitInfoMap, UnitPrecedenceMap)
merge (UnitInfoMap
pkg_map, UnitPrecedenceMap
prec_map) (Int
i, UnitDatabase String
db_path [UnitInfo]
db) = do
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"loading package database" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
db_path
[UnitId] -> (UnitId -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
override_set) ((UnitId -> IO ()) -> IO ()) -> (UnitId -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \UnitId
pkg ->
Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"package" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
pkg SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"overrides a previously defined package"
(UnitInfoMap, UnitPrecedenceMap)
-> IO (UnitInfoMap, UnitPrecedenceMap)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitInfoMap
pkg_map', UnitPrecedenceMap
prec_map')
where
db_map :: UnitInfoMap
db_map = [UnitInfo] -> UnitInfoMap
forall {srcpkgid} {srcpkgname} {modulename} {mod}.
[GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod]
-> UniqMap
UnitId (GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod)
mk_pkg_map [UnitInfo]
db
mk_pkg_map :: [GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod]
-> UniqMap
UnitId (GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod)
mk_pkg_map = [(UnitId,
GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod)]
-> UniqMap
UnitId (GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod)
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap ([(UnitId,
GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod)]
-> UniqMap
UnitId (GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod))
-> ([GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod]
-> [(UnitId,
GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod)])
-> [GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod]
-> UniqMap
UnitId (GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
-> (UnitId,
GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod))
-> [GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod]
-> [(UnitId,
GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod)]
forall a b. (a -> b) -> [a] -> [b]
map (\GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
p -> (GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
p, GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
p))
override_set :: Set UnitId
override_set :: Set UnitId
override_set = Set UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (UnitInfoMap -> Set UnitId
forall k a. Ord k => UniqMap k a -> Set k
nonDetUniqMapToKeySet UnitInfoMap
db_map)
(UnitInfoMap -> Set UnitId
forall k a. Ord k => UniqMap k a -> Set k
nonDetUniqMapToKeySet UnitInfoMap
pkg_map)
pkg_map' :: UnitInfoMap
pkg_map' :: UnitInfoMap
pkg_map' = UnitInfoMap
pkg_map UnitInfoMap -> UnitInfoMap -> UnitInfoMap
forall k a. UniqMap k a -> UniqMap k a -> UniqMap k a
`plusUniqMap` UnitInfoMap
db_map
prec_map' :: UnitPrecedenceMap
prec_map' :: UnitPrecedenceMap
prec_map' = UnitPrecedenceMap
prec_map UnitPrecedenceMap -> UnitPrecedenceMap -> UnitPrecedenceMap
forall k a. UniqMap k a -> UniqMap k a -> UniqMap k a
`plusUniqMap` ((UnitInfo -> Int) -> UnitInfoMap -> UnitPrecedenceMap
forall a b k. (a -> b) -> UniqMap k a -> UniqMap k b
mapUniqMap (Int -> UnitInfo -> Int
forall a b. a -> b -> a
const Int
i) UnitInfoMap
db_map)
validateDatabase :: UnitConfig -> UnitInfoMap
-> (UnitInfoMap, UnusableUnits, [SCC UnitInfo])
validateDatabase :: UnitConfig
-> UnitInfoMap -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo])
validateDatabase UnitConfig
cfg UnitInfoMap
pkg_map1 =
(UnitInfoMap
pkg_map5, UnusableUnits
unusable, [SCC UnitInfo]
sccs)
where
ignore_flags :: [IgnorePackageFlag]
ignore_flags = [IgnorePackageFlag] -> [IgnorePackageFlag]
forall a. [a] -> [a]
reverse (UnitConfig -> [IgnorePackageFlag]
unitConfigFlagsIgnored UnitConfig
cfg)
index :: RevIndex
index = UnitInfoMap -> RevIndex
reverseDeps UnitInfoMap
pkg_map1
mk_unusable :: (t -> b)
-> (t -> GenericUnitInfo srcpkgid srcpkgname k modulename mod -> t)
-> t
-> [GenericUnitInfo srcpkgid srcpkgname k modulename mod]
-> UniqMap
k (GenericUnitInfo srcpkgid srcpkgname k modulename mod, b)
mk_unusable t -> b
mk_err t -> GenericUnitInfo srcpkgid srcpkgname k modulename mod -> t
dep_matcher t
m [GenericUnitInfo srcpkgid srcpkgname k modulename mod]
uids =
[(k, (GenericUnitInfo srcpkgid srcpkgname k modulename mod, b))]
-> UniqMap
k (GenericUnitInfo srcpkgid srcpkgname k modulename mod, b)
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap [ (GenericUnitInfo srcpkgid srcpkgname k modulename mod -> k
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId GenericUnitInfo srcpkgid srcpkgname k modulename mod
pkg, (GenericUnitInfo srcpkgid srcpkgname k modulename mod
pkg, t -> b
mk_err (t -> GenericUnitInfo srcpkgid srcpkgname k modulename mod -> t
dep_matcher t
m GenericUnitInfo srcpkgid srcpkgname k modulename mod
pkg)))
| GenericUnitInfo srcpkgid srcpkgname k modulename mod
pkg <- [GenericUnitInfo srcpkgid srcpkgname k modulename mod]
uids
]
directly_broken :: [UnitInfo]
directly_broken = (UnitInfo -> Bool) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (UnitInfo -> Bool) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([UnitId] -> Bool) -> (UnitInfo -> [UnitId]) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfoMap -> UnitInfo -> [UnitId]
depsNotAvailable UnitInfoMap
pkg_map1)
(UnitInfoMap -> [UnitInfo]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap UnitInfoMap
pkg_map1)
(UnitInfoMap
pkg_map2, [UnitInfo]
broken) = [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits ((UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
directly_broken) RevIndex
index UnitInfoMap
pkg_map1
unusable_broken :: UnusableUnits
unusable_broken = ([UnitId] -> UnusableUnitReason)
-> (UnitInfoMap -> UnitInfo -> [UnitId])
-> UnitInfoMap
-> [UnitInfo]
-> UnusableUnits
forall {k} {t} {b} {t} {srcpkgid} {srcpkgname} {modulename} {mod}.
Uniquable k =>
(t -> b)
-> (t -> GenericUnitInfo srcpkgid srcpkgname k modulename mod -> t)
-> t
-> [GenericUnitInfo srcpkgid srcpkgname k modulename mod]
-> UniqMap
k (GenericUnitInfo srcpkgid srcpkgname k modulename mod, b)
mk_unusable [UnitId] -> UnusableUnitReason
BrokenDependencies UnitInfoMap -> UnitInfo -> [UnitId]
depsNotAvailable UnitInfoMap
pkg_map2 [UnitInfo]
broken
sccs :: [SCC UnitInfo]
sccs = [(UnitInfo, UnitId, [UnitId])] -> [SCC UnitInfo]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp [ (UnitInfo
pkg, UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
pkg, UnitInfo -> [UnitId]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends UnitInfo
pkg)
| UnitInfo
pkg <- UnitInfoMap -> [UnitInfo]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap UnitInfoMap
pkg_map2 ]
getCyclicSCC :: SCC (GenericUnitInfo srcpkgid srcpkgname b modulename mod) -> [b]
getCyclicSCC (CyclicSCC [GenericUnitInfo srcpkgid srcpkgname b modulename mod]
vs) = (GenericUnitInfo srcpkgid srcpkgname b modulename mod -> b)
-> [GenericUnitInfo srcpkgid srcpkgname b modulename mod] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map GenericUnitInfo srcpkgid srcpkgname b modulename mod -> b
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [GenericUnitInfo srcpkgid srcpkgname b modulename mod]
vs
getCyclicSCC (AcyclicSCC GenericUnitInfo srcpkgid srcpkgname b modulename mod
_) = []
(UnitInfoMap
pkg_map3, [UnitInfo]
cyclic) = [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits ((SCC UnitInfo -> [UnitId]) -> [SCC UnitInfo] -> [UnitId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SCC UnitInfo -> [UnitId]
forall {srcpkgid} {srcpkgname} {b} {modulename} {mod}.
SCC (GenericUnitInfo srcpkgid srcpkgname b modulename mod) -> [b]
getCyclicSCC [SCC UnitInfo]
sccs) RevIndex
index UnitInfoMap
pkg_map2
unusable_cyclic :: UnusableUnits
unusable_cyclic = ([UnitId] -> UnusableUnitReason)
-> (UnitInfoMap -> UnitInfo -> [UnitId])
-> UnitInfoMap
-> [UnitInfo]
-> UnusableUnits
forall {k} {t} {b} {t} {srcpkgid} {srcpkgname} {modulename} {mod}.
Uniquable k =>
(t -> b)
-> (t -> GenericUnitInfo srcpkgid srcpkgname k modulename mod -> t)
-> t
-> [GenericUnitInfo srcpkgid srcpkgname k modulename mod]
-> UniqMap
k (GenericUnitInfo srcpkgid srcpkgname k modulename mod, b)
mk_unusable [UnitId] -> UnusableUnitReason
CyclicDependencies UnitInfoMap -> UnitInfo -> [UnitId]
depsNotAvailable UnitInfoMap
pkg_map3 [UnitInfo]
cyclic
directly_ignored :: UnusableUnits
directly_ignored = [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits
ignoreUnits [IgnorePackageFlag]
ignore_flags (UnitInfoMap -> [UnitInfo]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap UnitInfoMap
pkg_map3)
(UnitInfoMap
pkg_map4, [UnitInfo]
ignored) = [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits (UnusableUnits -> [UnitId]
forall k a. UniqMap k a -> [k]
nonDetKeysUniqMap UnusableUnits
directly_ignored) RevIndex
index UnitInfoMap
pkg_map3
unusable_ignored :: UnusableUnits
unusable_ignored = ([UnitId] -> UnusableUnitReason)
-> (UnitInfoMap -> UnitInfo -> [UnitId])
-> UnitInfoMap
-> [UnitInfo]
-> UnusableUnits
forall {k} {t} {b} {t} {srcpkgid} {srcpkgname} {modulename} {mod}.
Uniquable k =>
(t -> b)
-> (t -> GenericUnitInfo srcpkgid srcpkgname k modulename mod -> t)
-> t
-> [GenericUnitInfo srcpkgid srcpkgname k modulename mod]
-> UniqMap
k (GenericUnitInfo srcpkgid srcpkgname k modulename mod, b)
mk_unusable [UnitId] -> UnusableUnitReason
IgnoredDependencies UnitInfoMap -> UnitInfo -> [UnitId]
depsNotAvailable UnitInfoMap
pkg_map4 [UnitInfo]
ignored
directly_shadowed :: [UnitInfo]
directly_shadowed = (UnitInfo -> Bool) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (UnitInfo -> Bool) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([UnitId] -> Bool) -> (UnitInfo -> [UnitId]) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfoMap -> UnitInfo -> [UnitId]
depsAbiMismatch UnitInfoMap
pkg_map4)
(UnitInfoMap -> [UnitInfo]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap UnitInfoMap
pkg_map4)
(UnitInfoMap
pkg_map5, [UnitInfo]
shadowed) = [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits ((UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
directly_shadowed) RevIndex
index UnitInfoMap
pkg_map4
unusable_shadowed :: UnusableUnits
unusable_shadowed = ([UnitId] -> UnusableUnitReason)
-> (UnitInfoMap -> UnitInfo -> [UnitId])
-> UnitInfoMap
-> [UnitInfo]
-> UnusableUnits
forall {k} {t} {b} {t} {srcpkgid} {srcpkgname} {modulename} {mod}.
Uniquable k =>
(t -> b)
-> (t -> GenericUnitInfo srcpkgid srcpkgname k modulename mod -> t)
-> t
-> [GenericUnitInfo srcpkgid srcpkgname k modulename mod]
-> UniqMap
k (GenericUnitInfo srcpkgid srcpkgname k modulename mod, b)
mk_unusable [UnitId] -> UnusableUnitReason
ShadowedDependencies UnitInfoMap -> UnitInfo -> [UnitId]
depsAbiMismatch UnitInfoMap
pkg_map5 [UnitInfo]
shadowed
unusable :: UnusableUnits
unusable = [UnusableUnits] -> UnusableUnits
forall k a. [UniqMap k a] -> UniqMap k a
plusUniqMapList [ UnusableUnits
unusable_shadowed
, UnusableUnits
unusable_cyclic
, UnusableUnits
unusable_broken
, UnusableUnits
unusable_ignored
, UnusableUnits
directly_ignored
]
mkUnitState
:: Logger
-> UnitConfig
-> IO (UnitState,[UnitDatabase UnitId])
mkUnitState :: Logger -> UnitConfig -> IO (UnitState, [UnitDatabase UnitId])
mkUnitState Logger
logger UnitConfig
cfg = do
raw_dbs <- case UnitConfig -> Maybe [UnitDatabase UnitId]
unitConfigDBCache UnitConfig
cfg of
Maybe [UnitDatabase UnitId]
Nothing -> Logger -> UnitConfig -> IO [UnitDatabase UnitId]
readUnitDatabases Logger
logger UnitConfig
cfg
Just [UnitDatabase UnitId]
dbs -> [UnitDatabase UnitId] -> IO [UnitDatabase UnitId]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [UnitDatabase UnitId]
dbs
let distrust_all UnitDatabase UnitId
db = UnitDatabase UnitId
db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
dbs | UnitConfig -> Bool
unitConfigDistrustAll UnitConfig
cfg = (UnitDatabase UnitId -> UnitDatabase UnitId)
-> [UnitDatabase UnitId] -> [UnitDatabase UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitDatabase UnitId -> UnitDatabase UnitId
distrust_all [UnitDatabase UnitId]
raw_dbs
| Bool
otherwise = [UnitDatabase UnitId]
raw_dbs
let raw_other_flags = [PackageFlag] -> [PackageFlag]
forall a. [a] -> [a]
reverse (UnitConfig -> [PackageFlag]
unitConfigFlagsExposed UnitConfig
cfg)
(hpt_flags, other_flags) = partition (selectHptFlag (unitConfigHomeUnits cfg)) raw_other_flags
debugTraceMsg logger 2 $
text "package flags" <+> ppr other_flags
let home_unit_deps = Set UnitId -> [PackageFlag] -> Set UnitId
selectHomeUnits (UnitConfig -> Set UnitId
unitConfigHomeUnits UnitConfig
cfg) [PackageFlag]
hpt_flags
(pkg_map1, prec_map) <- mergeDatabases logger dbs
let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
reportCycles logger sccs
reportUnusable logger unusable
pkgs1 <- mayThrowUnitErr
$ foldM (applyTrustFlag prec_map unusable)
(nonDetEltsUniqMap pkg_map2) (reverse (unitConfigFlagsTrusted cfg))
let prelim_pkg_db = [UnitInfo] -> UnitInfoMap
mkUnitInfoMap [UnitInfo]
pkgs1
let preferLater UnitInfo
unit UnitInfo
unit' =
case UnitPrecedenceMap -> UnitInfo -> UnitInfo -> Ordering
compareByPreference UnitPrecedenceMap
prec_map UnitInfo
unit UnitInfo
unit' of
Ordering
GT -> UnitInfo
unit
Ordering
_ -> UnitInfo
unit'
addIfMorePreferable UniqDFM FastString UnitInfo
m UnitInfo
unit = (UnitInfo -> UnitInfo -> UnitInfo)
-> UniqDFM FastString UnitInfo
-> FastString
-> UnitInfo
-> UniqDFM FastString UnitInfo
forall key elt.
Uniquable key =>
(elt -> elt -> elt)
-> UniqDFM key elt -> key -> elt -> UniqDFM key elt
addToUDFM_C UnitInfo -> UnitInfo -> UnitInfo
preferLater UniqDFM FastString UnitInfo
m (UnitInfo -> FastString
fsPackageName UnitInfo
unit) UnitInfo
unit
mostPreferablePackageReps = if UnitConfig -> Bool
unitConfigHideAll UnitConfig
cfg
then UniqDFM FastString UnitInfo
forall {k} (key :: k) elt. UniqDFM key elt
emptyUDFM
else (UniqDFM FastString UnitInfo
-> UnitInfo -> UniqDFM FastString UnitInfo)
-> UniqDFM FastString UnitInfo
-> [UnitInfo]
-> UniqDFM FastString UnitInfo
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UniqDFM FastString UnitInfo
-> UnitInfo -> UniqDFM FastString UnitInfo
addIfMorePreferable UniqDFM FastString UnitInfo
forall {k} (key :: k) elt. UniqDFM key elt
emptyUDFM [UnitInfo]
pkgs1
mostPreferable UnitInfo
u =
case UniqDFM FastString UnitInfo -> FastString -> Maybe UnitInfo
forall key elt.
Uniquable key =>
UniqDFM key elt -> key -> Maybe elt
lookupUDFM UniqDFM FastString UnitInfo
mostPreferablePackageReps (UnitInfo -> FastString
fsPackageName UnitInfo
u) of
Maybe UnitInfo
Nothing -> Bool
False
Just UnitInfo
u' -> UnitPrecedenceMap -> UnitInfo -> UnitInfo -> Ordering
compareByPreference UnitPrecedenceMap
prec_map UnitInfo
u UnitInfo
u' Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ
vis_map1 = (VisibilityMap -> UnitInfo -> VisibilityMap)
-> VisibilityMap -> [UnitInfo] -> VisibilityMap
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\VisibilityMap
vm UnitInfo
p ->
if UnitInfo -> Bool
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Bool
unitIsExposed UnitInfo
p Bool -> Bool -> Bool
&& Unit -> Bool
unitIsDefinite (UnitInfo -> Unit
mkUnit UnitInfo
p) Bool -> Bool -> Bool
&& UnitInfo -> Bool
mostPreferable UnitInfo
p
then VisibilityMap -> Unit -> UnitVisibility -> VisibilityMap
forall k a. Uniquable k => UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap VisibilityMap
vm (UnitInfo -> Unit
mkUnit UnitInfo
p)
UnitVisibility {
uv_expose_all :: Bool
uv_expose_all = Bool
True,
uv_renamings :: [(ModuleName, ModuleName)]
uv_renamings = [],
uv_package_name :: First FastString
uv_package_name = Maybe FastString -> First FastString
forall a. Maybe a -> First a
First (FastString -> Maybe FastString
forall a. a -> Maybe a
Just (UnitInfo -> FastString
fsPackageName UnitInfo
p)),
uv_requirements :: UniqMap ModuleName (Set InstantiatedModule)
uv_requirements = UniqMap ModuleName (Set InstantiatedModule)
forall k a. UniqMap k a
emptyUniqMap,
uv_explicit :: Maybe PackageArg
uv_explicit = Maybe PackageArg
forall a. Maybe a
Nothing
}
else VisibilityMap
vm)
VisibilityMap
forall k a. UniqMap k a
emptyUniqMap [UnitInfo]
pkgs1
vis_map2 <- mayThrowUnitErr
$ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable
(unitConfigHideAll cfg) pkgs1)
vis_map1 other_flags
(pkgs2, wired_map) <- findWiredInUnits logger prec_map pkgs1 vis_map2
let pkg_db = [UnitInfo] -> UnitInfoMap
mkUnitInfoMap [UnitInfo]
pkgs2
let vis_map = UniqMap UnitId UnitId -> VisibilityMap -> VisibilityMap
updateVisibilityMap UniqMap UnitId UnitId
wired_map VisibilityMap
vis_map2
let hide_plugin_pkgs = UnitConfig -> Bool
unitConfigHideAllPlugins UnitConfig
cfg
plugin_vis_map <-
case unitConfigFlagsPlugins cfg of
[] | Bool -> Bool
not Bool
hide_plugin_pkgs -> VisibilityMap -> IO VisibilityMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return VisibilityMap
vis_map
| Bool
otherwise -> VisibilityMap -> IO VisibilityMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return VisibilityMap
forall k a. UniqMap k a
emptyUniqMap
[PackageFlag]
_ -> do let plugin_vis_map1 :: VisibilityMap
plugin_vis_map1
| Bool
hide_plugin_pkgs = VisibilityMap
forall k a. UniqMap k a
emptyUniqMap
| Bool
otherwise = VisibilityMap
vis_map2
plugin_vis_map2
<- MaybeErr UnitErr VisibilityMap -> IO VisibilityMap
forall a. MaybeErr UnitErr a -> IO a
mayThrowUnitErr
(MaybeErr UnitErr VisibilityMap -> IO VisibilityMap)
-> MaybeErr UnitErr VisibilityMap -> IO VisibilityMap
forall a b. (a -> b) -> a -> b
$ (VisibilityMap -> PackageFlag -> MaybeErr UnitErr VisibilityMap)
-> VisibilityMap -> [PackageFlag] -> MaybeErr UnitErr VisibilityMap
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> UnusableUnits
-> Bool
-> [UnitInfo]
-> VisibilityMap
-> PackageFlag
-> MaybeErr UnitErr VisibilityMap
applyPackageFlag UnitPrecedenceMap
prec_map UnitInfoMap
prelim_pkg_db PreloadUnitClosure
forall a. UniqSet a
emptyUniqSet UnusableUnits
unusable
Bool
hide_plugin_pkgs [UnitInfo]
pkgs1)
VisibilityMap
plugin_vis_map1
([PackageFlag] -> [PackageFlag]
forall a. [a] -> [a]
reverse (UnitConfig -> [PackageFlag]
unitConfigFlagsPlugins UnitConfig
cfg))
return (updateVisibilityMap wired_map plugin_vis_map2)
let pkgname_map = [(PackageName, UnitId)] -> UniqFM PackageName UnitId
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [ (UnitInfo -> PackageName
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName UnitInfo
p, UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitInstanceOf UnitInfo
p)
| UnitInfo
p <- [UnitInfo]
pkgs2
]
let explicit_pkgs = [(Unit
k, UnitVisibility -> Maybe PackageArg
uv_explicit UnitVisibility
v) | (Unit
k, UnitVisibility
v) <- VisibilityMap -> [(Unit, UnitVisibility)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList VisibilityMap
vis_map]
req_ctx = (Set InstantiatedModule -> [InstantiatedModule])
-> UniqMap ModuleName (Set InstantiatedModule)
-> UniqMap ModuleName [InstantiatedModule]
forall a b k. (a -> b) -> UniqMap k a -> UniqMap k b
mapUniqMap (Set InstantiatedModule -> [InstantiatedModule]
forall a. Set a -> [a]
Set.toList)
(UniqMap ModuleName (Set InstantiatedModule)
-> UniqMap ModuleName [InstantiatedModule])
-> UniqMap ModuleName (Set InstantiatedModule)
-> UniqMap ModuleName [InstantiatedModule]
forall a b. (a -> b) -> a -> b
$ (Set InstantiatedModule
-> Set InstantiatedModule -> Set InstantiatedModule)
-> [UniqMap ModuleName (Set InstantiatedModule)]
-> UniqMap ModuleName (Set InstantiatedModule)
forall a k. (a -> a -> a) -> [UniqMap k a] -> UniqMap k a
plusUniqMapListWith Set InstantiatedModule
-> Set InstantiatedModule -> Set InstantiatedModule
forall a. Ord a => Set a -> Set a -> Set a
Set.union ((UnitVisibility -> UniqMap ModuleName (Set InstantiatedModule))
-> [UnitVisibility]
-> [UniqMap ModuleName (Set InstantiatedModule)]
forall a b. (a -> b) -> [a] -> [b]
map UnitVisibility -> UniqMap ModuleName (Set InstantiatedModule)
uv_requirements (VisibilityMap -> [UnitVisibility]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap VisibilityMap
vis_map))
let preload1 = VisibilityMap -> [Unit]
forall k a. UniqMap k a -> [k]
nonDetKeysUniqMap ((UnitVisibility -> Bool) -> VisibilityMap -> VisibilityMap
forall a k. (a -> Bool) -> UniqMap k a -> UniqMap k a
filterUniqMap (Maybe PackageArg -> Bool
forall a. Maybe a -> Bool
isJust (Maybe PackageArg -> Bool)
-> (UnitVisibility -> Maybe PackageArg) -> UnitVisibility -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitVisibility -> Maybe PackageArg
uv_explicit) VisibilityMap
vis_map)
basicLinkedUnits = (UnitId -> Unit) -> [UnitId] -> [Unit]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (Definite UnitId -> Unit)
-> (UnitId -> Definite UnitId) -> UnitId -> Unit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite)
([UnitId] -> [Unit]) -> [UnitId] -> [Unit]
forall a b. (a -> b) -> a -> b
$ (UnitId -> Bool) -> [UnitId] -> [UnitId]
forall a. (a -> Bool) -> [a] -> [a]
filter ((UnitId -> UnitInfoMap -> Bool) -> UnitInfoMap -> UnitId -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip UnitId -> UnitInfoMap -> Bool
forall k a. Uniquable k => k -> UniqMap k a -> Bool
elemUniqMap UnitInfoMap
pkg_db)
([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ UnitConfig -> [UnitId]
unitConfigAutoLink UnitConfig
cfg
preload3 = [Unit] -> [Unit]
forall a. Ord a => [a] -> [a]
ordNub ([Unit] -> [Unit]) -> [Unit] -> [Unit]
forall a b. (a -> b) -> a -> b
$ ([Unit]
basicLinkedUnits [Unit] -> [Unit] -> [Unit]
forall a. [a] -> [a] -> [a]
++ [Unit]
preload1)
dep_preload <- mayThrowUnitErr
$ closeUnitDeps pkg_db
$ zip (map toUnitId preload3) (repeat Nothing)
let mod_map1 = Logger
-> UnitConfig
-> UnitInfoMap
-> PreloadUnitClosure
-> VisibilityMap
-> ModuleNameProvidersMap
mkModuleNameProvidersMap Logger
logger UnitConfig
cfg UnitInfoMap
pkg_db PreloadUnitClosure
forall a. UniqSet a
emptyUniqSet VisibilityMap
vis_map
mod_map2 = UnusableUnits -> ModuleNameProvidersMap
mkUnusableModuleNameProvidersMap UnusableUnits
unusable
mod_map = ModuleNameProvidersMap
mod_map2 ModuleNameProvidersMap
-> ModuleNameProvidersMap -> ModuleNameProvidersMap
forall k a. UniqMap k a -> UniqMap k a -> UniqMap k a
`plusUniqMap` ModuleNameProvidersMap
mod_map1
let !state = UnitState
{ preloadUnits :: [UnitId]
preloadUnits = [UnitId]
dep_preload
, explicitUnits :: [(Unit, Maybe PackageArg)]
explicitUnits = [(Unit, Maybe PackageArg)]
explicit_pkgs
, homeUnitDepends :: [UnitId]
homeUnitDepends = Set UnitId -> [UnitId]
forall a. Set a -> [a]
Set.toList Set UnitId
home_unit_deps
, unitInfoMap :: UnitInfoMap
unitInfoMap = UnitInfoMap
pkg_db
, preloadClosure :: PreloadUnitClosure
preloadClosure = PreloadUnitClosure
forall a. UniqSet a
emptyUniqSet
, moduleNameProvidersMap :: ModuleNameProvidersMap
moduleNameProvidersMap = ModuleNameProvidersMap
mod_map
, pluginModuleNameProvidersMap :: ModuleNameProvidersMap
pluginModuleNameProvidersMap = Logger
-> UnitConfig
-> UnitInfoMap
-> PreloadUnitClosure
-> VisibilityMap
-> ModuleNameProvidersMap
mkModuleNameProvidersMap Logger
logger UnitConfig
cfg UnitInfoMap
pkg_db PreloadUnitClosure
forall a. UniqSet a
emptyUniqSet VisibilityMap
plugin_vis_map
, packageNameMap :: UniqFM PackageName UnitId
packageNameMap = UniqFM PackageName UnitId
pkgname_map
, wireMap :: UniqMap UnitId UnitId
wireMap = UniqMap UnitId UnitId
wired_map
, unwireMap :: UniqMap UnitId UnitId
unwireMap = [(UnitId, UnitId)] -> UniqMap UnitId UnitId
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap [ (UnitId
v,UnitId
k) | (UnitId
k,UnitId
v) <- UniqMap UnitId UnitId -> [(UnitId, UnitId)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UniqMap UnitId UnitId
wired_map ]
, requirementContext :: UniqMap ModuleName [InstantiatedModule]
requirementContext = UniqMap ModuleName [InstantiatedModule]
req_ctx
, allowVirtualUnits :: Bool
allowVirtualUnits = UnitConfig -> Bool
unitConfigAllowVirtual UnitConfig
cfg
}
return (state, raw_dbs)
selectHptFlag :: Set.Set UnitId -> PackageFlag -> Bool
selectHptFlag :: Set UnitId -> PackageFlag -> Bool
selectHptFlag Set UnitId
home_units (ExposePackage String
_ (UnitIdArg Unit
uid) ModRenaming
_) | Unit -> UnitId
toUnitId Unit
uid UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UnitId
home_units = Bool
True
selectHptFlag Set UnitId
_ PackageFlag
_ = Bool
False
selectHomeUnits :: Set.Set UnitId -> [PackageFlag] -> Set.Set UnitId
selectHomeUnits :: Set UnitId -> [PackageFlag] -> Set UnitId
selectHomeUnits Set UnitId
home_units [PackageFlag]
flags = (Set UnitId -> PackageFlag -> Set UnitId)
-> Set UnitId -> [PackageFlag] -> Set UnitId
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Set UnitId -> PackageFlag -> Set UnitId
go Set UnitId
forall a. Set a
Set.empty [PackageFlag]
flags
where
go :: Set.Set UnitId -> PackageFlag -> Set.Set UnitId
go :: Set UnitId -> PackageFlag -> Set UnitId
go Set UnitId
cur (ExposePackage String
_ (UnitIdArg Unit
uid) ModRenaming
_) | Unit -> UnitId
toUnitId Unit
uid UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UnitId
home_units = UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => a -> Set a -> Set a
Set.insert (Unit -> UnitId
toUnitId Unit
uid) Set UnitId
cur
go Set UnitId
cur PackageFlag
_ = Set UnitId
cur
unwireUnit :: UnitState -> Unit -> Unit
unwireUnit :: UnitState -> Unit -> Unit
unwireUnit UnitState
state uid :: Unit
uid@(RealUnit (Definite UnitId
def_uid)) =
Unit -> (UnitId -> Unit) -> Maybe UnitId -> Unit
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Unit
uid (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (Definite UnitId -> Unit)
-> (UnitId -> Definite UnitId) -> UnitId -> Unit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite) (UniqMap UnitId UnitId -> UnitId -> Maybe UnitId
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap (UnitState -> UniqMap UnitId UnitId
unwireMap UnitState
state) UnitId
def_uid)
unwireUnit UnitState
_ Unit
uid = Unit
uid
mkModuleNameProvidersMap
:: Logger
-> UnitConfig
-> UnitInfoMap
-> PreloadUnitClosure
-> VisibilityMap
-> ModuleNameProvidersMap
mkModuleNameProvidersMap :: Logger
-> UnitConfig
-> UnitInfoMap
-> PreloadUnitClosure
-> VisibilityMap
-> ModuleNameProvidersMap
mkModuleNameProvidersMap Logger
logger UnitConfig
cfg UnitInfoMap
pkg_map PreloadUnitClosure
closure VisibilityMap
vis_map =
((Unit, UnitVisibility)
-> ModuleNameProvidersMap -> ModuleNameProvidersMap)
-> ModuleNameProvidersMap
-> VisibilityMap
-> ModuleNameProvidersMap
forall k a b. ((k, a) -> b -> b) -> b -> UniqMap k a -> b
nonDetFoldUniqMap (Unit, UnitVisibility)
-> ModuleNameProvidersMap -> ModuleNameProvidersMap
extend_modmap ModuleNameProvidersMap
forall k a. UniqMap k a
emptyMap VisibilityMap
vis_map_extended
where
vis_map_extended :: VisibilityMap
vis_map_extended = VisibilityMap
default_vis VisibilityMap -> VisibilityMap -> VisibilityMap
forall k a. UniqMap k a -> UniqMap k a -> UniqMap k a
`plusUniqMap` VisibilityMap
vis_map
default_vis :: VisibilityMap
default_vis = [(Unit, UnitVisibility)] -> VisibilityMap
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap
[ (UnitInfo -> Unit
mkUnit UnitInfo
pkg, UnitVisibility
forall a. Monoid a => a
mempty)
| (UnitId
_, UnitInfo
pkg) <- UnitInfoMap -> [(UnitId, UnitInfo)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UnitInfoMap
pkg_map
, UnitInfo -> Bool
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Bool
unitIsIndefinite UnitInfo
pkg Bool -> Bool -> Bool
|| [(ModuleName, Module)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (UnitInfo -> [(ModuleName, Module)]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [(modulename, mod)]
unitInstantiations UnitInfo
pkg)
]
emptyMap :: UniqMap k a
emptyMap = UniqMap k a
forall k a. UniqMap k a
emptyUniqMap
setOrigins :: f a -> b -> f b
setOrigins f a
m b
os = (a -> b) -> f a -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> a -> b
forall a b. a -> b -> a
const b
os) f a
m
extend_modmap :: (Unit, UnitVisibility)
-> ModuleNameProvidersMap -> ModuleNameProvidersMap
extend_modmap (Unit
uid, UnitVisibility { uv_expose_all :: UnitVisibility -> Bool
uv_expose_all = Bool
b, uv_renamings :: UnitVisibility -> [(ModuleName, ModuleName)]
uv_renamings = [(ModuleName, ModuleName)]
rns }) ModuleNameProvidersMap
modmap
= ModuleNameProvidersMap
-> [(ModuleName, UniqMap Module ModuleOrigin)]
-> ModuleNameProvidersMap
forall a k1 k2.
(Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2) =>
UniqMap k1 (UniqMap k2 a)
-> [(k1, UniqMap k2 a)] -> UniqMap k1 (UniqMap k2 a)
addListTo ModuleNameProvidersMap
modmap [(ModuleName, UniqMap Module ModuleOrigin)]
theBindings
where
pkg :: UnitInfo
pkg = Unit -> UnitInfo
unit_lookup Unit
uid
theBindings :: [(ModuleName, UniqMap Module ModuleOrigin)]
theBindings :: [(ModuleName, UniqMap Module ModuleOrigin)]
theBindings = Bool
-> [(ModuleName, ModuleName)]
-> [(ModuleName, UniqMap Module ModuleOrigin)]
newBindings Bool
b [(ModuleName, ModuleName)]
rns
newBindings :: Bool
-> [(ModuleName, ModuleName)]
-> [(ModuleName, UniqMap Module ModuleOrigin)]
newBindings :: Bool
-> [(ModuleName, ModuleName)]
-> [(ModuleName, UniqMap Module ModuleOrigin)]
newBindings Bool
e [(ModuleName, ModuleName)]
rns = Bool -> [(ModuleName, UniqMap Module ModuleOrigin)]
es Bool
e [(ModuleName, UniqMap Module ModuleOrigin)]
-> [(ModuleName, UniqMap Module ModuleOrigin)]
-> [(ModuleName, UniqMap Module ModuleOrigin)]
forall a. [a] -> [a] -> [a]
++ [(ModuleName, UniqMap Module ModuleOrigin)]
hiddens [(ModuleName, UniqMap Module ModuleOrigin)]
-> [(ModuleName, UniqMap Module ModuleOrigin)]
-> [(ModuleName, UniqMap Module ModuleOrigin)]
forall a. [a] -> [a] -> [a]
++ ((ModuleName, ModuleName)
-> (ModuleName, UniqMap Module ModuleOrigin))
-> [(ModuleName, ModuleName)]
-> [(ModuleName, UniqMap Module ModuleOrigin)]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, ModuleName)
-> (ModuleName, UniqMap Module ModuleOrigin)
rnBinding [(ModuleName, ModuleName)]
rns
rnBinding :: (ModuleName, ModuleName)
-> (ModuleName, UniqMap Module ModuleOrigin)
rnBinding :: (ModuleName, ModuleName)
-> (ModuleName, UniqMap Module ModuleOrigin)
rnBinding (ModuleName
orig, ModuleName
new) = (ModuleName
new, UniqMap Module ModuleOrigin
-> ModuleOrigin -> UniqMap Module ModuleOrigin
forall {f :: * -> *} {a} {b}. Functor f => f a -> b -> f b
setOrigins UniqMap Module ModuleOrigin
origEntry ModuleOrigin
fromFlag)
where origEntry :: UniqMap Module ModuleOrigin
origEntry = case UniqFM ModuleName (UniqMap Module ModuleOrigin)
-> ModuleName -> Maybe (UniqMap Module ModuleOrigin)
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM ModuleName (UniqMap Module ModuleOrigin)
esmap ModuleName
orig of
Just UniqMap Module ModuleOrigin
r -> UniqMap Module ModuleOrigin
r
Maybe (UniqMap Module ModuleOrigin)
Nothing -> GhcException -> UniqMap Module ModuleOrigin
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError (SDocContext -> SDoc -> String
renderWithContext
(LogFlags -> SDocContext
log_default_user_context (Logger -> LogFlags
logFlags Logger
logger))
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"package flag: could not find module name" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
orig SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in package" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unit
pk)))
es :: Bool -> [(ModuleName, UniqMap Module ModuleOrigin)]
es :: Bool -> [(ModuleName, UniqMap Module ModuleOrigin)]
es Bool
e = do
(m, exposedReexport) <- [(ModuleName, Maybe Module)]
exposed_mods
let (pk', m', origin') =
case exposedReexport of
Maybe Module
Nothing -> (Unit
pk, ModuleName
m, Bool -> ModuleOrigin
fromExposedModules Bool
e)
Just (Module Unit
pk' ModuleName
m') ->
(Unit
pk', ModuleName
m', Bool -> UnitInfo -> ModuleOrigin
fromReexportedModules Bool
e UnitInfo
pkg)
return (m, mkModMap pk' m' origin')
esmap :: UniqFM ModuleName (UniqMap Module ModuleOrigin)
esmap :: UniqFM ModuleName (UniqMap Module ModuleOrigin)
esmap = [(ModuleName, UniqMap Module ModuleOrigin)]
-> UniqFM ModuleName (UniqMap Module ModuleOrigin)
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM (Bool -> [(ModuleName, UniqMap Module ModuleOrigin)]
es Bool
False)
hiddens :: [(ModuleName, UniqMap Module ModuleOrigin)]
hiddens = [(ModuleName
m, Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap Unit
pk ModuleName
m ModuleOrigin
ModHidden) | ModuleName
m <- [ModuleName]
hidden_mods]
pk :: Unit
pk = UnitInfo -> Unit
mkUnit UnitInfo
pkg
unit_lookup :: Unit -> UnitInfo
unit_lookup Unit
uid = Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo
lookupUnit' (UnitConfig -> Bool
unitConfigAllowVirtual UnitConfig
cfg) UnitInfoMap
pkg_map PreloadUnitClosure
closure Unit
uid
Maybe UnitInfo -> UnitInfo -> UnitInfo
forall a. Maybe a -> a -> a
`orElse` String -> SDoc -> UnitInfo
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"unit_lookup" (Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unit
uid)
exposed_mods :: [(ModuleName, Maybe Module)]
exposed_mods = UnitInfo -> [(ModuleName, Maybe Module)]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [(modulename, Maybe mod)]
unitExposedModules UnitInfo
pkg
hidden_mods :: [ModuleName]
hidden_mods = UnitInfo -> [ModuleName]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [modulename]
unitHiddenModules UnitInfo
pkg
mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap
mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap
mkUnusableModuleNameProvidersMap UnusableUnits
unusables =
((UnitId, (UnitInfo, UnusableUnitReason))
-> ModuleNameProvidersMap -> ModuleNameProvidersMap)
-> ModuleNameProvidersMap
-> UnusableUnits
-> ModuleNameProvidersMap
forall k a b. ((k, a) -> b -> b) -> b -> UniqMap k a -> b
nonDetFoldUniqMap (UnitId, (UnitInfo, UnusableUnitReason))
-> ModuleNameProvidersMap -> ModuleNameProvidersMap
forall {a}.
(a, (UnitInfo, UnusableUnitReason))
-> ModuleNameProvidersMap -> ModuleNameProvidersMap
extend_modmap ModuleNameProvidersMap
forall k a. UniqMap k a
emptyUniqMap UnusableUnits
unusables
where
extend_modmap :: (a, (UnitInfo, UnusableUnitReason))
-> ModuleNameProvidersMap -> ModuleNameProvidersMap
extend_modmap (a
_uid, (UnitInfo
unit_info, UnusableUnitReason
reason)) ModuleNameProvidersMap
modmap = ModuleNameProvidersMap
-> [(ModuleName, UniqMap Module ModuleOrigin)]
-> ModuleNameProvidersMap
forall a k1 k2.
(Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2) =>
UniqMap k1 (UniqMap k2 a)
-> [(k1, UniqMap k2 a)] -> UniqMap k1 (UniqMap k2 a)
addListTo ModuleNameProvidersMap
modmap [(ModuleName, UniqMap Module ModuleOrigin)]
bindings
where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)]
bindings :: [(ModuleName, UniqMap Module ModuleOrigin)]
bindings = [(ModuleName, UniqMap Module ModuleOrigin)]
exposed [(ModuleName, UniqMap Module ModuleOrigin)]
-> [(ModuleName, UniqMap Module ModuleOrigin)]
-> [(ModuleName, UniqMap Module ModuleOrigin)]
forall a. [a] -> [a] -> [a]
++ [(ModuleName, UniqMap Module ModuleOrigin)]
hidden
origin_reexport :: ModuleOrigin
origin_reexport = UnusableUnit -> ModuleOrigin
ModUnusable (Unit -> UnusableUnitReason -> Bool -> UnusableUnit
UnusableUnit Unit
unit UnusableUnitReason
reason Bool
True)
origin_normal :: ModuleOrigin
origin_normal = UnusableUnit -> ModuleOrigin
ModUnusable (Unit -> UnusableUnitReason -> Bool -> UnusableUnit
UnusableUnit Unit
unit UnusableUnitReason
reason Bool
False)
unit :: Unit
unit = UnitInfo -> Unit
mkUnit UnitInfo
unit_info
exposed :: [(ModuleName, UniqMap Module ModuleOrigin)]
exposed = ((ModuleName, Maybe Module)
-> (ModuleName, UniqMap Module ModuleOrigin))
-> [(ModuleName, Maybe Module)]
-> [(ModuleName, UniqMap Module ModuleOrigin)]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, Maybe Module)
-> (ModuleName, UniqMap Module ModuleOrigin)
get_exposed [(ModuleName, Maybe Module)]
exposed_mods
hidden :: [(ModuleName, UniqMap Module ModuleOrigin)]
hidden = [(ModuleName
m, Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap Unit
unit ModuleName
m ModuleOrigin
origin_normal) | ModuleName
m <- [ModuleName]
hidden_mods]
get_exposed :: (ModuleName, Maybe Module)
-> (ModuleName, UniqMap Module ModuleOrigin)
get_exposed (ModuleName
mod, Just Module
_) = (ModuleName
mod, Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap Unit
unit ModuleName
mod ModuleOrigin
origin_reexport)
get_exposed (ModuleName
mod, Maybe Module
_) = (ModuleName
mod, Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap Unit
unit ModuleName
mod ModuleOrigin
origin_normal)
exposed_mods :: [(ModuleName, Maybe Module)]
exposed_mods = UnitInfo -> [(ModuleName, Maybe Module)]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [(modulename, Maybe mod)]
unitExposedModules UnitInfo
unit_info
hidden_mods :: [ModuleName]
hidden_mods = UnitInfo -> [ModuleName]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [modulename]
unitHiddenModules UnitInfo
unit_info
addListTo :: (Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2)
=> UniqMap k1 (UniqMap k2 a)
-> [(k1, UniqMap k2 a)]
-> UniqMap k1 (UniqMap k2 a)
addListTo :: forall a k1 k2.
(Monoid a, Ord k1, Ord k2, Uniquable k1, Uniquable k2) =>
UniqMap k1 (UniqMap k2 a)
-> [(k1, UniqMap k2 a)] -> UniqMap k1 (UniqMap k2 a)
addListTo = (UniqMap k1 (UniqMap k2 a)
-> (k1, UniqMap k2 a) -> UniqMap k1 (UniqMap k2 a))
-> UniqMap k1 (UniqMap k2 a)
-> [(k1, UniqMap k2 a)]
-> UniqMap k1 (UniqMap k2 a)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UniqMap k1 (UniqMap k2 a)
-> (k1, UniqMap k2 a) -> UniqMap k1 (UniqMap k2 a)
forall {k} {a} {k}.
(Uniquable k, Monoid a) =>
UniqMap k (UniqMap k a)
-> (k, UniqMap k a) -> UniqMap k (UniqMap k a)
merge
where merge :: UniqMap k (UniqMap k a)
-> (k, UniqMap k a) -> UniqMap k (UniqMap k a)
merge UniqMap k (UniqMap k a)
m (k
k, UniqMap k a
v) = (UniqMap k a -> UniqMap k a -> UniqMap k a)
-> UniqMap k (UniqMap k a)
-> k
-> UniqMap k a
-> UniqMap k (UniqMap k a)
forall k a.
Uniquable k =>
(a -> a -> a) -> UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap_C ((a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a
forall a k.
(a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a
plusUniqMap_C a -> a -> a
forall a. Monoid a => a -> a -> a
mappend) UniqMap k (UniqMap k a)
m k
k UniqMap k a
v
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
mkModMap Unit
pkg ModuleName
mod = Module -> ModuleOrigin -> UniqMap Module ModuleOrigin
forall k a. Uniquable k => k -> a -> UniqMap k a
unitUniqMap (Unit -> ModuleName -> Module
forall unit. unit -> ModuleName -> GenModule unit
mkModule Unit
pkg ModuleName
mod)
lookupModuleInAllUnits :: UnitState
-> ModuleName
-> [(Module, UnitInfo)]
lookupModuleInAllUnits :: UnitState -> ModuleName -> [(Module, UnitInfo)]
lookupModuleInAllUnits UnitState
pkgs ModuleName
m
= case UnitState -> ModuleName -> PkgQual -> LookupResult
lookupModuleWithSuggestions UnitState
pkgs ModuleName
m PkgQual
NoPkgQual of
LookupFound Module
a (UnitInfo, ModuleOrigin)
b -> [(Module
a,(UnitInfo, ModuleOrigin) -> UnitInfo
forall a b. (a, b) -> a
fst (UnitInfo, ModuleOrigin)
b)]
LookupMultiple [(Module, ModuleOrigin)]
rs -> ((Module, ModuleOrigin) -> (Module, UnitInfo))
-> [(Module, ModuleOrigin)] -> [(Module, UnitInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (Module, ModuleOrigin) -> (Module, UnitInfo)
f [(Module, ModuleOrigin)]
rs
where f :: (Module, ModuleOrigin) -> (Module, UnitInfo)
f (Module
m,ModuleOrigin
_) = (Module
m, String -> Maybe UnitInfo -> UnitInfo
forall a. HasDebugCallStack => String -> Maybe a -> a
expectJust String
"lookupModule" (UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
pkgs
(Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
m)))
LookupResult
_ -> []
data LookupResult =
LookupFound Module (UnitInfo, ModuleOrigin)
| LookupMultiple [(Module, ModuleOrigin)]
| LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)]
| LookupUnusable [(Module, ModuleOrigin)]
| LookupNotFound [ModuleSuggestion]
data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
| SuggestHidden ModuleName Module ModuleOrigin
lookupModuleWithSuggestions :: UnitState
-> ModuleName
-> PkgQual
-> LookupResult
lookupModuleWithSuggestions :: UnitState -> ModuleName -> PkgQual -> LookupResult
lookupModuleWithSuggestions UnitState
pkgs
= UnitState
-> ModuleNameProvidersMap -> ModuleName -> PkgQual -> LookupResult
lookupModuleWithSuggestions' UnitState
pkgs (UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap UnitState
pkgs)
lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
lookupModulePackage UnitState
pkgs ModuleName
mn PkgQual
mfs =
case UnitState
-> ModuleNameProvidersMap -> ModuleName -> PkgQual -> LookupResult
lookupModuleWithSuggestions' UnitState
pkgs (UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap UnitState
pkgs) ModuleName
mn PkgQual
mfs of
LookupFound Module
_ (UnitInfo
orig_unit, ModuleOrigin
origin) ->
case ModuleOrigin
origin of
ModOrigin {Maybe Bool
fromOrigUnit :: ModuleOrigin -> Maybe Bool
fromOrigUnit :: Maybe Bool
fromOrigUnit, [UnitInfo]
fromExposedReexport :: ModuleOrigin -> [UnitInfo]
fromExposedReexport :: [UnitInfo]
fromExposedReexport} ->
case Maybe Bool
fromOrigUnit of
Just Bool
True ->
[UnitInfo] -> Maybe [UnitInfo]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [UnitInfo
orig_unit]
Maybe Bool
_ -> [UnitInfo] -> Maybe [UnitInfo]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [UnitInfo]
fromExposedReexport
ModuleOrigin
_ -> Maybe [UnitInfo]
forall a. Maybe a
Nothing
LookupResult
_ -> Maybe [UnitInfo]
forall a. Maybe a
Nothing
lookupPluginModuleWithSuggestions :: UnitState
-> ModuleName
-> PkgQual
-> LookupResult
lookupPluginModuleWithSuggestions :: UnitState -> ModuleName -> PkgQual -> LookupResult
lookupPluginModuleWithSuggestions UnitState
pkgs
= UnitState
-> ModuleNameProvidersMap -> ModuleName -> PkgQual -> LookupResult
lookupModuleWithSuggestions' UnitState
pkgs (UnitState -> ModuleNameProvidersMap
pluginModuleNameProvidersMap UnitState
pkgs)
lookupModuleWithSuggestions' :: UnitState
-> ModuleNameProvidersMap
-> ModuleName
-> PkgQual
-> LookupResult
lookupModuleWithSuggestions' :: UnitState
-> ModuleNameProvidersMap -> ModuleName -> PkgQual -> LookupResult
lookupModuleWithSuggestions' UnitState
pkgs ModuleNameProvidersMap
mod_map ModuleName
m PkgQual
mb_pn
= case ModuleNameProvidersMap
-> ModuleName -> Maybe (UniqMap Module ModuleOrigin)
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap ModuleNameProvidersMap
mod_map ModuleName
m of
Maybe (UniqMap Module ModuleOrigin)
Nothing -> [ModuleSuggestion] -> LookupResult
LookupNotFound [ModuleSuggestion]
suggestions
Just UniqMap Module ModuleOrigin
xs ->
case (([(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
[(Module, ModuleOrigin)], [(Module, ModuleOrigin)])
-> (Module, ModuleOrigin)
-> ([(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
[(Module, ModuleOrigin)], [(Module, ModuleOrigin)]))
-> ([(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
[(Module, ModuleOrigin)], [(Module, ModuleOrigin)])
-> [(Module, ModuleOrigin)]
-> ([(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
[(Module, ModuleOrigin)], [(Module, ModuleOrigin)])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
[(Module, ModuleOrigin)], [(Module, ModuleOrigin)])
-> (Module, ModuleOrigin)
-> ([(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
[(Module, ModuleOrigin)], [(Module, ModuleOrigin)])
classify ([],[],[], []) (((Module, ModuleOrigin) -> Module)
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Module, ModuleOrigin) -> Module
forall a b. (a, b) -> a
fst ([(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)])
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall a b. (a -> b) -> a -> b
$ UniqMap Module ModuleOrigin -> [(Module, ModuleOrigin)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UniqMap Module ModuleOrigin
xs) of
([], [], [], []) -> [ModuleSuggestion] -> LookupResult
LookupNotFound [ModuleSuggestion]
suggestions
([(Module, ModuleOrigin)]
_, [(Module, ModuleOrigin)]
_, [(Module, ModuleOrigin)]
_, [(Module
m, ModuleOrigin
o)]) -> Module -> (UnitInfo, ModuleOrigin) -> LookupResult
LookupFound Module
m (Module -> UnitInfo
mod_unit Module
m, ModuleOrigin
o)
([(Module, ModuleOrigin)]
_, [(Module, ModuleOrigin)]
_, [(Module, ModuleOrigin)]
_, exposed :: [(Module, ModuleOrigin)]
exposed@((Module, ModuleOrigin)
_:[(Module, ModuleOrigin)]
_)) -> [(Module, ModuleOrigin)] -> LookupResult
LookupMultiple [(Module, ModuleOrigin)]
exposed
([], [], unusable :: [(Module, ModuleOrigin)]
unusable@((Module, ModuleOrigin)
_:[(Module, ModuleOrigin)]
_), []) -> [(Module, ModuleOrigin)] -> LookupResult
LookupUnusable [(Module, ModuleOrigin)]
unusable
([(Module, ModuleOrigin)]
hidden_pkg, [(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
_, []) ->
[(Module, ModuleOrigin)]
-> [(Module, ModuleOrigin)] -> LookupResult
LookupHidden [(Module, ModuleOrigin)]
hidden_pkg [(Module, ModuleOrigin)]
hidden_mod
where
classify :: ([(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
[(Module, ModuleOrigin)], [(Module, ModuleOrigin)])
-> (Module, ModuleOrigin)
-> ([(Module, ModuleOrigin)], [(Module, ModuleOrigin)],
[(Module, ModuleOrigin)], [(Module, ModuleOrigin)])
classify ([(Module, ModuleOrigin)]
hidden_pkg, [(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
unusable, [(Module, ModuleOrigin)]
exposed) (Module
m, ModuleOrigin
origin0) =
let origin :: ModuleOrigin
origin = PkgQual -> UnitInfo -> ModuleOrigin -> ModuleOrigin
filterOrigin PkgQual
mb_pn (Module -> UnitInfo
mod_unit Module
m) ModuleOrigin
origin0
x :: (Module, ModuleOrigin)
x = (Module
m, ModuleOrigin
origin)
in case ModuleOrigin
origin of
ModuleOrigin
ModHidden
-> ([(Module, ModuleOrigin)]
hidden_pkg, (Module, ModuleOrigin)
x(Module, ModuleOrigin)
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall a. a -> [a] -> [a]
:[(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
unusable, [(Module, ModuleOrigin)]
exposed)
ModUnusable UnusableUnit
_
-> ([(Module, ModuleOrigin)]
hidden_pkg, [(Module, ModuleOrigin)]
hidden_mod, (Module, ModuleOrigin)
x(Module, ModuleOrigin)
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall a. a -> [a] -> [a]
:[(Module, ModuleOrigin)]
unusable, [(Module, ModuleOrigin)]
exposed)
ModuleOrigin
_ | ModuleOrigin -> Bool
originEmpty ModuleOrigin
origin
-> ([(Module, ModuleOrigin)]
hidden_pkg, [(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
unusable, [(Module, ModuleOrigin)]
exposed)
| ModuleOrigin -> Bool
originVisible ModuleOrigin
origin
-> ([(Module, ModuleOrigin)]
hidden_pkg, [(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
unusable, (Module, ModuleOrigin)
x(Module, ModuleOrigin)
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall a. a -> [a] -> [a]
:[(Module, ModuleOrigin)]
exposed)
| Bool
otherwise
-> ((Module, ModuleOrigin)
x(Module, ModuleOrigin)
-> [(Module, ModuleOrigin)] -> [(Module, ModuleOrigin)]
forall a. a -> [a] -> [a]
:[(Module, ModuleOrigin)]
hidden_pkg, [(Module, ModuleOrigin)]
hidden_mod, [(Module, ModuleOrigin)]
unusable, [(Module, ModuleOrigin)]
exposed)
unit_lookup :: Unit -> UnitInfo
unit_lookup Unit
p = UnitState -> Unit -> Maybe UnitInfo
lookupUnit UnitState
pkgs Unit
p Maybe UnitInfo -> UnitInfo -> UnitInfo
forall a. Maybe a -> a -> a
`orElse` String -> SDoc -> UnitInfo
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"lookupModuleWithSuggestions" (Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unit
p SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m)
mod_unit :: Module -> UnitInfo
mod_unit = Unit -> UnitInfo
unit_lookup (Unit -> UnitInfo) -> (Module -> Unit) -> Module -> UnitInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit
filterOrigin :: PkgQual
-> UnitInfo
-> ModuleOrigin
-> ModuleOrigin
filterOrigin :: PkgQual -> UnitInfo -> ModuleOrigin -> ModuleOrigin
filterOrigin PkgQual
NoPkgQual UnitInfo
_ ModuleOrigin
o = ModuleOrigin
o
filterOrigin (ThisPkg UnitId
_) UnitInfo
_ ModuleOrigin
o = ModuleOrigin
o
filterOrigin (OtherPkg UnitId
u) UnitInfo
pkg ModuleOrigin
o =
let match_pkg :: UnitInfo -> Bool
match_pkg UnitInfo
p = UnitId
u UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
p
in case ModuleOrigin
o of
ModuleOrigin
ModHidden
| UnitInfo -> Bool
match_pkg UnitInfo
pkg -> ModuleOrigin
ModHidden
| Bool
otherwise -> ModuleOrigin
forall a. Monoid a => a
mempty
ModUnusable UnusableUnit
_
| UnitInfo -> Bool
match_pkg UnitInfo
pkg -> ModuleOrigin
o
| Bool
otherwise -> ModuleOrigin
forall a. Monoid a => a
mempty
ModOrigin { fromOrigUnit :: ModuleOrigin -> Maybe Bool
fromOrigUnit = Maybe Bool
e, fromExposedReexport :: ModuleOrigin -> [UnitInfo]
fromExposedReexport = [UnitInfo]
res,
fromHiddenReexport :: ModuleOrigin -> [UnitInfo]
fromHiddenReexport = [UnitInfo]
rhs }
-> ModOrigin
{ fromOrigUnit :: Maybe Bool
fromOrigUnit = if UnitInfo -> Bool
match_pkg UnitInfo
pkg then Maybe Bool
e else Maybe Bool
forall a. Maybe a
Nothing
, fromExposedReexport :: [UnitInfo]
fromExposedReexport = (UnitInfo -> Bool) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter UnitInfo -> Bool
match_pkg [UnitInfo]
res
, fromHiddenReexport :: [UnitInfo]
fromHiddenReexport = (UnitInfo -> Bool) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter UnitInfo -> Bool
match_pkg [UnitInfo]
rhs
, fromPackageFlag :: Bool
fromPackageFlag = Bool
False
}
suggestions :: [ModuleSuggestion]
suggestions = String -> [(String, ModuleSuggestion)] -> [ModuleSuggestion]
forall a. String -> [(String, a)] -> [a]
fuzzyLookup (ModuleName -> String
moduleNameString ModuleName
m) [(String, ModuleSuggestion)]
all_mods
all_mods :: [(String, ModuleSuggestion)]
all_mods :: [(String, ModuleSuggestion)]
all_mods = ((String, ModuleSuggestion)
-> (String, ModuleSuggestion) -> Ordering)
-> [(String, ModuleSuggestion)] -> [(String, ModuleSuggestion)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((String, ModuleSuggestion) -> String)
-> (String, ModuleSuggestion)
-> (String, ModuleSuggestion)
-> Ordering
forall a t. Ord a => (t -> a) -> t -> t -> Ordering
comparing (String, ModuleSuggestion) -> String
forall a b. (a, b) -> a
fst) ([(String, ModuleSuggestion)] -> [(String, ModuleSuggestion)])
-> [(String, ModuleSuggestion)] -> [(String, ModuleSuggestion)]
forall a b. (a -> b) -> a -> b
$
[ (ModuleName -> String
moduleNameString ModuleName
m, ModuleSuggestion
suggestion)
| (ModuleName
m, UniqMap Module ModuleOrigin
e) <- ModuleNameProvidersMap
-> [(ModuleName, UniqMap Module ModuleOrigin)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList (UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap UnitState
pkgs)
, ModuleSuggestion
suggestion <- ((Module, ModuleOrigin) -> ModuleSuggestion)
-> [(Module, ModuleOrigin)] -> [ModuleSuggestion]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> (Module, ModuleOrigin) -> ModuleSuggestion
getSuggestion ModuleName
m) (UniqMap Module ModuleOrigin -> [(Module, ModuleOrigin)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UniqMap Module ModuleOrigin
e)
]
getSuggestion :: ModuleName -> (Module, ModuleOrigin) -> ModuleSuggestion
getSuggestion ModuleName
name (Module
mod, ModuleOrigin
origin) =
(if ModuleOrigin -> Bool
originVisible ModuleOrigin
origin then ModuleName -> Module -> ModuleOrigin -> ModuleSuggestion
SuggestVisible else ModuleName -> Module -> ModuleOrigin -> ModuleSuggestion
SuggestHidden)
ModuleName
name Module
mod ModuleOrigin
origin
listVisibleModuleNames :: UnitState -> [ModuleName]
listVisibleModuleNames :: UnitState -> [ModuleName]
listVisibleModuleNames UnitState
state =
((ModuleName, UniqMap Module ModuleOrigin) -> ModuleName)
-> [(ModuleName, UniqMap Module ModuleOrigin)] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, UniqMap Module ModuleOrigin) -> ModuleName
forall a b. (a, b) -> a
fst (((ModuleName, UniqMap Module ModuleOrigin) -> Bool)
-> [(ModuleName, UniqMap Module ModuleOrigin)]
-> [(ModuleName, UniqMap Module ModuleOrigin)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleName, UniqMap Module ModuleOrigin) -> Bool
forall {a} {k}. (a, UniqMap k ModuleOrigin) -> Bool
visible (ModuleNameProvidersMap
-> [(ModuleName, UniqMap Module ModuleOrigin)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList (UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap UnitState
state)))
where visible :: (a, UniqMap k ModuleOrigin) -> Bool
visible (a
_, UniqMap k ModuleOrigin
ms) = (ModuleOrigin -> Bool) -> UniqMap k ModuleOrigin -> Bool
forall a k. (a -> Bool) -> UniqMap k a -> Bool
anyUniqMap ModuleOrigin -> Bool
originVisible UniqMap k ModuleOrigin
ms
closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
closeUnitDeps :: UnitInfoMap
-> [(UnitId, Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
closeUnitDeps UnitInfoMap
pkg_map [(UnitId, Maybe UnitId)]
ps = UnitInfoMap
-> [UnitId]
-> [(UnitId, Maybe UnitId)]
-> MaybeErr UnitErr [UnitId]
closeUnitDeps' UnitInfoMap
pkg_map [] [(UnitId, Maybe UnitId)]
ps
closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
closeUnitDeps' :: UnitInfoMap
-> [UnitId]
-> [(UnitId, Maybe UnitId)]
-> MaybeErr UnitErr [UnitId]
closeUnitDeps' UnitInfoMap
pkg_map [UnitId]
current_ids [(UnitId, Maybe UnitId)]
ps = ([UnitId] -> (UnitId, Maybe UnitId) -> MaybeErr UnitErr [UnitId])
-> [UnitId]
-> [(UnitId, Maybe UnitId)]
-> MaybeErr UnitErr [UnitId]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((UnitId -> Maybe UnitId -> MaybeErr UnitErr [UnitId])
-> (UnitId, Maybe UnitId) -> MaybeErr UnitErr [UnitId]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((UnitId -> Maybe UnitId -> MaybeErr UnitErr [UnitId])
-> (UnitId, Maybe UnitId) -> MaybeErr UnitErr [UnitId])
-> ([UnitId]
-> UnitId -> Maybe UnitId -> MaybeErr UnitErr [UnitId])
-> [UnitId]
-> (UnitId, Maybe UnitId)
-> MaybeErr UnitErr [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfoMap
-> [UnitId] -> UnitId -> Maybe UnitId -> MaybeErr UnitErr [UnitId]
add_unit UnitInfoMap
pkg_map) [UnitId]
current_ids [(UnitId, Maybe UnitId)]
ps
add_unit :: UnitInfoMap
-> [UnitId]
-> UnitId
-> Maybe UnitId
-> MaybeErr UnitErr [UnitId]
add_unit :: UnitInfoMap
-> [UnitId] -> UnitId -> Maybe UnitId -> MaybeErr UnitErr [UnitId]
add_unit UnitInfoMap
pkg_map [UnitId]
ps UnitId
p Maybe UnitId
mb_parent
| UnitId
p UnitId -> [UnitId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnitId]
ps = [UnitId] -> MaybeErr UnitErr [UnitId]
forall a. a -> MaybeErr UnitErr a
forall (m :: * -> *) a. Monad m => a -> m a
return [UnitId]
ps
| Bool
otherwise = case UnitInfoMap -> UnitId -> Maybe UnitInfo
lookupUnitId' UnitInfoMap
pkg_map UnitId
p of
Maybe UnitInfo
Nothing -> UnitErr -> MaybeErr UnitErr [UnitId]
forall err val. err -> MaybeErr err val
Failed (UnitId -> Maybe UnitId -> UnitErr
CloseUnitErr UnitId
p Maybe UnitId
mb_parent)
Just UnitInfo
info -> do
ps' <- ([UnitId] -> UnitId -> MaybeErr UnitErr [UnitId])
-> [UnitId] -> [UnitId] -> MaybeErr UnitErr [UnitId]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [UnitId] -> UnitId -> MaybeErr UnitErr [UnitId]
add_unit_key [UnitId]
ps (UnitInfo -> [UnitId]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends UnitInfo
info)
return (p : ps')
where
add_unit_key :: [UnitId] -> UnitId -> MaybeErr UnitErr [UnitId]
add_unit_key [UnitId]
xs UnitId
key
= UnitInfoMap
-> [UnitId] -> UnitId -> Maybe UnitId -> MaybeErr UnitErr [UnitId]
add_unit UnitInfoMap
pkg_map [UnitId]
xs UnitId
key (UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just UnitId
p)
data UnitErr
= CloseUnitErr !UnitId !(Maybe UnitId)
| PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)]
| TrustFlagErr !TrustFlag ![(UnitInfo,UnusableUnitReason)]
mayThrowUnitErr :: MaybeErr UnitErr a -> IO a
mayThrowUnitErr :: forall a. MaybeErr UnitErr a -> IO a
mayThrowUnitErr = \case
Failed UnitErr
e -> GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO
(GhcException -> IO a) -> GhcException -> IO a
forall a b. (a -> b) -> a -> b
$ String -> GhcException
CmdLineError
(String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext
(SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle
(SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ UnitErr -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitErr
e
Succeeded a
a -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
instance Outputable UnitErr where
ppr :: UnitErr -> SDoc
ppr = \case
CloseUnitErr UnitId
p Maybe UnitId
mb_parent
-> (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"unknown unit:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
p)
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> case Maybe UnitId
mb_parent of
Maybe UnitId
Nothing -> SDoc
forall doc. IsOutput doc => doc
Outputable.empty
Just UnitId
parent -> SDoc
forall doc. IsLine doc => doc
space SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dependency of"
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (UnitId -> FastString
unitIdFS UnitId
parent))
PackageFlagErr PackageFlag
flag [(UnitInfo, UnusableUnitReason)]
reasons
-> SDoc -> [(UnitInfo, UnusableUnitReason)] -> SDoc
forall {a} {srcpkgid} {srcpkgname} {modulename} {mod}.
Outputable a =>
SDoc
-> [(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
UnusableUnitReason)]
-> SDoc
flag_err (PackageFlag -> SDoc
pprFlag PackageFlag
flag) [(UnitInfo, UnusableUnitReason)]
reasons
TrustFlagErr TrustFlag
flag [(UnitInfo, UnusableUnitReason)]
reasons
-> SDoc -> [(UnitInfo, UnusableUnitReason)] -> SDoc
forall {a} {srcpkgid} {srcpkgname} {modulename} {mod}.
Outputable a =>
SDoc
-> [(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
UnusableUnitReason)]
-> SDoc
flag_err (TrustFlag -> SDoc
pprTrustFlag TrustFlag
flag) [(UnitInfo, UnusableUnitReason)]
reasons
where
flag_err :: SDoc
-> [(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
UnusableUnitReason)]
-> SDoc
flag_err SDoc
flag_doc [(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
UnusableUnitReason)]
reasons =
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cannot satisfy "
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
flag_doc
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> (if [(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
UnusableUnitReason)]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
UnusableUnitReason)]
reasons then SDoc
forall doc. IsOutput doc => doc
Outputable.empty else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
": ")
SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
4 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (((GenericUnitInfo srcpkgid srcpkgname a modulename mod,
UnusableUnitReason)
-> SDoc)
-> [(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
UnusableUnitReason)]
-> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (GenericUnitInfo srcpkgid srcpkgname a modulename mod,
UnusableUnitReason)
-> SDoc
forall {a} {srcpkgid} {srcpkgname} {modulename} {mod}.
Outputable a =>
(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
UnusableUnitReason)
-> SDoc
ppr_reason [(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
UnusableUnitReason)]
reasons) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(use -v for more information)")
ppr_reason :: (GenericUnitInfo srcpkgid srcpkgname a modulename mod,
UnusableUnitReason)
-> SDoc
ppr_reason (GenericUnitInfo srcpkgid srcpkgname a modulename mod
p, UnusableUnitReason
reason) =
SDoc -> UnusableUnitReason -> SDoc
pprReason (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr (GenericUnitInfo srcpkgid srcpkgname a modulename mod -> a
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId GenericUnitInfo srcpkgid srcpkgname a modulename mod
p) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is") UnusableUnitReason
reason
requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule]
requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule]
requirementMerges UnitState
pkgstate ModuleName
mod_name =
[InstantiatedModule]
-> Maybe [InstantiatedModule] -> [InstantiatedModule]
forall a. a -> Maybe a -> a
fromMaybe [] (UniqMap ModuleName [InstantiatedModule]
-> ModuleName -> Maybe [InstantiatedModule]
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap (UnitState -> UniqMap ModuleName [InstantiatedModule]
requirementContext UnitState
pkgstate) ModuleName
mod_name)
pprUnitIdForUser :: UnitState -> UnitId -> SDoc
pprUnitIdForUser :: UnitState -> UnitId -> SDoc
pprUnitIdForUser UnitState
state uid :: UnitId
uid@(UnitId FastString
fs) =
case UnitState -> UnitId -> Maybe UnitPprInfo
lookupUnitPprInfo UnitState
state UnitId
uid of
Maybe UnitPprInfo
Nothing -> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext FastString
fs
Just UnitPprInfo
i -> UnitPprInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitPprInfo
i
pprUnitInfoForUser :: UnitInfo -> SDoc
pprUnitInfoForUser :: UnitInfo -> SDoc
pprUnitInfoForUser UnitInfo
info = UnitPprInfo -> SDoc
forall a. Outputable a => a -> SDoc
ppr ((UnitId -> FastString) -> UnitInfo -> UnitPprInfo
forall u. (u -> FastString) -> GenUnitInfo u -> UnitPprInfo
mkUnitPprInfo UnitId -> FastString
unitIdFS UnitInfo
info)
lookupUnitPprInfo :: UnitState -> UnitId -> Maybe UnitPprInfo
lookupUnitPprInfo :: UnitState -> UnitId -> Maybe UnitPprInfo
lookupUnitPprInfo UnitState
state UnitId
uid = (UnitInfo -> UnitPprInfo) -> Maybe UnitInfo -> Maybe UnitPprInfo
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((UnitId -> FastString) -> UnitInfo -> UnitPprInfo
forall u. (u -> FastString) -> GenUnitInfo u -> UnitPprInfo
mkUnitPprInfo UnitId -> FastString
unitIdFS) (UnitState -> UnitId -> Maybe UnitInfo
lookupUnitId UnitState
state UnitId
uid)
pprUnits :: UnitState -> SDoc
pprUnits :: UnitState -> SDoc
pprUnits = (UnitInfo -> SDoc) -> UnitState -> SDoc
pprUnitsWith UnitInfo -> SDoc
pprUnitInfo
pprUnitsWith :: (UnitInfo -> SDoc) -> UnitState -> SDoc
pprUnitsWith :: (UnitInfo -> SDoc) -> UnitState -> SDoc
pprUnitsWith UnitInfo -> SDoc
pprIPI UnitState
pkgstate =
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"---") ((UnitInfo -> SDoc) -> [UnitInfo] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> SDoc
pprIPI (UnitState -> [UnitInfo]
listUnitInfo UnitState
pkgstate)))
pprUnitsSimple :: UnitState -> SDoc
pprUnitsSimple :: UnitState -> SDoc
pprUnitsSimple = (UnitInfo -> SDoc) -> UnitState -> SDoc
pprUnitsWith UnitInfo -> SDoc
forall {doc} {srcpkgid} {srcpkgname} {modulename} {mod}.
IsLine doc =>
GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod -> doc
pprIPI
where pprIPI :: GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod -> doc
pprIPI GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
ipi = let i :: FastString
i = UnitId -> FastString
unitIdFS (GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
ipi)
e :: doc
e = if GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod -> Bool
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Bool
unitIsExposed GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
ipi then String -> doc
forall doc. IsLine doc => String -> doc
text String
"E" else String -> doc
forall doc. IsLine doc => String -> doc
text String
" "
t :: doc
t = if GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod -> Bool
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Bool
unitIsTrusted GenericUnitInfo srcpkgid srcpkgname UnitId modulename mod
ipi then String -> doc
forall doc. IsLine doc => String -> doc
text String
"T" else String -> doc
forall doc. IsLine doc => String -> doc
text String
" "
in doc
e doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> doc
t doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> doc
forall doc. IsLine doc => String -> doc
text String
" " doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> FastString -> doc
forall doc. IsLine doc => FastString -> doc
ftext FastString
i
pprModuleMap :: ModuleNameProvidersMap -> SDoc
pprModuleMap :: ModuleNameProvidersMap -> SDoc
pprModuleMap ModuleNameProvidersMap
mod_map =
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (((ModuleName, UniqMap Module ModuleOrigin) -> SDoc)
-> [(ModuleName, UniqMap Module ModuleOrigin)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, UniqMap Module ModuleOrigin) -> SDoc
forall {a}. Outputable a => (ModuleName, UniqMap Module a) -> SDoc
pprLine (ModuleNameProvidersMap
-> [(ModuleName, UniqMap Module ModuleOrigin)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList ModuleNameProvidersMap
mod_map))
where
pprLine :: (ModuleName, UniqMap Module a) -> SDoc
pprLine (ModuleName
m,UniqMap Module a
e) = ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
50 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (((Module, a) -> SDoc) -> [(Module, a)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> (Module, a) -> SDoc
forall a. Outputable a => ModuleName -> (Module, a) -> SDoc
pprEntry ModuleName
m) (UniqMap Module a -> [(Module, a)]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UniqMap Module a
e)))
pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc
pprEntry :: forall a. Outputable a => ModuleName -> (Module, a) -> SDoc
pprEntry ModuleName
m (Module
m',a
o)
| ModuleName
m ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
== Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
m' = Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
m') SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
o)
| Bool
otherwise = Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
m' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
o)
fsPackageName :: UnitInfo -> FastString
fsPackageName :: UnitInfo -> FastString
fsPackageName UnitInfo
info = FastString
fs
where
PackageName FastString
fs = UnitInfo -> PackageName
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName UnitInfo
info
improveUnit :: UnitState -> Unit -> Unit
improveUnit :: UnitState -> Unit -> Unit
improveUnit UnitState
state Unit
u = UnitInfoMap -> PreloadUnitClosure -> Unit -> Unit
improveUnit' (UnitState -> UnitInfoMap
unitInfoMap UnitState
state) (UnitState -> PreloadUnitClosure
preloadClosure UnitState
state) Unit
u
improveUnit' :: UnitInfoMap -> PreloadUnitClosure -> Unit -> Unit
improveUnit' :: UnitInfoMap -> PreloadUnitClosure -> Unit -> Unit
improveUnit' UnitInfoMap
_ PreloadUnitClosure
_ uid :: Unit
uid@(RealUnit Definite UnitId
_) = Unit
uid
improveUnit' UnitInfoMap
pkg_map PreloadUnitClosure
closure Unit
uid =
case Bool -> UnitInfoMap -> PreloadUnitClosure -> Unit -> Maybe UnitInfo
lookupUnit' Bool
False UnitInfoMap
pkg_map PreloadUnitClosure
closure Unit
uid of
Maybe UnitInfo
Nothing -> Unit
uid
Just UnitInfo
pkg ->
if UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
pkg UnitId -> PreloadUnitClosure -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` PreloadUnitClosure
closure
then UnitInfo -> Unit
mkUnit UnitInfo
pkg
else Unit
uid
instUnitToUnit :: UnitState -> InstantiatedUnit -> Unit
instUnitToUnit :: UnitState -> GenInstantiatedUnit UnitId -> Unit
instUnitToUnit UnitState
state GenInstantiatedUnit UnitId
iuid =
UnitState -> Unit -> Unit
improveUnit UnitState
state (Unit -> Unit) -> Unit -> Unit
forall a b. (a -> b) -> a -> b
$ GenInstantiatedUnit UnitId -> Unit
forall uid. GenInstantiatedUnit uid -> GenUnit uid
VirtUnit GenInstantiatedUnit UnitId
iuid
type ShHoleSubst = ModuleNameEnv Module
renameHoleModule :: UnitState -> ShHoleSubst -> Module -> Module
renameHoleModule :: UnitState -> UniqFM ModuleName Module -> Module -> Module
renameHoleModule UnitState
state = UnitInfoMap
-> PreloadUnitClosure
-> UniqFM ModuleName Module
-> Module
-> Module
renameHoleModule' (UnitState -> UnitInfoMap
unitInfoMap UnitState
state) (UnitState -> PreloadUnitClosure
preloadClosure UnitState
state)
renameHoleUnit :: UnitState -> ShHoleSubst -> Unit -> Unit
renameHoleUnit :: UnitState -> UniqFM ModuleName Module -> Unit -> Unit
renameHoleUnit UnitState
state = UnitInfoMap
-> PreloadUnitClosure -> UniqFM ModuleName Module -> Unit -> Unit
renameHoleUnit' (UnitState -> UnitInfoMap
unitInfoMap UnitState
state) (UnitState -> PreloadUnitClosure
preloadClosure UnitState
state)
renameHoleModule' :: UnitInfoMap -> PreloadUnitClosure -> ShHoleSubst -> Module -> Module
renameHoleModule' :: UnitInfoMap
-> PreloadUnitClosure
-> UniqFM ModuleName Module
-> Module
-> Module
renameHoleModule' UnitInfoMap
pkg_map PreloadUnitClosure
closure UniqFM ModuleName Module
env Module
m
| Bool -> Bool
not (Module -> Bool
forall u. GenModule (GenUnit u) -> Bool
isHoleModule Module
m) =
let uid :: Unit
uid = UnitInfoMap
-> PreloadUnitClosure -> UniqFM ModuleName Module -> Unit -> Unit
renameHoleUnit' UnitInfoMap
pkg_map PreloadUnitClosure
closure UniqFM ModuleName Module
env (Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit Module
m)
in Unit -> ModuleName -> Module
forall unit. unit -> ModuleName -> GenModule unit
mkModule Unit
uid (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
m)
| Just Module
m' <- UniqFM ModuleName Module -> ModuleName -> Maybe Module
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM ModuleName Module
env (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
m) = Module
m'
| Bool
otherwise = Module
m
renameHoleUnit' :: UnitInfoMap -> PreloadUnitClosure -> ShHoleSubst -> Unit -> Unit
renameHoleUnit' :: UnitInfoMap
-> PreloadUnitClosure -> UniqFM ModuleName Module -> Unit -> Unit
renameHoleUnit' UnitInfoMap
pkg_map PreloadUnitClosure
closure UniqFM ModuleName Module
env Unit
uid =
case Unit
uid of
(VirtUnit
InstantiatedUnit{ instUnitInstanceOf :: forall unit. GenInstantiatedUnit unit -> unit
instUnitInstanceOf = UnitId
cid
, instUnitInsts :: forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts = [(ModuleName, Module)]
insts
, instUnitHoles :: forall unit. GenInstantiatedUnit unit -> UniqDSet ModuleName
instUnitHoles = UniqDSet ModuleName
fh })
-> if UniqFM ModuleName ModuleName -> Bool
forall {k} (key :: k) elt. UniqFM key elt -> Bool
isNullUFM ((ModuleName -> Module -> ModuleName)
-> UniqFM ModuleName ModuleName
-> UniqFM ModuleName Module
-> UniqFM ModuleName ModuleName
forall {k} elt1 elt2 elt3 (key :: k).
(elt1 -> elt2 -> elt3)
-> UniqFM key elt1 -> UniqFM key elt2 -> UniqFM key elt3
intersectUFM_C ModuleName -> Module -> ModuleName
forall a b. a -> b -> a
const (UniqDFM ModuleName ModuleName -> UniqFM ModuleName ModuleName
forall {k} (key :: k) elt. UniqDFM key elt -> UniqFM key elt
udfmToUfm (UniqDSet ModuleName -> UniqDFM ModuleName ModuleName
forall a. UniqDSet a -> UniqDFM a a
getUniqDSet UniqDSet ModuleName
fh)) UniqFM ModuleName Module
env)
then Unit
uid
else UnitInfoMap -> PreloadUnitClosure -> Unit -> Unit
improveUnit' UnitInfoMap
pkg_map PreloadUnitClosure
closure (Unit -> Unit) -> Unit -> Unit
forall a b. (a -> b) -> a -> b
$
UnitId -> [(ModuleName, Module)] -> Unit
forall u.
IsUnitId u =>
u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u
mkVirtUnit UnitId
cid
(((ModuleName, Module) -> (ModuleName, Module))
-> [(ModuleName, Module)] -> [(ModuleName, Module)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ModuleName
k,Module
v) -> (ModuleName
k, UnitInfoMap
-> PreloadUnitClosure
-> UniqFM ModuleName Module
-> Module
-> Module
renameHoleModule' UnitInfoMap
pkg_map PreloadUnitClosure
closure UniqFM ModuleName Module
env Module
v)) [(ModuleName, Module)]
insts)
Unit
_ -> Unit
uid
instModuleToModule :: UnitState -> InstantiatedModule -> Module
instModuleToModule :: UnitState -> InstantiatedModule -> Module
instModuleToModule UnitState
pkgstate (Module GenInstantiatedUnit UnitId
iuid ModuleName
mod_name) =
Unit -> ModuleName -> Module
forall unit. unit -> ModuleName -> GenModule unit
mkModule (UnitState -> GenInstantiatedUnit UnitId -> Unit
instUnitToUnit UnitState
pkgstate GenInstantiatedUnit UnitId
iuid) ModuleName
mod_name
pprWithUnitState :: UnitState -> SDoc -> SDoc
pprWithUnitState :: UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state = (SDocContext -> SDocContext) -> SDoc -> SDoc
updSDocContext (\SDocContext
ctx -> SDocContext
ctx
{ sdocUnitIdForUser = \FastString
fs -> UnitState -> UnitId -> SDoc
pprUnitIdForUser UnitState
state (FastString -> UnitId
UnitId FastString
fs)
})