{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
module GHC.Unit.State (
module GHC.Unit.Info,
UnitState(..),
UnitDatabase (..),
emptyUnitState,
initUnits,
readUnitDatabases,
readUnitDatabase,
getUnitDbRefs,
resolveUnitDatabase,
listUnitInfo,
lookupUnit,
lookupUnit',
unsafeLookupUnit,
lookupUnitId,
lookupUnitId',
unsafeLookupUnitId,
lookupPackageName,
improveUnit,
searchPackageId,
displayUnitId,
listVisibleModuleNames,
lookupModuleInAllUnits,
lookupModuleWithSuggestions,
lookupModulePackage,
lookupPluginModuleWithSuggestions,
LookupResult(..),
ModuleSuggestion(..),
ModuleOrigin(..),
UnusableUnitReason(..),
pprReason,
getUnitIncludePath,
getUnitLibraryPath,
getUnitLinkOpts,
getUnitExtraCcOpts,
getUnitFrameworkPath,
getUnitFrameworks,
getPreloadUnitsAnd,
collectArchives,
collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
packageHsLibs, getLibs,
ShHoleSubst,
renameHoleUnit,
renameHoleModule,
renameHoleUnit',
renameHoleModule',
instUnitToUnit,
instModuleToModule,
mkIndefUnitId,
updateIndefUnitId,
unwireUnit,
pprFlag,
pprUnits,
pprUnitsSimple,
pprModuleMap,
homeUnitIsIndefinite,
homeUnitIsDefinite,
)
where
#include "GhclibHsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.Unit.Database
import GHC.Unit.Info
import GHC.Unit.Types
import GHC.Unit.Module
import GHC.Driver.Session
import GHC.Driver.Ways
import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
import GHC.Types.Unique.Set
import GHC.Types.Unique.DSet
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 GHC.Utils.Error ( debugTraceMsg, MsgDoc, dumpIfSet_dyn,
withTiming, DumpFormat (..) )
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 as List
import Data.Map (Map)
import Data.Set (Set)
import Data.Monoid (First(..))
import qualified Data.Semigroup as Semigroup
import qualified Data.Map as Map
import qualified Data.Map.Strict as MapStrict
import qualified Data.Set as Set
data ModuleOrigin =
ModHidden
| ModUnusable UnusableUnitReason
| ModOrigin {
ModuleOrigin -> Maybe Bool
fromOrigUnit :: Maybe Bool
, ModuleOrigin -> [UnitInfo]
fromExposedReexport :: [UnitInfo]
, ModuleOrigin -> [UnitInfo]
fromHiddenReexport :: [UnitInfo]
, ModuleOrigin -> Bool
fromPackageFlag :: Bool
}
instance Outputable ModuleOrigin where
ppr :: ModuleOrigin -> SDoc
ppr ModuleOrigin
ModHidden = String -> SDoc
text String
"hidden module"
ppr (ModUnusable UnusableUnitReason
_) = String -> SDoc
text String
"unusable module"
ppr (ModOrigin Maybe Bool
e [UnitInfo]
res [UnitInfo]
rhs Bool
f) = [SDoc] -> SDoc
sep (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma (
(case Maybe Bool
e of
Maybe Bool
Nothing -> []
Just Bool
False -> [String -> SDoc
text String
"hidden package"]
Just Bool
True -> [String -> SDoc
text String
"exposed package"]) [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++
(if [UnitInfo] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitInfo]
res
then []
else [String -> SDoc
text String
"reexport by" SDoc -> SDoc -> SDoc
<+>
[SDoc] -> SDoc
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 (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitInfo]
rhs
then []
else [String -> SDoc
text String
"hidden reexport by" SDoc -> SDoc -> SDoc
<+>
[SDoc] -> SDoc
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
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
ModOrigin Maybe Bool
e [UnitInfo]
res [UnitInfo]
rhs Bool
f <> :: ModuleOrigin -> ModuleOrigin -> ModuleOrigin
<> ModOrigin Maybe Bool
e' [UnitInfo]
res' [UnitInfo]
rhs' Bool
f' =
Maybe Bool -> [UnitInfo] -> [UnitInfo] -> Bool -> ModuleOrigin
ModOrigin (Maybe Bool -> Maybe Bool -> Maybe Bool
forall a. Eq a => Maybe a -> Maybe a -> Maybe a
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 a -> Maybe a -> Maybe a
g (Just a
b) (Just a
b')
| a
b a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b' = a -> Maybe a
forall a. a -> Maybe a
Just a
b
| Bool
otherwise = String -> Maybe a
forall a. String -> a
panic String
"ModOrigin: package both exposed/hidden"
g Maybe a
Nothing Maybe a
x = Maybe a
x
g Maybe a
x Maybe a
Nothing = Maybe a
x
ModuleOrigin
_x <> ModuleOrigin
_y = String -> ModuleOrigin
forall a. String -> a
panic String
"ModOrigin: hidden module redefined"
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 UnusableUnitReason
_) = 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 (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 = Map 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 -> Map ModuleName (Set InstantiatedModule)
uv_requirements :: Map ModuleName (Set InstantiatedModule)
, UnitVisibility -> Bool
uv_explicit :: Bool
}
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 -> Map ModuleName (Set InstantiatedModule)
uv_requirements = Map ModuleName (Set InstantiatedModule)
reqs,
uv_explicit :: UnitVisibility -> Bool
uv_explicit = Bool
explicit
}) = (Bool, [(ModuleName, ModuleName)], Maybe FastString,
Map ModuleName (Set InstantiatedModule), Bool)
-> SDoc
forall a. Outputable a => a -> SDoc
ppr (Bool
b, [(ModuleName, ModuleName)]
rns, Maybe FastString
mb_pn, Map ModuleName (Set InstantiatedModule)
reqs, Bool
explicit)
instance Semigroup UnitVisibility where
UnitVisibility
uv1 <> :: UnitVisibility -> UnitVisibility -> UnitVisibility
<> UnitVisibility
uv2
= UnitVisibility :: Bool
-> [(ModuleName, ModuleName)]
-> First FastString
-> Map ModuleName (Set InstantiatedModule)
-> Bool
-> UnitVisibility
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 :: Map ModuleName (Set InstantiatedModule)
uv_requirements = (Set InstantiatedModule
-> Set InstantiatedModule -> Set InstantiatedModule)
-> Map ModuleName (Set InstantiatedModule)
-> Map ModuleName (Set InstantiatedModule)
-> Map ModuleName (Set InstantiatedModule)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set InstantiatedModule
-> Set InstantiatedModule -> Set InstantiatedModule
forall a. Ord a => Set a -> Set a -> Set a
Set.union (UnitVisibility -> Map ModuleName (Set InstantiatedModule)
uv_requirements UnitVisibility
uv1) (UnitVisibility -> Map ModuleName (Set InstantiatedModule)
uv_requirements UnitVisibility
uv2)
, uv_explicit :: Bool
uv_explicit = UnitVisibility -> Bool
uv_explicit UnitVisibility
uv1 Bool -> Bool -> Bool
|| UnitVisibility -> Bool
uv_explicit UnitVisibility
uv2
}
instance Monoid UnitVisibility where
mempty :: UnitVisibility
mempty = UnitVisibility :: Bool
-> [(ModuleName, ModuleName)]
-> First FastString
-> Map ModuleName (Set InstantiatedModule)
-> Bool
-> UnitVisibility
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 :: Map ModuleName (Set InstantiatedModule)
uv_requirements = Map ModuleName (Set InstantiatedModule)
forall k a. Map k a
Map.empty
, uv_explicit :: Bool
uv_explicit = Bool
False
}
mappend :: UnitVisibility -> UnitVisibility -> UnitVisibility
mappend = UnitVisibility -> UnitVisibility -> UnitVisibility
forall a. Semigroup a => a -> a -> a
(Semigroup.<>)
data UnitConfig = UnitConfig
{ UnitConfig -> PlatformMini
unitConfigPlatformArchOs :: !PlatformMini
, UnitConfig -> Set Way
unitConfigWays :: !(Set Way)
, 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 -> Bool
unitConfigAllowVirtualUnits :: !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]
}
initUnitConfig :: DynFlags -> UnitConfig
initUnitConfig :: DynFlags -> UnitConfig
initUnitConfig DynFlags
dflags =
let 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 -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
/= DynFlags -> UnitId
homeUnitId DynFlags
dflags) [UnitId
baseUnitId, UnitId
rtsUnitId]
in UnitConfig :: PlatformMini
-> Set Way
-> String
-> String
-> String
-> String
-> [UnitId]
-> Bool
-> Bool
-> Bool
-> Bool
-> Maybe [UnitDatabase UnitId]
-> [PackageDBFlag]
-> [PackageFlag]
-> [IgnorePackageFlag]
-> [TrustFlag]
-> [PackageFlag]
-> UnitConfig
UnitConfig
{ unitConfigPlatformArchOs :: PlatformMini
unitConfigPlatformArchOs = Platform -> PlatformMini
platformMini (DynFlags -> Platform
targetPlatform DynFlags
dflags)
, unitConfigProgramName :: String
unitConfigProgramName = DynFlags -> String
programName DynFlags
dflags
, unitConfigWays :: Set Way
unitConfigWays = DynFlags -> Set Way
ways DynFlags
dflags
, 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
, unitConfigAllowVirtualUnits :: Bool
unitConfigAllowVirtualUnits = DynFlags -> Bool
homeUnitIsIndefinite DynFlags
dflags
, unitConfigDBCache :: Maybe [UnitDatabase UnitId]
unitConfigDBCache = DynFlags -> Maybe [UnitDatabase UnitId]
unitDatabases DynFlags
dflags
, unitConfigFlagsDB :: [PackageDBFlag]
unitConfigFlagsDB = 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
}
type ModuleNameProvidersMap =
Map ModuleName (Map Module ModuleOrigin)
data UnitState = UnitState {
UnitState -> UnitInfoMap
unitInfoMap :: UnitInfoMap,
UnitState -> PreloadUnitClosure
preloadClosure :: PreloadUnitClosure,
UnitState -> Map PackageName IndefUnitId
packageNameMap :: Map PackageName IndefUnitId,
UnitState -> Map UnitId UnitId
wireMap :: Map UnitId UnitId,
UnitState -> Map UnitId UnitId
unwireMap :: Map UnitId UnitId,
UnitState -> [UnitId]
preloadUnits :: [UnitId],
UnitState -> [Unit]
explicitUnits :: [Unit],
UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap :: !ModuleNameProvidersMap,
UnitState -> ModuleNameProvidersMap
pluginModuleNameProvidersMap :: !ModuleNameProvidersMap,
UnitState -> Map ModuleName [InstantiatedModule]
requirementContext :: Map ModuleName [InstantiatedModule],
UnitState -> Bool
allowVirtualUnits :: !Bool
}
emptyUnitState :: UnitState
emptyUnitState :: UnitState
emptyUnitState = UnitState :: UnitInfoMap
-> PreloadUnitClosure
-> Map PackageName IndefUnitId
-> Map UnitId UnitId
-> Map UnitId UnitId
-> [UnitId]
-> [Unit]
-> ModuleNameProvidersMap
-> ModuleNameProvidersMap
-> Map ModuleName [InstantiatedModule]
-> Bool
-> UnitState
UnitState {
unitInfoMap :: UnitInfoMap
unitInfoMap = UnitInfoMap
forall k a. Map k a
Map.empty,
preloadClosure :: PreloadUnitClosure
preloadClosure = PreloadUnitClosure
forall a. UniqSet a
emptyUniqSet,
packageNameMap :: Map PackageName IndefUnitId
packageNameMap = Map PackageName IndefUnitId
forall k a. Map k a
Map.empty,
wireMap :: Map UnitId UnitId
wireMap = Map UnitId UnitId
forall k a. Map k a
Map.empty,
unwireMap :: Map UnitId UnitId
unwireMap = Map UnitId UnitId
forall k a. Map k a
Map.empty,
preloadUnits :: [UnitId]
preloadUnits = [],
explicitUnits :: [Unit]
explicitUnits = [],
moduleNameProvidersMap :: ModuleNameProvidersMap
moduleNameProvidersMap = ModuleNameProvidersMap
forall k a. Map k a
Map.empty,
pluginModuleNameProvidersMap :: ModuleNameProvidersMap
pluginModuleNameProvidersMap = ModuleNameProvidersMap
forall k a. Map k a
Map.empty,
requirementContext :: Map ModuleName [InstantiatedModule]
requirementContext = Map ModuleName [InstantiatedModule]
forall k a. Map k a
Map.empty,
allowVirtualUnits :: Bool
allowVirtualUnits = Bool
False
}
data UnitDatabase unit = UnitDatabase
{ UnitDatabase unit -> String
unitDatabasePath :: FilePath
, UnitDatabase unit -> [GenUnitInfo unit]
unitDatabaseUnits :: [GenUnitInfo unit]
}
type UnitInfoMap = Map 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 -> UnitId -> UnitInfoMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Definite UnitId -> UnitId
forall unit. Definite unit -> unit
unDefinite Definite UnitId
i) UnitInfoMap
pkg_map
VirtUnit GenInstantiatedUnit UnitId
i
| Bool
allowOnTheFlyInst
->
(UnitInfo -> UnitInfo) -> Maybe UnitInfo -> Maybe UnitInfo
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))
(UnitId -> UnitInfoMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (IndefUnitId -> UnitId
forall unit. Indefinite unit -> unit
indefUnit (GenInstantiatedUnit UnitId -> IndefUnitId
forall unit. GenInstantiatedUnit unit -> Indefinite unit
instUnitInstanceOf GenInstantiatedUnit UnitId
i)) UnitInfoMap
pkg_map)
| Bool
otherwise
->
UnitId -> UnitInfoMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (GenInstantiatedUnit UnitId -> UnitId
virtualUnitId GenInstantiatedUnit UnitId
i) UnitInfoMap
pkg_map
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 = UnitId -> UnitInfoMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
uid UnitInfoMap
db
unsafeLookupUnit :: HasDebugCallStack => UnitState -> Unit -> UnitInfo
unsafeLookupUnit :: 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 :: 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 IndefUnitId
lookupPackageName :: UnitState -> PackageName -> Maybe IndefUnitId
lookupPackageName UnitState
pkgstate PackageName
n = PackageName -> Map PackageName IndefUnitId -> Maybe IndefUnitId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
n (UnitState -> Map PackageName IndefUnitId
packageNameMap UnitState
pkgstate)
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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> srcpkgid
unitPackageId)
(UnitState -> [UnitInfo]
listUnitInfo UnitState
pkgstate)
mkUnitInfoMap :: [UnitInfo] -> UnitInfoMap
mkUnitInfoMap :: [UnitInfo] -> UnitInfoMap
mkUnitInfoMap [UnitInfo]
infos = (UnitInfoMap -> UnitInfo -> UnitInfoMap)
-> UnitInfoMap -> [UnitInfo] -> UnitInfoMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UnitInfoMap -> UnitInfo -> UnitInfoMap
forall srcpkgid srcpkgname.
Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
-> GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
add UnitInfoMap
forall k a. Map k a
Map.empty [UnitInfo]
infos
where
mkVirt :: GenericUnitInfo
IndefUnitId srcpkgid srcpkgname uid ModuleName Module
-> UnitId
mkVirt GenericUnitInfo
IndefUnitId srcpkgid srcpkgname uid ModuleName Module
p = GenInstantiatedUnit UnitId -> UnitId
virtualUnitId (IndefUnitId -> [(ModuleName, Module)] -> GenInstantiatedUnit UnitId
mkInstantiatedUnit (GenericUnitInfo
IndefUnitId srcpkgid srcpkgname uid ModuleName Module
-> IndefUnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> compid
unitInstanceOf GenericUnitInfo
IndefUnitId srcpkgid srcpkgname uid ModuleName Module
p) (GenericUnitInfo
IndefUnitId srcpkgid srcpkgname uid ModuleName Module
-> [(ModuleName, Module)]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, mod)]
unitInstantiations GenericUnitInfo
IndefUnitId srcpkgid srcpkgname uid ModuleName Module
p))
add :: Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
-> GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
add Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
pkg_map GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
p
| Bool -> Bool
not ([(ModuleName, Module)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> [(ModuleName, Module)]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, mod)]
unitInstantiations GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
p))
= UnitId
-> GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
-> Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> UnitId
forall srcpkgid srcpkgname uid.
GenericUnitInfo
IndefUnitId srcpkgid srcpkgname uid ModuleName Module
-> UnitId
mkVirt GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
p) GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
p
(Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
-> Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module))
-> Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
-> Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
forall a b. (a -> b) -> a -> b
$ UnitId
-> GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
-> Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
p) GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
p
(Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
-> Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module))
-> Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
-> Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
forall a b. (a -> b) -> a -> b
$ Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
pkg_map
| Bool
otherwise
= UnitId
-> GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
-> Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
-> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
p) GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module
p Map
UnitId
(GenericUnitInfo
IndefUnitId srcpkgid srcpkgname UnitId ModuleName Module)
pkg_map
listUnitInfo :: UnitState -> [UnitInfo]
listUnitInfo :: UnitState -> [UnitInfo]
listUnitInfo UnitState
state = UnitInfoMap -> [UnitInfo]
forall k a. Map k a -> [a]
Map.elems (UnitState -> UnitInfoMap
unitInfoMap UnitState
state)
initUnits :: DynFlags -> IO DynFlags
initUnits :: DynFlags -> IO DynFlags
initUnits DynFlags
dflags = do
let forceUnitInfoMap :: (UnitState, b) -> ()
forceUnitInfoMap (UnitState
state, b
_) = UnitState -> UnitInfoMap
unitInfoMap UnitState
state UnitInfoMap -> () -> ()
`seq` ()
let ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle
let printer :: Int -> SDoc -> IO ()
printer = DynFlags -> Int -> SDoc -> IO ()
debugTraceMsg DynFlags
dflags
(UnitState
state,[UnitDatabase UnitId]
dbs) <- DynFlags
-> SDoc
-> ((UnitState, [UnitDatabase UnitId]) -> ())
-> IO (UnitState, [UnitDatabase UnitId])
-> IO (UnitState, [UnitDatabase UnitId])
forall (m :: * -> *) a.
MonadIO m =>
DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming DynFlags
dflags (String -> SDoc
text String
"initializing unit database")
(UnitState, [UnitDatabase UnitId]) -> ()
forall b. (UnitState, b) -> ()
forceUnitInfoMap
(SDocContext
-> (Int -> SDoc -> IO ())
-> UnitConfig
-> IO (UnitState, [UnitDatabase UnitId])
mkUnitState SDocContext
ctx Int -> SDoc -> IO ()
printer (DynFlags -> UnitConfig
initUnitConfig DynFlags
dflags))
DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn (DynFlags
dflags { pprCols :: Int
pprCols = Int
200 }) DumpFlag
Opt_D_dump_mod_map String
"Module Map"
DumpFormat
FormatText (ModuleNameProvidersMap -> SDoc
pprModuleMap (UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap UnitState
state))
let dflags' :: DynFlags
dflags' = DynFlags
dflags
{ unitDatabases :: Maybe [UnitDatabase UnitId]
unitDatabases = [UnitDatabase UnitId] -> Maybe [UnitDatabase UnitId]
forall a. a -> Maybe a
Just [UnitDatabase UnitId]
dbs
, unitState :: UnitState
unitState = UnitState
state
}
dflags'' :: DynFlags
dflags'' = DynFlags -> DynFlags
upd_wired_in_home_instantiations DynFlags
dflags'
DynFlags -> IO DynFlags
forall (m :: * -> *) a. Monad m => a -> m a
return DynFlags
dflags''
readUnitDatabases :: (Int -> SDoc -> IO ()) -> UnitConfig -> IO [UnitDatabase UnitId]
readUnitDatabases :: (Int -> SDoc -> IO ()) -> UnitConfig -> IO [UnitDatabase UnitId]
readUnitDatabases Int -> SDoc -> IO ()
printer UnitConfig
cfg = do
[PkgDbRef]
conf_refs <- UnitConfig -> IO [PkgDbRef]
getUnitDbRefs UnitConfig
cfg
[String]
confs <- ([Maybe String] -> [String]) -> IO [Maybe String] -> IO [String]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe String] -> IO [String])
-> IO [Maybe String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (PkgDbRef -> IO (Maybe String)) -> [PkgDbRef] -> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (UnitConfig -> PkgDbRef -> IO (Maybe String)
resolveUnitDatabase UnitConfig
cfg) [PkgDbRef]
conf_refs
(String -> IO (UnitDatabase UnitId))
-> [String] -> IO [UnitDatabase UnitId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Int -> SDoc -> IO ())
-> UnitConfig -> String -> IO (UnitDatabase UnitId)
readUnitDatabase Int -> SDoc -> IO ()
printer UnitConfig
cfg) [String]
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]
Either IOException String
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 :: [PkgDbRef]
base_conf_refs = case Either IOException String
e_pkg_path of
Left IOException
_ -> [PkgDbRef]
system_conf_refs
Right String
path
| Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
path) Bool -> Bool -> Bool
&& Char -> Bool
isSearchPathSeparator (String -> Char
forall a. [a] -> a
last String
path)
-> (String -> PkgDbRef) -> [String] -> [PkgDbRef]
forall a b. (a -> b) -> [a] -> [b]
map String -> PkgDbRef
PkgDbPath (String -> [String]
splitSearchPath (String -> String
forall a. [a] -> [a]
init String
path)) [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)
[PkgDbRef] -> IO [PkgDbRef]
forall (m :: * -> *) a. Monad m => a -> m a
return ([PkgDbRef] -> IO [PkgDbRef]) -> [PkgDbRef] -> IO [PkgDbRef]
forall a b. (a -> b) -> a -> b
$ [PkgDbRef] -> [PkgDbRef]
forall a. [a] -> [a]
reverse ((PackageDBFlag -> [PkgDbRef] -> [PkgDbRef])
-> [PkgDbRef] -> [PackageDBFlag] -> [PkgDbRef]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PackageDBFlag -> [PkgDbRef] -> [PkgDbRef]
doFlag [PkgDbRef]
base_conf_refs (UnitConfig -> [PackageDBFlag]
unitConfigFlagsDB UnitConfig
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 (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
String
dir <- String -> PlatformMini -> MaybeT IO String
versionedAppDir (UnitConfig -> String
unitConfigProgramName UnitConfig
cfg) (UnitConfig -> PlatformMini
unitConfigPlatformArchOs UnitConfig
cfg)
let pkgconf :: String
pkgconf = String
dir String -> String -> String
</> UnitConfig -> String
unitConfigDBName UnitConfig
cfg
Bool
exist <- IO Bool -> MaybeT IO Bool
forall a. IO a -> MaybeT IO a
tryMaybeT (IO Bool -> MaybeT IO Bool) -> IO Bool -> MaybeT IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesDirectoryExist String
pkgconf
if Bool
exist then String -> MaybeT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
pkgconf else MaybeT IO String
forall (m :: * -> *) a. MonadPlus m => m a
mzero
resolveUnitDatabase UnitConfig
_ (PkgDbPath String
name) = Maybe String -> IO (Maybe String)
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 :: (Int -> SDoc -> IO ()) -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId)
readUnitDatabase :: (Int -> SDoc -> IO ())
-> UnitConfig -> String -> IO (UnitDatabase UnitId)
readUnitDatabase Int -> SDoc -> IO ()
printer UnitConfig
cfg String
conf_file = do
Bool
isdir <- String -> IO Bool
doesDirectoryExist String
conf_file
[DbUnitInfo]
proto_pkg_configs <-
if Bool
isdir
then String -> IO [DbUnitInfo]
readDirStyleUnitInfo String
conf_file
else do
Bool
isfile <- String -> IO Bool
doesFileExist String
conf_file
if Bool
isfile
then do
Maybe [DbUnitInfo]
mpkgs <- IO (Maybe [DbUnitInfo])
tryReadOldFileStyleUnitInfo
case Maybe [DbUnitInfo]
mpkgs of
Just [DbUnitInfo]
pkgs -> [DbUnitInfo] -> IO [DbUnitInfo]
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 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
"can't find a package database at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
conf_file
let
conf_file' :: String
conf_file' = String -> String
dropTrailingPathSeparator String
conf_file
top_dir :: String
top_dir = UnitConfig -> String
unitConfigGHCDir UnitConfig
cfg
pkgroot :: String
pkgroot = String -> String
takeDirectory String
conf_file'
pkg_configs1 :: [UnitInfo]
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)
-> (UnitId -> FastString) -> GenUnitInfo UnitKey -> UnitInfo
forall u v.
(u -> v) -> (v -> FastString) -> GenUnitInfo u -> GenUnitInfo v
mapUnitInfo (\(UnitKey FastString
x) -> FastString -> UnitId
UnitId FastString
x) UnitId -> FastString
unitIdFS (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
UnitDatabase UnitId -> IO (UnitDatabase UnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitDatabase UnitId -> IO (UnitDatabase UnitId))
-> UnitDatabase UnitId -> IO (UnitDatabase UnitId)
forall a b. (a -> b) -> a -> b
$ String -> [UnitInfo] -> UnitDatabase UnitId
forall unit. String -> [GenUnitInfo unit] -> UnitDatabase unit
UnitDatabase String
conf_file' [UnitInfo]
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"
Bool
cache_exists <- String -> IO Bool
doesFileExist String
filename
if Bool
cache_exists
then do
Int -> SDoc -> IO ()
printer Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"Using binary package database:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
filename
String -> IO [DbUnitInfo]
readPackageDbForGhc String
filename
else do
Int -> SDoc -> IO ()
printer Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"There is no package.cache in"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
conf_dir
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
", checking if the database is empty"
Bool
db_empty <- (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
".conf")
([String] -> Bool) -> IO [String] -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getDirectoryContents String
conf_dir
if Bool
db_empty
then do
Int -> SDoc -> IO ()
printer Int
3 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> SDoc
text String
"There are no .conf files in"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
conf_dir SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
", treating"
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"package database as empty"
[DbUnitInfo] -> IO [DbUnitInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else do
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
"there is no package.cache in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
conf_dir String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" even though package database is not empty"
tryReadOldFileStyleUnitInfo :: IO (Maybe [DbUnitInfo])
tryReadOldFileStyleUnitInfo = do
String
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 (m :: * -> *) a. Monad m => a -> m a
return String
""
if Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
2 String
content String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"[]"
then do
let conf_dir :: String
conf_dir = String
conf_file String -> String -> String
<.> String
"d"
Bool
direxists <- String -> IO Bool
doesDirectoryExist String
conf_dir
if Bool
direxists
then do Int -> SDoc -> IO ()
printer Int
2 (String -> SDoc
text String
"Ignoring old file-style db and trying:" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
conf_dir)
([DbUnitInfo] -> Maybe [DbUnitInfo])
-> IO [DbUnitInfo] -> IO (Maybe [DbUnitInfo])
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [DbUnitInfo] -> Maybe [DbUnitInfo]
forall a. a -> Maybe a
Just (String -> IO [DbUnitInfo]
readDirStyleUnitInfo String
conf_dir)
else Maybe [DbUnitInfo] -> IO (Maybe [DbUnitInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return ([DbUnitInfo] -> Maybe [DbUnitInfo]
forall a. a -> Maybe a
Just [])
else Maybe [DbUnitInfo] -> IO (Maybe [DbUnitInfo])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [DbUnitInfo]
forall a. Maybe a
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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
distrust [UnitInfo]
pkgs
where
distrust :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
distrust GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
pkg = GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
pkg{ unitIsTrusted :: Bool
unitIsTrusted = Bool
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
. String -> String -> UnitInfo -> UnitInfo
forall a b c d e f.
String
-> String
-> GenericUnitInfo a b c d e f
-> GenericUnitInfo a b c d e f
mungeUnitInfoPaths String
top_dir String
pkgroot
mungeDynLibFields :: UnitInfo -> UnitInfo
mungeDynLibFields :: UnitInfo -> UnitInfo
mungeDynLibFields UnitInfo
pkg =
UnitInfo
pkg {
unitLibraryDynDirs :: [String]
unitLibraryDynDirs = case UnitInfo -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitLibraryDynDirs UnitInfo
pkg of
[] -> UnitInfo -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitLibraryDirs UnitInfo
pkg
[String]
ds -> [String]
ds
}
applyTrustFlag
:: SDocContext
-> UnitPrecedenceMap
-> UnusableUnits
-> [UnitInfo]
-> TrustFlag
-> IO [UnitInfo]
applyTrustFlag :: SDocContext
-> UnitPrecedenceMap
-> UnusableUnits
-> [UnitInfo]
-> TrustFlag
-> IO [UnitInfo]
applyTrustFlag SDocContext
ctx 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 -> SDocContext
-> TrustFlag -> [(UnitInfo, UnusableUnitReason)] -> IO [UnitInfo]
forall a.
SDocContext
-> TrustFlag -> [(UnitInfo, UnusableUnitReason)] -> IO a
trustFlagErr SDocContext
ctx TrustFlag
flag [(UnitInfo, UnusableUnitReason)]
ps
Right ([UnitInfo]
ps,[UnitInfo]
qs) -> [UnitInfo] -> IO [UnitInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ((UnitInfo -> UnitInfo) -> [UnitInfo] -> [UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitInfo
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
trust [UnitInfo]
ps [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ [UnitInfo]
qs)
where trust :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
trust GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
p = GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
p {unitIsTrusted :: Bool
unitIsTrusted=Bool
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 -> SDocContext
-> TrustFlag -> [(UnitInfo, UnusableUnitReason)] -> IO [UnitInfo]
forall a.
SDocContext
-> TrustFlag -> [(UnitInfo, UnusableUnitReason)] -> IO a
trustFlagErr SDocContext
ctx TrustFlag
flag [(UnitInfo, UnusableUnitReason)]
ps
Right ([UnitInfo]
ps,[UnitInfo]
qs) -> [UnitInfo] -> IO [UnitInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ([UnitInfo] -> [UnitInfo]
distrustAllUnits [UnitInfo]
ps [UnitInfo] -> [UnitInfo] -> [UnitInfo]
forall a. [a] -> [a] -> [a]
++ [UnitInfo]
qs)
homeUnitIsIndefinite :: DynFlags -> Bool
homeUnitIsIndefinite :: DynFlags -> Bool
homeUnitIsIndefinite DynFlags
dflags = Bool -> Bool
not (DynFlags -> Bool
homeUnitIsDefinite DynFlags
dflags)
homeUnitIsDefinite :: DynFlags -> Bool
homeUnitIsDefinite :: DynFlags -> Bool
homeUnitIsDefinite DynFlags
dflags = Unit -> Bool
unitIsDefinite (DynFlags -> Unit
homeUnit DynFlags
dflags)
applyPackageFlag
:: SDocContext
-> UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> UnusableUnits
-> Bool
-> [UnitInfo]
-> VisibilityMap
-> PackageFlag
-> IO VisibilityMap
applyPackageFlag :: SDocContext
-> UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> UnusableUnits
-> Bool
-> [UnitInfo]
-> VisibilityMap
-> PackageFlag
-> IO VisibilityMap
applyPackageFlag SDocContext
ctx 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 -> SDocContext
-> PackageFlag
-> [(UnitInfo, UnusableUnitReason)]
-> IO VisibilityMap
forall a.
SDocContext
-> PackageFlag -> [(UnitInfo, UnusableUnitReason)] -> IO a
packageFlagErr SDocContext
ctx PackageFlag
flag [(UnitInfo, UnusableUnitReason)]
ps
Right (UnitInfo
p:[UnitInfo]
_) -> VisibilityMap -> IO VisibilityMap
forall (m :: * -> *) a. Monad m => a -> m a
return VisibilityMap
vm'
where
n :: FastString
n = UnitInfo -> FastString
fsPackageName UnitInfo
p
reqs :: Map ModuleName (Set InstantiatedModule)
reqs | UnitIdArg Unit
orig_uid <- PackageArg
arg = Unit -> Map ModuleName (Set InstantiatedModule)
forall uid.
GenUnit uid
-> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))
collectHoles Unit
orig_uid
| Bool
otherwise = Map ModuleName (Set InstantiatedModule)
forall k a. Map k a
Map.empty
collectHoles :: GenUnit uid
-> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))
collectHoles GenUnit uid
uid = case GenUnit uid
uid of
GenUnit uid
HoleUnit -> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))
forall k a. Map k a
Map.empty
RealUnit {} -> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))
forall k a. Map k a
Map.empty
VirtUnit GenInstantiatedUnit uid
indef ->
let local :: [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
local = [ ModuleName
-> Set (GenModule (GenInstantiatedUnit uid))
-> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))
forall k a. k -> a -> Map k a
Map.singleton
(GenModule (GenUnit uid) -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule (GenUnit uid)
mod)
(GenModule (GenInstantiatedUnit uid)
-> Set (GenModule (GenInstantiatedUnit uid))
forall a. a -> Set a
Set.singleton (GenModule (GenInstantiatedUnit uid)
-> Set (GenModule (GenInstantiatedUnit uid)))
-> GenModule (GenInstantiatedUnit uid)
-> Set (GenModule (GenInstantiatedUnit uid))
forall a b. (a -> b) -> a -> b
$ GenInstantiatedUnit uid
-> ModuleName -> GenModule (GenInstantiatedUnit uid)
forall unit. unit -> ModuleName -> GenModule unit
Module GenInstantiatedUnit uid
indef ModuleName
mod_name)
| (ModuleName
mod_name, GenModule (GenUnit uid)
mod) <- GenInstantiatedUnit uid -> GenInstantiations uid
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit uid
indef
, GenModule (GenUnit uid) -> Bool
forall u. GenModule (GenUnit u) -> Bool
isHoleModule GenModule (GenUnit uid)
mod ]
recurse :: [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
recurse = [ GenUnit uid
-> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))
collectHoles (GenModule (GenUnit uid) -> GenUnit uid
forall unit. GenModule unit -> unit
moduleUnit GenModule (GenUnit uid)
mod)
| (ModuleName
_, GenModule (GenUnit uid)
mod) <- GenInstantiatedUnit uid -> GenInstantiations uid
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit uid
indef ]
in (Set (GenModule (GenInstantiatedUnit uid))
-> Set (GenModule (GenInstantiatedUnit uid))
-> Set (GenModule (GenInstantiatedUnit uid)))
-> [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
-> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Set (GenModule (GenInstantiatedUnit uid))
-> Set (GenModule (GenInstantiatedUnit uid))
-> Set (GenModule (GenInstantiatedUnit uid))
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
-> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid))))
-> [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
-> Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))
forall a b. (a -> b) -> a -> b
$ [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
local [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
-> [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
-> [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
forall a. [a] -> [a] -> [a]
++ [Map ModuleName (Set (GenModule (GenInstantiatedUnit uid)))]
recurse
uv :: UnitVisibility
uv = UnitVisibility :: Bool
-> [(ModuleName, ModuleName)]
-> First FastString
-> Map ModuleName (Set InstantiatedModule)
-> Bool
-> UnitVisibility
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 :: Map ModuleName (Set InstantiatedModule)
uv_requirements = Map ModuleName (Set InstantiatedModule)
reqs
, uv_explicit :: Bool
uv_explicit = Bool
True
}
vm' :: VisibilityMap
vm' = (UnitVisibility -> UnitVisibility -> UnitVisibility)
-> Unit -> UnitVisibility -> VisibilityMap -> VisibilityMap
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith UnitVisibility -> UnitVisibility -> UnitVisibility
forall a. Monoid a => a -> a -> a
mappend (UnitInfo -> Unit
mkUnit UnitInfo
p) UnitVisibility
uv VisibilityMap
vm_cleared
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) -> Map k a -> Map k a
Map.filterWithKey
(\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 -> IO VisibilityMap
forall a. 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 -> SDocContext
-> PackageFlag
-> [(UnitInfo, UnusableUnitReason)]
-> IO VisibilityMap
forall a.
SDocContext
-> PackageFlag -> [(UnitInfo, UnusableUnitReason)] -> IO a
packageFlagErr SDocContext
ctx PackageFlag
flag [(UnitInfo, UnusableUnitReason)]
ps
Right [UnitInfo]
ps -> VisibilityMap -> IO VisibilityMap
forall (m :: * -> *) a. Monad m => a -> m a
return VisibilityMap
vm'
where vm' :: VisibilityMap
vm' = (VisibilityMap -> Unit -> VisibilityMap)
-> VisibilityMap -> [Unit] -> VisibilityMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Unit -> VisibilityMap -> VisibilityMap)
-> VisibilityMap -> Unit -> VisibilityMap
forall a b c. (a -> b -> c) -> b -> a -> c
flip Unit -> VisibilityMap -> VisibilityMap
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete) 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 (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \UnitInfo
x' -> (UnitInfo, UnusableUnitReason)
-> Maybe (UnitInfo, UnusableUnitReason)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitInfo
x',UnusableUnitReason
y))
(UnusableUnits -> [(UnitInfo, UnusableUnitReason)]
forall k a. Map k a -> [a]
Map.elems 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
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
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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId UnitInfo
p
-> UnitInfo -> Maybe UnitInfo
forall a. a -> Maybe a
Just UnitInfo
p
VirtUnit GenInstantiatedUnit UnitId
inst
| IndefUnitId -> UnitId
forall unit. Indefinite unit -> unit
indefUnit (GenInstantiatedUnit UnitId -> IndefUnitId
forall unit. GenInstantiatedUnit unit -> Indefinite unit
instUnitInstanceOf GenInstantiatedUnit UnitId
inst) UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid 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 (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. Map k a -> [a]
Map.elems 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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, mod)]
unitInstantiations UnitInfo
conf)
in UnitInfo
conf {
unitInstantiations :: [(ModuleName, Module)]
unitInstantiations = [(ModuleName, Module)]
new_insts,
unitExposedModules :: [(ModuleName, Maybe Module)]
unitExposedModules = ((ModuleName, Maybe Module) -> (ModuleName, Maybe Module))
-> [(ModuleName, Maybe Module)] -> [(ModuleName, Maybe Module)]
forall a b. (a -> b) -> [a] -> [b]
map (\(ModuleName
mod_name, Maybe Module
mb_mod) -> (ModuleName
mod_name, (Module -> Module) -> Maybe Module -> Maybe Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Module -> Module
smod Maybe Module
mb_mod))
(UnitInfo -> [(ModuleName, Maybe Module)]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, Maybe mod)]
unitExposedModules UnitInfo
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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid 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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Version
unitPackageVersion UnitInfo
pkg UnitInfo
pkg' of
Ordering
GT -> Ordering
GT
Ordering
EQ | Just Int
prec <- UnitId -> UnitPrecedenceMap -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId UnitInfo
pkg) UnitPrecedenceMap
prec_map
, Just Int
prec' <- UnitId -> UnitPrecedenceMap -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId UnitInfo
pkg') UnitPrecedenceMap
prec_map
-> 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 :: (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
packageFlagErr :: SDocContext
-> PackageFlag
-> [(UnitInfo, UnusableUnitReason)]
-> IO a
packageFlagErr :: SDocContext
-> PackageFlag -> [(UnitInfo, UnusableUnitReason)] -> IO a
packageFlagErr SDocContext
ctx PackageFlag
flag [(UnitInfo, UnusableUnitReason)]
reasons
= SDocContext -> SDoc -> [(UnitInfo, UnusableUnitReason)] -> IO a
forall a.
SDocContext -> SDoc -> [(UnitInfo, UnusableUnitReason)] -> IO a
packageFlagErr' SDocContext
ctx (PackageFlag -> SDoc
pprFlag PackageFlag
flag) [(UnitInfo, UnusableUnitReason)]
reasons
trustFlagErr :: SDocContext
-> TrustFlag
-> [(UnitInfo, UnusableUnitReason)]
-> IO a
trustFlagErr :: SDocContext
-> TrustFlag -> [(UnitInfo, UnusableUnitReason)] -> IO a
trustFlagErr SDocContext
ctx TrustFlag
flag [(UnitInfo, UnusableUnitReason)]
reasons
= SDocContext -> SDoc -> [(UnitInfo, UnusableUnitReason)] -> IO a
forall a.
SDocContext -> SDoc -> [(UnitInfo, UnusableUnitReason)] -> IO a
packageFlagErr' SDocContext
ctx (TrustFlag -> SDoc
pprTrustFlag TrustFlag
flag) [(UnitInfo, UnusableUnitReason)]
reasons
packageFlagErr' :: SDocContext
-> SDoc
-> [(UnitInfo, UnusableUnitReason)]
-> IO a
packageFlagErr' :: SDocContext -> SDoc -> [(UnitInfo, UnusableUnitReason)] -> IO a
packageFlagErr' SDocContext
ctx SDoc
flag_doc [(UnitInfo, UnusableUnitReason)]
reasons
= GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
CmdLineError (SDocContext -> SDoc -> String
renderWithStyle SDocContext
ctx (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ SDoc
err))
where err :: SDoc
err = String -> SDoc
text String
"cannot satisfy " SDoc -> SDoc -> SDoc
<> SDoc
flag_doc SDoc -> SDoc -> SDoc
<>
(if [(UnitInfo, UnusableUnitReason)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(UnitInfo, UnusableUnitReason)]
reasons then SDoc
Outputable.empty else String -> SDoc
text String
": ") SDoc -> SDoc -> SDoc
$$
Int -> SDoc -> SDoc
nest Int
4 (SDoc
ppr_reasons SDoc -> SDoc -> SDoc
$$
String -> SDoc
text String
"(use -v for more information)")
ppr_reasons :: SDoc
ppr_reasons = [SDoc] -> SDoc
vcat (((UnitInfo, UnusableUnitReason) -> SDoc)
-> [(UnitInfo, UnusableUnitReason)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (UnitInfo, UnusableUnitReason) -> SDoc
forall a compid srcpkgid srcpkgname modulename mod.
Outputable a =>
(GenericUnitInfo compid srcpkgid srcpkgname a modulename mod,
UnusableUnitReason)
-> SDoc
ppr_reason [(UnitInfo, UnusableUnitReason)]
reasons)
ppr_reason :: (GenericUnitInfo compid srcpkgid srcpkgname a modulename mod,
UnusableUnitReason)
-> SDoc
ppr_reason (GenericUnitInfo compid srcpkgid srcpkgname a modulename mod
p, UnusableUnitReason
reason) =
SDoc -> UnusableUnitReason -> SDoc
pprReason (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr (GenericUnitInfo compid srcpkgid srcpkgname a modulename mod -> a
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId GenericUnitInfo compid srcpkgid srcpkgname a modulename mod
p) SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is") UnusableUnitReason
reason
pprFlag :: PackageFlag -> SDoc
pprFlag :: PackageFlag -> SDoc
pprFlag PackageFlag
flag = case PackageFlag
flag of
HidePackage String
p -> String -> SDoc
text String
"-hide-package " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
p
ExposePackage String
doc PackageArg
_ ModRenaming
_ -> String -> SDoc
text String
doc
pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag TrustFlag
flag = case TrustFlag
flag of
TrustPackage String
p -> String -> SDoc
text String
"-trust " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
p
DistrustPackage String
p -> String -> SDoc
text String
"-distrust " SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
p
type WiringMap = Map UnitId UnitId
findWiredInUnits
:: (SDoc -> IO ())
-> UnitPrecedenceMap
-> [UnitInfo]
-> VisibilityMap
-> IO ([UnitInfo],
WiringMap)
findWiredInUnits :: (SDoc -> IO ())
-> UnitPrecedenceMap
-> [UnitInfo]
-> VisibilityMap
-> IO ([UnitInfo], Map UnitId UnitId)
findWiredInUnits SDoc -> IO ()
printer 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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid 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 =
let 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
, Unit -> VisibilityMap -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member (UnitInfo -> Unit
mkUnit UnitInfo
p) VisibilityMap
vis_map ] in
case [UnitInfo]
all_exposed_ps of
[] -> case [UnitInfo]
all_ps of
[] -> IO (Maybe (UnitId, UnitInfo))
forall a. IO (Maybe a)
notfound
[UnitInfo]
many -> UnitInfo -> IO (Maybe (UnitId, UnitInfo))
pick ([UnitInfo] -> UnitInfo
forall a. [a] -> a
head (UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
sortByPreference UnitPrecedenceMap
prec_map [UnitInfo]
many))
[UnitInfo]
many -> UnitInfo -> IO (Maybe (UnitId, UnitInfo))
pick ([UnitInfo] -> UnitInfo
forall a. [a] -> a
head (UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
sortByPreference UnitPrecedenceMap
prec_map [UnitInfo]
many))
where
notfound :: IO (Maybe a)
notfound = do
SDoc -> IO ()
printer (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"wired-in package "
SDoc -> SDoc -> SDoc
<> FastString -> SDoc
ftext (UnitId -> FastString
unitIdFS UnitId
wired_pkg)
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" not found."
Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
pick :: UnitInfo -> IO (Maybe (UnitId, UnitInfo))
pick :: UnitInfo -> IO (Maybe (UnitId, UnitInfo))
pick UnitInfo
pkg = do
SDoc -> IO ()
printer (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"wired-in package "
SDoc -> SDoc -> SDoc
<> FastString -> SDoc
ftext (UnitId -> FastString
unitIdFS UnitId
wired_pkg)
SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" mapped to "
SDoc -> SDoc -> SDoc
<> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr (UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId UnitInfo
pkg)
Maybe (UnitId, UnitInfo) -> IO (Maybe (UnitId, UnitInfo))
forall (m :: * -> *) a. Monad m => a -> m a
return ((UnitId, UnitInfo) -> Maybe (UnitId, UnitInfo)
forall a. a -> Maybe a
Just (UnitId
wired_pkg, UnitInfo
pkg))
[Maybe (UnitId, UnitInfo)]
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)
mapM ([UnitInfo] -> UnitId -> IO (Maybe (UnitId, UnitInfo))
findWiredInUnit [UnitInfo]
pkgs) [UnitId]
wiredInUnitIds
let
wired_in_pkgs :: [(UnitId, UnitInfo)]
wired_in_pkgs = [Maybe (UnitId, UnitInfo)] -> [(UnitId, UnitInfo)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (UnitId, UnitInfo)]
mb_wired_in_pkgs
wiredInMap :: Map UnitId UnitId
wiredInMap :: Map UnitId UnitId
wiredInMap = [(UnitId, UnitId)] -> Map UnitId UnitId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (UnitInfo -> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid 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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitIsIndefinite UnitInfo
realUnitInfo)
]
updateWiredInDependencies :: [GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module]
-> [GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module]
updateWiredInDependencies [GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module]
pkgs = (GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
-> GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module)
-> [GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module]
-> [GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module]
forall a b. (a -> b) -> [a] -> [b]
map (GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
-> GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
forall compid srcpkgid srcpkgname a.
GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
-> GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
upd_deps (GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
-> GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module)
-> (GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
-> GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module)
-> GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
-> GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
-> GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module
forall (f :: * -> *) srcpkgid srcpkgname modulename mod.
Functor f =>
GenericUnitInfo
(f UnitId) srcpkgid srcpkgname UnitId modulename mod
-> GenericUnitInfo
(f UnitId) srcpkgid srcpkgname UnitId modulename mod
upd_pkg) [GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module]
pkgs
where upd_pkg :: GenericUnitInfo
(f UnitId) srcpkgid srcpkgname UnitId modulename mod
-> GenericUnitInfo
(f UnitId) srcpkgid srcpkgname UnitId modulename mod
upd_pkg GenericUnitInfo
(f UnitId) srcpkgid srcpkgname UnitId modulename mod
pkg
| Just UnitId
wiredInUnitId <- UnitId -> Map UnitId UnitId -> Maybe UnitId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (GenericUnitInfo
(f UnitId) srcpkgid srcpkgname UnitId modulename mod
-> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId GenericUnitInfo
(f UnitId) srcpkgid srcpkgname UnitId modulename mod
pkg) Map UnitId UnitId
wiredInMap
= GenericUnitInfo
(f UnitId) srcpkgid srcpkgname UnitId modulename mod
pkg { unitId :: UnitId
unitId = UnitId
wiredInUnitId
, unitInstanceOf :: f UnitId
unitInstanceOf = (UnitId -> UnitId) -> f UnitId -> f UnitId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (UnitId -> UnitId -> UnitId
forall a b. a -> b -> a
const UnitId
wiredInUnitId) (GenericUnitInfo
(f UnitId) srcpkgid srcpkgname UnitId modulename mod
-> f UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> compid
unitInstanceOf GenericUnitInfo
(f UnitId) srcpkgid srcpkgname UnitId modulename mod
pkg)
}
| Bool
otherwise
= GenericUnitInfo
(f UnitId) srcpkgid srcpkgname UnitId modulename mod
pkg
upd_deps :: GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
-> GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
upd_deps GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
pkg = GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
pkg {
unitDepends :: [UnitId]
unitDepends = (UnitId -> UnitId) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (Map UnitId UnitId -> UnitId -> UnitId
upd_wired_in Map UnitId UnitId
wiredInMap) (GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
-> [UnitId]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [uid]
unitDepends GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
pkg),
unitExposedModules :: [(a, Maybe Module)]
unitExposedModules
= ((a, Maybe Module) -> (a, Maybe Module))
-> [(a, Maybe Module)] -> [(a, Maybe Module)]
forall a b. (a -> b) -> [a] -> [b]
map (\(a
k,Maybe Module
v) -> (a
k, (Module -> Module) -> Maybe Module -> Maybe Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map UnitId UnitId -> Module -> Module
upd_wired_in_mod Map UnitId UnitId
wiredInMap) Maybe Module
v))
(GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
-> [(a, Maybe Module)]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, Maybe mod)]
unitExposedModules GenericUnitInfo compid srcpkgid srcpkgname UnitId a Module
pkg)
}
([UnitInfo], Map UnitId UnitId)
-> IO ([UnitInfo], Map UnitId UnitId)
forall (m :: * -> *) a. Monad m => a -> m a
return ([UnitInfo] -> [UnitInfo]
forall (f :: * -> *) srcpkgid srcpkgname a.
Functor f =>
[GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module]
-> [GenericUnitInfo (f UnitId) srcpkgid srcpkgname UnitId a Module]
updateWiredInDependencies [UnitInfo]
pkgs, Map UnitId UnitId
wiredInMap)
upd_wired_in_home_instantiations :: DynFlags -> DynFlags
upd_wired_in_home_instantiations :: DynFlags -> DynFlags
upd_wired_in_home_instantiations DynFlags
dflags = DynFlags
dflags { homeUnitInstantiations :: [(ModuleName, Module)]
homeUnitInstantiations = [(ModuleName, Module)]
wiredInsts }
where
state :: UnitState
state = DynFlags -> UnitState
unitState DynFlags
dflags
wiringMap :: Map UnitId UnitId
wiringMap = UnitState -> Map UnitId UnitId
wireMap UnitState
state
unwiredInsts :: [(ModuleName, Module)]
unwiredInsts = DynFlags -> [(ModuleName, Module)]
homeUnitInstantiations DynFlags
dflags
wiredInsts :: [(ModuleName, Module)]
wiredInsts = ((ModuleName, Module) -> (ModuleName, Module))
-> [(ModuleName, Module)] -> [(ModuleName, Module)]
forall a b. (a -> b) -> [a] -> [b]
map ((Module -> Module) -> (ModuleName, Module) -> (ModuleName, Module)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Map UnitId UnitId -> Module -> Module
upd_wired_in_mod Map UnitId UnitId
wiringMap)) [(ModuleName, Module)]
unwiredInsts
upd_wired_in_mod :: WiringMap -> Module -> Module
upd_wired_in_mod :: Map UnitId UnitId -> Module -> Module
upd_wired_in_mod Map UnitId UnitId
wiredInMap (Module Unit
uid ModuleName
m) = Unit -> ModuleName -> Module
forall unit. unit -> ModuleName -> GenModule unit
Module (Map UnitId UnitId -> Unit -> Unit
upd_wired_in_uid Map UnitId UnitId
wiredInMap Unit
uid) ModuleName
m
upd_wired_in_uid :: WiringMap -> Unit -> Unit
upd_wired_in_uid :: Map UnitId UnitId -> Unit -> Unit
upd_wired_in_uid Map 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 (Map UnitId UnitId -> UnitId -> UnitId
upd_wired_in Map 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
$ IndefUnitId -> [(ModuleName, Module)] -> GenInstantiatedUnit UnitId
mkInstantiatedUnit
(GenInstantiatedUnit UnitId -> IndefUnitId
forall unit. GenInstantiatedUnit unit -> Indefinite 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,Map UnitId UnitId -> Module -> Module
upd_wired_in_mod Map 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 :: Map UnitId UnitId -> UnitId -> UnitId
upd_wired_in Map UnitId UnitId
wiredInMap UnitId
key
| Just UnitId
key' <- UnitId -> Map UnitId UnitId -> Maybe UnitId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
key Map UnitId UnitId
wiredInMap = UnitId
key'
| Bool
otherwise = UnitId
key
updateVisibilityMap :: WiringMap -> VisibilityMap -> VisibilityMap
updateVisibilityMap :: Map UnitId UnitId -> VisibilityMap -> VisibilityMap
updateVisibilityMap Map UnitId UnitId
wiredInMap VisibilityMap
vis_map = (VisibilityMap -> (UnitId, UnitId) -> VisibilityMap)
-> VisibilityMap -> [(UnitId, UnitId)] -> VisibilityMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' VisibilityMap -> (UnitId, UnitId) -> VisibilityMap
f VisibilityMap
vis_map (Map UnitId UnitId -> [(UnitId, UnitId)]
forall k a. Map k a -> [(k, a)]
Map.toList Map UnitId UnitId
wiredInMap)
where f :: VisibilityMap -> (UnitId, UnitId) -> VisibilityMap
f VisibilityMap
vm (UnitId
from, UnitId
to) = case Unit -> VisibilityMap -> Maybe UnitVisibility
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
from)) VisibilityMap
vis_map of
Maybe UnitVisibility
Nothing -> VisibilityMap
vm
Just UnitVisibility
r -> Unit -> UnitVisibility -> VisibilityMap -> VisibilityMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
to)) UnitVisibility
r
(Unit -> VisibilityMap -> VisibilityMap
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Definite UnitId -> Unit
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
from)) VisibilityMap
vm)
data UnusableUnitReason
=
IgnoredWithFlag
| BrokenDependencies [UnitId]
| CyclicDependencies [UnitId]
| IgnoredDependencies [UnitId]
| ShadowedDependencies [UnitId]
instance Outputable UnusableUnitReason where
ppr :: UnusableUnitReason -> SDoc
ppr UnusableUnitReason
IgnoredWithFlag = String -> SDoc
text String
"[ignored with flag]"
ppr (BrokenDependencies [UnitId]
uids) = SDoc -> SDoc
brackets (String -> SDoc
text String
"broken" SDoc -> SDoc -> SDoc
<+> [UnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
uids)
ppr (CyclicDependencies [UnitId]
uids) = SDoc -> SDoc
brackets (String -> SDoc
text String
"cyclic" SDoc -> SDoc -> SDoc
<+> [UnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
uids)
ppr (IgnoredDependencies [UnitId]
uids) = SDoc -> SDoc
brackets (String -> SDoc
text String
"ignored" SDoc -> SDoc -> SDoc
<+> [UnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
uids)
ppr (ShadowedDependencies [UnitId]
uids) = SDoc -> SDoc
brackets (String -> SDoc
text String
"shadowed" SDoc -> SDoc -> SDoc
<+> [UnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
uids)
type UnusableUnits = Map 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
<+> String -> SDoc
text String
"ignored due to an -ignore-package flag"
BrokenDependencies [UnitId]
deps ->
SDoc
pref SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"unusable due to missing dependencies:" SDoc -> SDoc -> SDoc
$$
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
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
<+> String -> SDoc
text String
"unusable due to cyclic dependencies:" SDoc -> SDoc -> SDoc
$$
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
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
<+> String -> SDoc
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
$$
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
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
<+> String -> SDoc
text String
"unusable due to shadowed dependencies:" SDoc -> SDoc -> SDoc
$$
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
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 :: (SDoc -> IO ()) -> [SCC UnitInfo] -> IO ()
reportCycles :: (SDoc -> IO ()) -> [SCC UnitInfo] -> IO ()
reportCycles SDoc -> IO ()
printer [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 ()
forall a compid srcpkgid srcpkgname modulename mod.
Outputable a =>
SCC (GenericUnitInfo compid srcpkgid srcpkgname a modulename mod)
-> IO ()
report [SCC UnitInfo]
sccs
where
report :: SCC (GenericUnitInfo compid srcpkgid srcpkgname a modulename mod)
-> IO ()
report (AcyclicSCC GenericUnitInfo compid srcpkgid srcpkgname a modulename mod
_) = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
report (CyclicSCC [GenericUnitInfo compid srcpkgid srcpkgname a modulename mod]
vs) =
SDoc -> IO ()
printer (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"these packages are involved in a cycle:" SDoc -> SDoc -> SDoc
$$
Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
hsep ((GenericUnitInfo compid srcpkgid srcpkgname a modulename mod
-> SDoc)
-> [GenericUnitInfo compid srcpkgid srcpkgname a modulename mod]
-> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr (a -> SDoc)
-> (GenericUnitInfo compid srcpkgid srcpkgname a modulename mod
-> a)
-> GenericUnitInfo compid srcpkgid srcpkgname a modulename mod
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericUnitInfo compid srcpkgid srcpkgname a modulename mod -> a
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId) [GenericUnitInfo compid srcpkgid srcpkgname a modulename mod]
vs))
reportUnusable :: (SDoc -> IO ()) -> UnusableUnits -> IO ()
reportUnusable :: (SDoc -> IO ()) -> UnusableUnits -> IO ()
reportUnusable SDoc -> IO ()
printer 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 ()
forall a a. Outputable a => (a, (a, UnusableUnitReason)) -> IO ()
report (UnusableUnits -> [(UnitId, (UnitInfo, UnusableUnitReason))]
forall k a. Map k a -> [(k, a)]
Map.toList UnusableUnits
pkgs)
where
report :: (a, (a, UnusableUnitReason)) -> IO ()
report (a
ipid, (a
_, UnusableUnitReason
reason)) =
SDoc -> IO ()
printer (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
SDoc -> UnusableUnitReason -> SDoc
pprReason
(String -> SDoc
text String
"package" SDoc -> SDoc -> SDoc
<+> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
ipid SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"is") UnusableUnitReason
reason
type RevIndex = Map UnitId [UnitId]
reverseDeps :: UnitInfoMap -> RevIndex
reverseDeps :: UnitInfoMap -> RevIndex
reverseDeps UnitInfoMap
db = (RevIndex -> UnitInfo -> RevIndex)
-> RevIndex -> UnitInfoMap -> RevIndex
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' RevIndex -> UnitInfo -> RevIndex
forall k compid srcpkgid srcpkgname modulename mod.
Ord k =>
Map k [k]
-> GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
-> Map k [k]
go RevIndex
forall k a. Map k a
Map.empty UnitInfoMap
db
where
go :: Map k [k]
-> GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
-> Map k [k]
go Map k [k]
r GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
pkg = (Map k [k] -> k -> Map k [k]) -> Map k [k] -> [k] -> Map k [k]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (k -> Map k [k] -> k -> Map k [k]
forall k a. Ord k => a -> Map k [a] -> k -> Map k [a]
go' (GenericUnitInfo compid srcpkgid srcpkgname k modulename mod -> k
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
pkg)) Map k [k]
r (GenericUnitInfo compid srcpkgid srcpkgname k modulename mod -> [k]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [uid]
unitDepends GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
pkg)
go' :: a -> Map k [a] -> k -> Map k [a]
go' a
from Map k [a]
r k
to = ([a] -> [a] -> [a]) -> k -> [a] -> Map k [a] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) k
to [a
from] Map k [a]
r
removeUnits :: [UnitId] -> RevIndex
-> UnitInfoMap
-> (UnitInfoMap, [UnitInfo])
removeUnits :: [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits [UnitId]
uids RevIndex
index UnitInfoMap
m = [UnitId] -> (UnitInfoMap, [UnitInfo]) -> (UnitInfoMap, [UnitInfo])
forall a. [UnitId] -> (Map UnitId a, [a]) -> (Map UnitId a, [a])
go [UnitId]
uids (UnitInfoMap
m,[])
where
go :: [UnitId] -> (Map UnitId a, [a]) -> (Map UnitId a, [a])
go [] (Map UnitId a
m,[a]
pkgs) = (Map UnitId a
m,[a]
pkgs)
go (UnitId
uid:[UnitId]
uids) (Map UnitId a
m,[a]
pkgs)
| Just a
pkg <- UnitId -> Map UnitId a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
uid Map UnitId a
m
= case UnitId -> RevIndex -> Maybe [UnitId]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
uid RevIndex
index of
Maybe [UnitId]
Nothing -> [UnitId] -> (Map UnitId a, [a]) -> (Map UnitId a, [a])
go [UnitId]
uids (UnitId -> Map UnitId a -> Map UnitId a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete UnitId
uid Map UnitId a
m, a
pkga -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
pkgs)
Just [UnitId]
rdeps -> [UnitId] -> (Map UnitId a, [a]) -> (Map UnitId a, [a])
go ([UnitId]
rdeps [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [UnitId]
uids) (UnitId -> Map UnitId a -> Map UnitId a
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete UnitId
uid Map UnitId a
m, a
pkga -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
pkgs)
| Bool
otherwise
= [UnitId] -> (Map UnitId a, [a]) -> (Map UnitId a, [a])
go [UnitId]
uids (Map UnitId a
m,[a]
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. Ord k => k -> Map k a -> Bool
`Map.member` UnitInfoMap
pkg_map)) (UnitInfo -> [UnitId]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [uid]
unitDepends UnitInfo
pkg)
depsAbiMismatch :: UnitInfoMap
-> UnitInfo
-> [UnitId]
depsAbiMismatch :: UnitInfoMap -> UnitInfo -> [UnitId]
depsAbiMismatch UnitInfoMap
pkg_map UnitInfo
pkg = ((UnitId, String) -> UnitId) -> [(UnitId, String)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, String) -> UnitId
forall a b. (a, b) -> a
fst ([(UnitId, String)] -> [UnitId])
-> ([(UnitId, String)] -> [(UnitId, String)])
-> [(UnitId, String)]
-> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UnitId, String) -> Bool)
-> [(UnitId, String)] -> [(UnitId, String)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((UnitId, String) -> Bool) -> (UnitId, String) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId, String) -> Bool
abiMatch) ([(UnitId, String)] -> [UnitId]) -> [(UnitId, String)] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ UnitInfo -> [(UnitId, String)]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(uid, String)]
unitAbiDepends UnitInfo
pkg
where
abiMatch :: (UnitId, String) -> Bool
abiMatch (UnitId
dep_uid, String
abi)
| Just UnitInfo
dep_pkg <- UnitId -> UnitInfoMap -> Maybe UnitInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
dep_uid UnitInfoMap
pkg_map
= UnitInfo -> String
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> String
unitAbiHash UnitInfo
dep_pkg String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
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. Ord k => [(k, a)] -> Map k a
Map.fromList ((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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId UnitInfo
p, (UnitInfo
p, UnusableUnitReason
IgnoredWithFlag))
| UnitInfo
p <- [UnitInfo]
ps ]
type UnitPrecedenceMap = Map UnitId Int
mergeDatabases :: (SDoc -> IO ()) -> [UnitDatabase UnitId]
-> IO (UnitInfoMap, UnitPrecedenceMap)
mergeDatabases :: (SDoc -> IO ())
-> [UnitDatabase UnitId] -> IO (UnitInfoMap, UnitPrecedenceMap)
mergeDatabases SDoc -> IO ()
printer = ((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. Map k a
Map.empty, UnitPrecedenceMap
forall k a. Map k a
Map.empty) ([(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
SDoc -> IO ()
printer (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"loading package database" SDoc -> SDoc -> SDoc
<+> String -> SDoc
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 ->
SDoc -> IO ()
printer (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"package" SDoc -> SDoc -> SDoc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
pkg SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"overrides a previously defined package"
(UnitInfoMap, UnitPrecedenceMap)
-> IO (UnitInfoMap, UnitPrecedenceMap)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitInfoMap
pkg_map', UnitPrecedenceMap
prec_map')
where
db_map :: UnitInfoMap
db_map = [UnitInfo] -> UnitInfoMap
forall compid srcpkgid srcpkgname modulename mod.
[GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod]
-> Map
UnitId
(GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod)
mk_pkg_map [UnitInfo]
db
mk_pkg_map :: [GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod]
-> Map
UnitId
(GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod)
mk_pkg_map = [(UnitId,
GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod)]
-> Map
UnitId
(GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(UnitId,
GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod)]
-> Map
UnitId
(GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod))
-> ([GenericUnitInfo
compid srcpkgid srcpkgname UnitId modulename mod]
-> [(UnitId,
GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod)])
-> [GenericUnitInfo
compid srcpkgid srcpkgname UnitId modulename mod]
-> Map
UnitId
(GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
-> (UnitId,
GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod))
-> [GenericUnitInfo
compid srcpkgid srcpkgname UnitId modulename mod]
-> [(UnitId,
GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod)]
forall a b. (a -> b) -> [a] -> [b]
map (\GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
p -> (GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
-> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
p, GenericUnitInfo compid 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. Map k a -> Set k
Map.keysSet UnitInfoMap
db_map)
(UnitInfoMap -> Set UnitId
forall k a. Map k a -> Set k
Map.keysSet UnitInfoMap
pkg_map)
pkg_map' :: UnitInfoMap
pkg_map' :: UnitInfoMap
pkg_map' = UnitInfoMap -> UnitInfoMap -> UnitInfoMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union UnitInfoMap
db_map UnitInfoMap
pkg_map
prec_map' :: UnitPrecedenceMap
prec_map' :: UnitPrecedenceMap
prec_map' = UnitPrecedenceMap -> UnitPrecedenceMap -> UnitPrecedenceMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ((UnitInfo -> Int) -> UnitInfoMap -> UnitPrecedenceMap
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Int -> UnitInfo -> Int
forall a b. a -> b -> a
const Int
i) UnitInfoMap
db_map) UnitPrecedenceMap
prec_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 compid srcpkgid srcpkgname k modulename mod
-> t)
-> t
-> [GenericUnitInfo compid srcpkgid srcpkgname k modulename mod]
-> Map
k (GenericUnitInfo compid srcpkgid srcpkgname k modulename mod, b)
mk_unusable t -> b
mk_err t
-> GenericUnitInfo compid srcpkgid srcpkgname k modulename mod -> t
dep_matcher t
m [GenericUnitInfo compid srcpkgid srcpkgname k modulename mod]
uids =
[(k,
(GenericUnitInfo compid srcpkgid srcpkgname k modulename mod, b))]
-> Map
k (GenericUnitInfo compid srcpkgid srcpkgname k modulename mod, b)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (GenericUnitInfo compid srcpkgid srcpkgname k modulename mod -> k
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
pkg, (GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
pkg, t -> b
mk_err (t
-> GenericUnitInfo compid srcpkgid srcpkgname k modulename mod -> t
dep_matcher t
m GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
pkg)))
| GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
pkg <- [GenericUnitInfo compid 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 (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. Map k a -> [a]
Map.elems 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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid 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 compid srcpkgid srcpkgname modulename mod.
Ord k =>
(t -> b)
-> (t
-> GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
-> t)
-> t
-> [GenericUnitInfo compid srcpkgid srcpkgname k modulename mod]
-> Map
k (GenericUnitInfo compid 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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId UnitInfo
pkg, UnitInfo -> [UnitId]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [uid]
unitDepends UnitInfo
pkg)
| UnitInfo
pkg <- UnitInfoMap -> [UnitInfo]
forall k a. Map k a -> [a]
Map.elems UnitInfoMap
pkg_map2 ]
getCyclicSCC :: SCC (GenericUnitInfo compid srcpkgid srcpkgname b modulename mod)
-> [b]
getCyclicSCC (CyclicSCC [GenericUnitInfo compid srcpkgid srcpkgname b modulename mod]
vs) = (GenericUnitInfo compid srcpkgid srcpkgname b modulename mod -> b)
-> [GenericUnitInfo compid srcpkgid srcpkgname b modulename mod]
-> [b]
forall a b. (a -> b) -> [a] -> [b]
map GenericUnitInfo compid srcpkgid srcpkgname b modulename mod -> b
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId [GenericUnitInfo compid srcpkgid srcpkgname b modulename mod]
vs
getCyclicSCC (AcyclicSCC GenericUnitInfo compid 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 compid srcpkgid srcpkgname b modulename mod.
SCC (GenericUnitInfo compid 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 compid srcpkgid srcpkgname modulename mod.
Ord k =>
(t -> b)
-> (t
-> GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
-> t)
-> t
-> [GenericUnitInfo compid srcpkgid srcpkgname k modulename mod]
-> Map
k (GenericUnitInfo compid 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. Map k a -> [a]
Map.elems UnitInfoMap
pkg_map3)
(UnitInfoMap
pkg_map4, [UnitInfo]
ignored) = [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits (UnusableUnits -> [UnitId]
forall k a. Map k a -> [k]
Map.keys 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 compid srcpkgid srcpkgname modulename mod.
Ord k =>
(t -> b)
-> (t
-> GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
-> t)
-> t
-> [GenericUnitInfo compid srcpkgid srcpkgname k modulename mod]
-> Map
k (GenericUnitInfo compid 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 (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. Map k a -> [a]
Map.elems 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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid 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 compid srcpkgid srcpkgname modulename mod.
Ord k =>
(t -> b)
-> (t
-> GenericUnitInfo compid srcpkgid srcpkgname k modulename mod
-> t)
-> t
-> [GenericUnitInfo compid srcpkgid srcpkgname k modulename mod]
-> Map
k (GenericUnitInfo compid srcpkgid srcpkgname k modulename mod, b)
mk_unusable [UnitId] -> UnusableUnitReason
ShadowedDependencies UnitInfoMap -> UnitInfo -> [UnitId]
depsAbiMismatch UnitInfoMap
pkg_map5 [UnitInfo]
shadowed
unusable :: UnusableUnits
unusable = UnusableUnits
directly_ignored UnusableUnits -> UnusableUnits -> UnusableUnits
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` UnusableUnits
unusable_ignored
UnusableUnits -> UnusableUnits -> UnusableUnits
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` UnusableUnits
unusable_broken
UnusableUnits -> UnusableUnits -> UnusableUnits
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` UnusableUnits
unusable_cyclic
UnusableUnits -> UnusableUnits -> UnusableUnits
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` UnusableUnits
unusable_shadowed
mkUnitState
:: SDocContext
-> (Int -> SDoc -> IO ())
-> UnitConfig
-> IO (UnitState,[UnitDatabase UnitId])
mkUnitState :: SDocContext
-> (Int -> SDoc -> IO ())
-> UnitConfig
-> IO (UnitState, [UnitDatabase UnitId])
mkUnitState SDocContext
ctx Int -> SDoc -> IO ()
printer UnitConfig
cfg = do
[UnitDatabase UnitId]
raw_dbs <- case UnitConfig -> Maybe [UnitDatabase UnitId]
unitConfigDBCache UnitConfig
cfg of
Maybe [UnitDatabase UnitId]
Nothing -> (Int -> SDoc -> IO ()) -> UnitConfig -> IO [UnitDatabase UnitId]
readUnitDatabases Int -> SDoc -> IO ()
printer UnitConfig
cfg
Just [UnitDatabase UnitId]
dbs -> [UnitDatabase UnitId] -> IO [UnitDatabase UnitId]
forall (m :: * -> *) a. Monad m => a -> m a
return [UnitDatabase UnitId]
dbs
let distrust_all :: UnitDatabase UnitId -> UnitDatabase UnitId
distrust_all UnitDatabase UnitId
db = UnitDatabase UnitId
db { unitDatabaseUnits :: [UnitInfo]
unitDatabaseUnits = [UnitInfo] -> [UnitInfo]
distrustAllUnits (UnitDatabase UnitId -> [UnitInfo]
forall unit. UnitDatabase unit -> [GenUnitInfo unit]
unitDatabaseUnits UnitDatabase UnitId
db) }
dbs :: [UnitDatabase UnitId]
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 other_flags :: [PackageFlag]
other_flags = [PackageFlag] -> [PackageFlag]
forall a. [a] -> [a]
reverse (UnitConfig -> [PackageFlag]
unitConfigFlagsExposed UnitConfig
cfg)
Int -> SDoc -> IO ()
printer Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc
text String
"package flags" SDoc -> SDoc -> SDoc
<+> [PackageFlag] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [PackageFlag]
other_flags
(UnitInfoMap
pkg_map1, UnitPrecedenceMap
prec_map) <- (SDoc -> IO ())
-> [UnitDatabase UnitId] -> IO (UnitInfoMap, UnitPrecedenceMap)
mergeDatabases (Int -> SDoc -> IO ()
printer Int
2) [UnitDatabase UnitId]
dbs
let (UnitInfoMap
pkg_map2, UnusableUnits
unusable, [SCC UnitInfo]
sccs) = UnitConfig
-> UnitInfoMap -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo])
validateDatabase UnitConfig
cfg UnitInfoMap
pkg_map1
(SDoc -> IO ()) -> [SCC UnitInfo] -> IO ()
reportCycles (Int -> SDoc -> IO ()
printer Int
2) [SCC UnitInfo]
sccs
(SDoc -> IO ()) -> UnusableUnits -> IO ()
reportUnusable (Int -> SDoc -> IO ()
printer Int
2) UnusableUnits
unusable
[UnitInfo]
pkgs1 <- ([UnitInfo] -> TrustFlag -> IO [UnitInfo])
-> [UnitInfo] -> [TrustFlag] -> IO [UnitInfo]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (SDocContext
-> UnitPrecedenceMap
-> UnusableUnits
-> [UnitInfo]
-> TrustFlag
-> IO [UnitInfo]
applyTrustFlag SDocContext
ctx UnitPrecedenceMap
prec_map UnusableUnits
unusable)
(UnitInfoMap -> [UnitInfo]
forall k a. Map k a -> [a]
Map.elems UnitInfoMap
pkg_map2) ([TrustFlag] -> [TrustFlag]
forall a. [a] -> [a]
reverse (UnitConfig -> [TrustFlag]
unitConfigFlagsTrusted UnitConfig
cfg))
let prelim_pkg_db :: UnitInfoMap
prelim_pkg_db = [UnitInfo] -> UnitInfoMap
mkUnitInfoMap [UnitInfo]
pkgs1
let preferLater :: UnitInfo -> UnitInfo -> UnitInfo
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
-> UnitInfo -> UniqDFM FastString UnitInfo
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 :: UniqDFM FastString UnitInfo
mostPreferablePackageReps = if UnitConfig -> Bool
unitConfigHideAll UnitConfig
cfg
then UniqDFM FastString UnitInfo
forall key elt. UniqDFM key elt
emptyUDFM
else (UniqDFM FastString UnitInfo
-> UnitInfo -> UniqDFM FastString UnitInfo)
-> UniqDFM FastString UnitInfo
-> [UnitInfo]
-> UniqDFM FastString UnitInfo
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 key elt. UniqDFM key elt
emptyUDFM [UnitInfo]
pkgs1
mostPreferable :: UnitInfo -> Bool
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
vis_map1 = (VisibilityMap -> UnitInfo -> VisibilityMap)
-> VisibilityMap -> [UnitInfo] -> VisibilityMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\VisibilityMap
vm UnitInfo
p ->
if UnitInfo -> Bool
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid 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 Unit -> UnitVisibility -> VisibilityMap -> VisibilityMap
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (UnitInfo -> Unit
mkUnit UnitInfo
p)
UnitVisibility :: Bool
-> [(ModuleName, ModuleName)]
-> First FastString
-> Map ModuleName (Set InstantiatedModule)
-> Bool
-> UnitVisibility
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 :: Map ModuleName (Set InstantiatedModule)
uv_requirements = Map ModuleName (Set InstantiatedModule)
forall k a. Map k a
Map.empty,
uv_explicit :: Bool
uv_explicit = Bool
False
}
VisibilityMap
vm
else VisibilityMap
vm)
VisibilityMap
forall k a. Map k a
Map.empty [UnitInfo]
pkgs1
VisibilityMap
vis_map2 <- (VisibilityMap -> PackageFlag -> IO VisibilityMap)
-> VisibilityMap -> [PackageFlag] -> IO VisibilityMap
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (SDocContext
-> UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> UnusableUnits
-> Bool
-> [UnitInfo]
-> VisibilityMap
-> PackageFlag
-> IO VisibilityMap
applyPackageFlag SDocContext
ctx UnitPrecedenceMap
prec_map UnitInfoMap
prelim_pkg_db PreloadUnitClosure
forall a. UniqSet a
emptyUniqSet UnusableUnits
unusable
(UnitConfig -> Bool
unitConfigHideAll UnitConfig
cfg) [UnitInfo]
pkgs1)
VisibilityMap
vis_map1 [PackageFlag]
other_flags
([UnitInfo]
pkgs2, Map UnitId UnitId
wired_map) <- (SDoc -> IO ())
-> UnitPrecedenceMap
-> [UnitInfo]
-> VisibilityMap
-> IO ([UnitInfo], Map UnitId UnitId)
findWiredInUnits (Int -> SDoc -> IO ()
printer Int
2) UnitPrecedenceMap
prec_map [UnitInfo]
pkgs1 VisibilityMap
vis_map2
let pkg_db :: UnitInfoMap
pkg_db = [UnitInfo] -> UnitInfoMap
mkUnitInfoMap [UnitInfo]
pkgs2
let vis_map :: VisibilityMap
vis_map = Map UnitId UnitId -> VisibilityMap -> VisibilityMap
updateVisibilityMap Map UnitId UnitId
wired_map VisibilityMap
vis_map2
let hide_plugin_pkgs :: Bool
hide_plugin_pkgs = UnitConfig -> Bool
unitConfigHideAllPlugins UnitConfig
cfg
VisibilityMap
plugin_vis_map <-
case UnitConfig -> [PackageFlag]
unitConfigFlagsPlugins UnitConfig
cfg of
[] | Bool -> Bool
not Bool
hide_plugin_pkgs -> VisibilityMap -> IO VisibilityMap
forall (m :: * -> *) a. Monad m => a -> m a
return VisibilityMap
vis_map
| Bool
otherwise -> VisibilityMap -> IO VisibilityMap
forall (m :: * -> *) a. Monad m => a -> m a
return VisibilityMap
forall k a. Map k a
Map.empty
[PackageFlag]
_ -> do let plugin_vis_map1 :: VisibilityMap
plugin_vis_map1
| Bool
hide_plugin_pkgs = VisibilityMap
forall k a. Map k a
Map.empty
| Bool
otherwise = VisibilityMap
vis_map2
VisibilityMap
plugin_vis_map2
<- (VisibilityMap -> PackageFlag -> IO VisibilityMap)
-> VisibilityMap -> [PackageFlag] -> IO VisibilityMap
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (SDocContext
-> UnitPrecedenceMap
-> UnitInfoMap
-> PreloadUnitClosure
-> UnusableUnits
-> Bool
-> [UnitInfo]
-> VisibilityMap
-> PackageFlag
-> IO VisibilityMap
applyPackageFlag SDocContext
ctx 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))
VisibilityMap -> IO VisibilityMap
forall (m :: * -> *) a. Monad m => a -> m a
return (Map UnitId UnitId -> VisibilityMap -> VisibilityMap
updateVisibilityMap Map UnitId UnitId
wired_map VisibilityMap
plugin_vis_map2)
let pkgname_map :: Map PackageName IndefUnitId
pkgname_map = (Map PackageName IndefUnitId
-> UnitInfo -> Map PackageName IndefUnitId)
-> Map PackageName IndefUnitId
-> [UnitInfo]
-> Map PackageName IndefUnitId
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map PackageName IndefUnitId
-> UnitInfo -> Map PackageName IndefUnitId
forall srcpkgname a srcpkgid uid modulename mod.
Ord srcpkgname =>
Map srcpkgname a
-> GenericUnitInfo a srcpkgid srcpkgname uid modulename mod
-> Map srcpkgname a
add Map PackageName IndefUnitId
forall k a. Map k a
Map.empty [UnitInfo]
pkgs2
where add :: Map srcpkgname a
-> GenericUnitInfo a srcpkgid srcpkgname uid modulename mod
-> Map srcpkgname a
add Map srcpkgname a
pn_map GenericUnitInfo a srcpkgid srcpkgname uid modulename mod
p
= srcpkgname -> a -> Map srcpkgname a -> Map srcpkgname a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (GenericUnitInfo a srcpkgid srcpkgname uid modulename mod
-> srcpkgname
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> srcpkgname
unitPackageName GenericUnitInfo a srcpkgid srcpkgname uid modulename mod
p) (GenericUnitInfo a srcpkgid srcpkgname uid modulename mod -> a
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> compid
unitInstanceOf GenericUnitInfo a srcpkgid srcpkgname uid modulename mod
p) Map srcpkgname a
pn_map
let explicit_pkgs :: [Unit]
explicit_pkgs = VisibilityMap -> [Unit]
forall k a. Map k a -> [k]
Map.keys VisibilityMap
vis_map
req_ctx :: Map ModuleName [InstantiatedModule]
req_ctx = (Set InstantiatedModule -> [InstantiatedModule])
-> Map ModuleName (Set InstantiatedModule)
-> Map ModuleName [InstantiatedModule]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (Set InstantiatedModule -> [InstantiatedModule]
forall a. Set a -> [a]
Set.toList)
(Map ModuleName (Set InstantiatedModule)
-> Map ModuleName [InstantiatedModule])
-> Map ModuleName (Set InstantiatedModule)
-> Map ModuleName [InstantiatedModule]
forall a b. (a -> b) -> a -> b
$ (Set InstantiatedModule
-> Set InstantiatedModule -> Set InstantiatedModule)
-> [Map ModuleName (Set InstantiatedModule)]
-> Map ModuleName (Set InstantiatedModule)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Set InstantiatedModule
-> Set InstantiatedModule -> Set InstantiatedModule
forall a. Ord a => Set a -> Set a -> Set a
Set.union ((UnitVisibility -> Map ModuleName (Set InstantiatedModule))
-> [UnitVisibility] -> [Map ModuleName (Set InstantiatedModule)]
forall a b. (a -> b) -> [a] -> [b]
map UnitVisibility -> Map ModuleName (Set InstantiatedModule)
uv_requirements (VisibilityMap -> [UnitVisibility]
forall k a. Map k a -> [a]
Map.elems VisibilityMap
vis_map))
let preload1 :: [Unit]
preload1 = VisibilityMap -> [Unit]
forall k a. Map k a -> [k]
Map.keys ((UnitVisibility -> Bool) -> VisibilityMap -> VisibilityMap
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter UnitVisibility -> Bool
uv_explicit VisibilityMap
vis_map)
basicLinkedUnits :: [Unit]
basicLinkedUnits = (UnitId -> Unit) -> [UnitId] -> [Unit]
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. Ord k => k -> Map k a -> Bool
Map.member UnitInfoMap
pkg_db)
([UnitId] -> [UnitId]) -> [UnitId] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ UnitConfig -> [UnitId]
unitConfigAutoLink UnitConfig
cfg
preload3 :: [Unit]
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)
let dep_preload_err :: MaybeErr SDoc [UnitId]
dep_preload_err = UnitInfoMap -> [(UnitId, Maybe UnitId)] -> MaybeErr SDoc [UnitId]
closeUnitDeps UnitInfoMap
pkg_db ([UnitId] -> [Maybe UnitId] -> [(UnitId, Maybe UnitId)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Unit -> UnitId) -> [Unit] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map Unit -> UnitId
toUnitId [Unit]
preload3) (Maybe UnitId -> [Maybe UnitId]
forall a. a -> [a]
repeat Maybe UnitId
forall a. Maybe a
Nothing))
[UnitId]
dep_preload <- SDocContext -> MaybeErr SDoc [UnitId] -> IO [UnitId]
forall a. SDocContext -> MaybeErr SDoc a -> IO a
throwErr SDocContext
ctx MaybeErr SDoc [UnitId]
dep_preload_err
let mod_map1 :: ModuleNameProvidersMap
mod_map1 = SDocContext
-> UnitConfig
-> UnitInfoMap
-> PreloadUnitClosure
-> VisibilityMap
-> ModuleNameProvidersMap
mkModuleNameProvidersMap SDocContext
ctx UnitConfig
cfg UnitInfoMap
pkg_db PreloadUnitClosure
forall a. UniqSet a
emptyUniqSet VisibilityMap
vis_map
mod_map2 :: ModuleNameProvidersMap
mod_map2 = UnusableUnits -> ModuleNameProvidersMap
mkUnusableModuleNameProvidersMap UnusableUnits
unusable
mod_map :: ModuleNameProvidersMap
mod_map = ModuleNameProvidersMap
-> ModuleNameProvidersMap -> ModuleNameProvidersMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ModuleNameProvidersMap
mod_map1 ModuleNameProvidersMap
mod_map2
let !state :: UnitState
state = UnitState :: UnitInfoMap
-> PreloadUnitClosure
-> Map PackageName IndefUnitId
-> Map UnitId UnitId
-> Map UnitId UnitId
-> [UnitId]
-> [Unit]
-> ModuleNameProvidersMap
-> ModuleNameProvidersMap
-> Map ModuleName [InstantiatedModule]
-> Bool
-> UnitState
UnitState
{ preloadUnits :: [UnitId]
preloadUnits = [UnitId]
dep_preload
, explicitUnits :: [Unit]
explicitUnits = [Unit]
explicit_pkgs
, unitInfoMap :: UnitInfoMap
unitInfoMap = UnitInfoMap
pkg_db
, preloadClosure :: PreloadUnitClosure
preloadClosure = PreloadUnitClosure
forall a. UniqSet a
emptyUniqSet
, moduleNameProvidersMap :: ModuleNameProvidersMap
moduleNameProvidersMap = ModuleNameProvidersMap
mod_map
, pluginModuleNameProvidersMap :: ModuleNameProvidersMap
pluginModuleNameProvidersMap = SDocContext
-> UnitConfig
-> UnitInfoMap
-> PreloadUnitClosure
-> VisibilityMap
-> ModuleNameProvidersMap
mkModuleNameProvidersMap SDocContext
ctx UnitConfig
cfg UnitInfoMap
pkg_db PreloadUnitClosure
forall a. UniqSet a
emptyUniqSet VisibilityMap
plugin_vis_map
, packageNameMap :: Map PackageName IndefUnitId
packageNameMap = Map PackageName IndefUnitId
pkgname_map
, wireMap :: Map UnitId UnitId
wireMap = Map UnitId UnitId
wired_map
, unwireMap :: Map UnitId UnitId
unwireMap = [(UnitId, UnitId)] -> Map UnitId UnitId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ (UnitId
v,UnitId
k) | (UnitId
k,UnitId
v) <- Map UnitId UnitId -> [(UnitId, UnitId)]
forall k a. Map k a -> [(k, a)]
Map.toList Map UnitId UnitId
wired_map ]
, requirementContext :: Map ModuleName [InstantiatedModule]
requirementContext = Map ModuleName [InstantiatedModule]
req_ctx
, allowVirtualUnits :: Bool
allowVirtualUnits = UnitConfig -> Bool
unitConfigAllowVirtualUnits UnitConfig
cfg
}
(UnitState, [UnitDatabase UnitId])
-> IO (UnitState, [UnitDatabase UnitId])
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitState
state, [UnitDatabase UnitId]
raw_dbs)
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) (UnitId -> Map UnitId UnitId -> Maybe UnitId
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
def_uid (UnitState -> Map UnitId UnitId
unwireMap UnitState
state))
unwireUnit UnitState
_ Unit
uid = Unit
uid
mkModuleNameProvidersMap
:: SDocContext
-> UnitConfig
-> UnitInfoMap
-> PreloadUnitClosure
-> VisibilityMap
-> ModuleNameProvidersMap
mkModuleNameProvidersMap :: SDocContext
-> UnitConfig
-> UnitInfoMap
-> PreloadUnitClosure
-> VisibilityMap
-> ModuleNameProvidersMap
mkModuleNameProvidersMap SDocContext
ctx UnitConfig
cfg UnitInfoMap
pkg_map PreloadUnitClosure
closure VisibilityMap
vis_map =
(ModuleNameProvidersMap
-> Unit -> UnitVisibility -> ModuleNameProvidersMap)
-> ModuleNameProvidersMap
-> VisibilityMap
-> ModuleNameProvidersMap
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey ModuleNameProvidersMap
-> Unit -> UnitVisibility -> ModuleNameProvidersMap
extend_modmap ModuleNameProvidersMap
forall k a. Map k a
emptyMap VisibilityMap
vis_map_extended
where
vis_map_extended :: VisibilityMap
vis_map_extended = VisibilityMap -> VisibilityMap -> VisibilityMap
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union VisibilityMap
vis_map VisibilityMap
default_vis
default_vis :: VisibilityMap
default_vis = [(Unit, UnitVisibility)] -> VisibilityMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
[ (UnitInfo -> Unit
mkUnit UnitInfo
pkg, UnitVisibility
forall a. Monoid a => a
mempty)
| UnitInfo
pkg <- UnitInfoMap -> [UnitInfo]
forall k a. Map k a -> [a]
Map.elems UnitInfoMap
pkg_map
, UnitInfo -> Bool
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitIsIndefinite UnitInfo
pkg Bool -> Bool -> Bool
|| [(ModuleName, Module)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (UnitInfo -> [(ModuleName, Module)]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, mod)]
unitInstantiations UnitInfo
pkg)
]
emptyMap :: Map k a
emptyMap = Map k a
forall k a. Map k a
Map.empty
setOrigins :: f b -> b -> f b
setOrigins f b
m b
os = (b -> b) -> f b -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> b -> b
forall a b. a -> b -> a
const b
os) f b
m
extend_modmap :: ModuleNameProvidersMap
-> Unit -> UnitVisibility -> ModuleNameProvidersMap
extend_modmap ModuleNameProvidersMap
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
-> [(ModuleName, Map Module ModuleOrigin)]
-> ModuleNameProvidersMap
forall a k1 k2.
(Monoid a, Ord k1, Ord k2) =>
Map k1 (Map k2 a) -> [(k1, Map k2 a)] -> Map k1 (Map k2 a)
addListTo ModuleNameProvidersMap
modmap [(ModuleName, Map Module ModuleOrigin)]
theBindings
where
pkg :: UnitInfo
pkg = Unit -> UnitInfo
unit_lookup Unit
uid
theBindings :: [(ModuleName, Map Module ModuleOrigin)]
theBindings :: [(ModuleName, Map Module ModuleOrigin)]
theBindings = Bool
-> [(ModuleName, ModuleName)]
-> [(ModuleName, Map Module ModuleOrigin)]
newBindings Bool
b [(ModuleName, ModuleName)]
rns
newBindings :: Bool
-> [(ModuleName, ModuleName)]
-> [(ModuleName, Map Module ModuleOrigin)]
newBindings :: Bool
-> [(ModuleName, ModuleName)]
-> [(ModuleName, Map Module ModuleOrigin)]
newBindings Bool
e [(ModuleName, ModuleName)]
rns = Bool -> [(ModuleName, Map Module ModuleOrigin)]
es Bool
e [(ModuleName, Map Module ModuleOrigin)]
-> [(ModuleName, Map Module ModuleOrigin)]
-> [(ModuleName, Map Module ModuleOrigin)]
forall a. [a] -> [a] -> [a]
++ [(ModuleName, Map Module ModuleOrigin)]
hiddens [(ModuleName, Map Module ModuleOrigin)]
-> [(ModuleName, Map Module ModuleOrigin)]
-> [(ModuleName, Map Module ModuleOrigin)]
forall a. [a] -> [a] -> [a]
++ ((ModuleName, ModuleName) -> (ModuleName, Map Module ModuleOrigin))
-> [(ModuleName, ModuleName)]
-> [(ModuleName, Map Module ModuleOrigin)]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, ModuleName) -> (ModuleName, Map Module ModuleOrigin)
rnBinding [(ModuleName, ModuleName)]
rns
rnBinding :: (ModuleName, ModuleName)
-> (ModuleName, Map Module ModuleOrigin)
rnBinding :: (ModuleName, ModuleName) -> (ModuleName, Map Module ModuleOrigin)
rnBinding (ModuleName
orig, ModuleName
new) = (ModuleName
new, Map Module ModuleOrigin -> ModuleOrigin -> Map Module ModuleOrigin
forall (f :: * -> *) b b. Functor f => f b -> b -> f b
setOrigins Map Module ModuleOrigin
origEntry ModuleOrigin
fromFlag)
where origEntry :: Map Module ModuleOrigin
origEntry = case UniqFM ModuleName (Map Module ModuleOrigin)
-> ModuleName -> Maybe (Map Module ModuleOrigin)
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM UniqFM ModuleName (Map Module ModuleOrigin)
esmap ModuleName
orig of
Just Map Module ModuleOrigin
r -> Map Module ModuleOrigin
r
Maybe (Map Module ModuleOrigin)
Nothing -> GhcException -> Map Module ModuleOrigin
forall a. GhcException -> a
throwGhcException (String -> GhcException
CmdLineError (SDocContext -> SDoc -> String
renderWithStyle SDocContext
ctx
(String -> SDoc
text String
"package flag: could not find module name" SDoc -> SDoc -> SDoc
<+>
ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
orig SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"in package" SDoc -> SDoc -> SDoc
<+> Unit -> SDoc
forall a. Outputable a => a -> SDoc
ppr Unit
pk)))
es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]
es :: Bool -> [(ModuleName, Map Module ModuleOrigin)]
es Bool
e = do
(ModuleName
m, Maybe Module
exposedReexport) <- [(ModuleName, Maybe Module)]
exposed_mods
let (Unit
pk', ModuleName
m', ModuleOrigin
origin') =
case Maybe Module
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)
(ModuleName, Map Module ModuleOrigin)
-> [(ModuleName, Map Module ModuleOrigin)]
forall (m :: * -> *) a. Monad m => a -> m a
return (ModuleName
m, Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap Unit
pk' ModuleName
m' ModuleOrigin
origin')
esmap :: UniqFM ModuleName (Map Module ModuleOrigin)
esmap :: UniqFM ModuleName (Map Module ModuleOrigin)
esmap = [(ModuleName, Map Module ModuleOrigin)]
-> UniqFM ModuleName (Map Module ModuleOrigin)
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM (Bool -> [(ModuleName, Map Module ModuleOrigin)]
es Bool
False)
hiddens :: [(ModuleName, Map Module ModuleOrigin)]
hiddens = [(ModuleName
m, Unit -> ModuleName -> ModuleOrigin -> Map 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
unitConfigAllowVirtualUnits 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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, Maybe mod)]
unitExposedModules UnitInfo
pkg
hidden_mods :: [ModuleName]
hidden_mods = UnitInfo -> [ModuleName]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [modulename]
unitHiddenModules UnitInfo
pkg
mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap
mkUnusableModuleNameProvidersMap :: UnusableUnits -> ModuleNameProvidersMap
mkUnusableModuleNameProvidersMap UnusableUnits
unusables =
(ModuleNameProvidersMap
-> (UnitInfo, UnusableUnitReason) -> ModuleNameProvidersMap)
-> ModuleNameProvidersMap
-> UnusableUnits
-> ModuleNameProvidersMap
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' ModuleNameProvidersMap
-> (UnitInfo, UnusableUnitReason) -> ModuleNameProvidersMap
extend_modmap ModuleNameProvidersMap
forall k a. Map k a
Map.empty UnusableUnits
unusables
where
extend_modmap :: ModuleNameProvidersMap
-> (UnitInfo, UnusableUnitReason) -> ModuleNameProvidersMap
extend_modmap ModuleNameProvidersMap
modmap (UnitInfo
pkg, UnusableUnitReason
reason) = ModuleNameProvidersMap
-> [(ModuleName, Map Module ModuleOrigin)]
-> ModuleNameProvidersMap
forall a k1 k2.
(Monoid a, Ord k1, Ord k2) =>
Map k1 (Map k2 a) -> [(k1, Map k2 a)] -> Map k1 (Map k2 a)
addListTo ModuleNameProvidersMap
modmap [(ModuleName, Map Module ModuleOrigin)]
bindings
where bindings :: [(ModuleName, Map Module ModuleOrigin)]
bindings :: [(ModuleName, Map Module ModuleOrigin)]
bindings = [(ModuleName, Map Module ModuleOrigin)]
exposed [(ModuleName, Map Module ModuleOrigin)]
-> [(ModuleName, Map Module ModuleOrigin)]
-> [(ModuleName, Map Module ModuleOrigin)]
forall a. [a] -> [a] -> [a]
++ [(ModuleName, Map Module ModuleOrigin)]
hidden
origin :: ModuleOrigin
origin = UnusableUnitReason -> ModuleOrigin
ModUnusable UnusableUnitReason
reason
pkg_id :: Unit
pkg_id = UnitInfo -> Unit
mkUnit UnitInfo
pkg
exposed :: [(ModuleName, Map Module ModuleOrigin)]
exposed = ((ModuleName, Maybe Module)
-> (ModuleName, Map Module ModuleOrigin))
-> [(ModuleName, Maybe Module)]
-> [(ModuleName, Map Module ModuleOrigin)]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, Maybe Module) -> (ModuleName, Map Module ModuleOrigin)
get_exposed [(ModuleName, Maybe Module)]
exposed_mods
hidden :: [(ModuleName, Map Module ModuleOrigin)]
hidden = [(ModuleName
m, Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap Unit
pkg_id ModuleName
m ModuleOrigin
origin) | ModuleName
m <- [ModuleName]
hidden_mods]
get_exposed :: (ModuleName, Maybe Module) -> (ModuleName, Map Module ModuleOrigin)
get_exposed (ModuleName
mod, Just Module
mod') = (ModuleName
mod, Module -> ModuleOrigin -> Map Module ModuleOrigin
forall k a. k -> a -> Map k a
Map.singleton Module
mod' ModuleOrigin
origin)
get_exposed (ModuleName
mod, Maybe Module
_) = (ModuleName
mod, Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap Unit
pkg_id ModuleName
mod ModuleOrigin
origin)
exposed_mods :: [(ModuleName, Maybe Module)]
exposed_mods = UnitInfo -> [(ModuleName, Maybe Module)]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [(modulename, Maybe mod)]
unitExposedModules UnitInfo
pkg
hidden_mods :: [ModuleName]
hidden_mods = UnitInfo -> [ModuleName]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [modulename]
unitHiddenModules UnitInfo
pkg
addListTo :: (Monoid a, Ord k1, Ord k2)
=> Map k1 (Map k2 a)
-> [(k1, Map k2 a)]
-> Map k1 (Map k2 a)
addListTo :: Map k1 (Map k2 a) -> [(k1, Map k2 a)] -> Map k1 (Map k2 a)
addListTo = (Map k1 (Map k2 a) -> (k1, Map k2 a) -> Map k1 (Map k2 a))
-> Map k1 (Map k2 a) -> [(k1, Map k2 a)] -> Map k1 (Map k2 a)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map k1 (Map k2 a) -> (k1, Map k2 a) -> Map k1 (Map k2 a)
forall k k a.
(Ord k, Ord k, Monoid a) =>
Map k (Map k a) -> (k, Map k a) -> Map k (Map k a)
merge
where merge :: Map k (Map k a) -> (k, Map k a) -> Map k (Map k a)
merge Map k (Map k a)
m (k
k, Map k a
v) = (Map k a -> Map k a -> Map k a)
-> k -> Map k a -> Map k (Map k a) -> Map k (Map k a)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
MapStrict.insertWith ((a -> a -> a) -> Map k a -> Map k a -> Map k a
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith a -> a -> a
forall a. Monoid a => a -> a -> a
mappend) k
k Map k a
v Map k (Map k a)
m
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap :: Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin
mkModMap Unit
pkg ModuleName
mod = Module -> ModuleOrigin -> Map Module ModuleOrigin
forall k a. k -> a -> Map k a
Map.singleton (Unit -> ModuleName -> Module
forall unit. unit -> ModuleName -> GenModule unit
mkModule Unit
pkg ModuleName
mod)
getUnitIncludePath :: DynFlags -> [UnitId] -> IO [String]
getUnitIncludePath :: DynFlags -> [UnitId] -> IO [String]
getUnitIncludePath DynFlags
dflags [UnitId]
pkgs =
[UnitInfo] -> [String]
collectIncludeDirs ([UnitInfo] -> [String]) -> IO [UnitInfo] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DynFlags -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd DynFlags
dflags [UnitId]
pkgs
collectIncludeDirs :: [UnitInfo] -> [FilePath]
collectIncludeDirs :: [UnitInfo] -> [String]
collectIncludeDirs [UnitInfo]
ps = [String] -> [String]
forall a. Ord a => [a] -> [a]
ordNub ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall a. [a] -> Bool
notNull ((UnitInfo -> [String]) -> [UnitInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnitInfo -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitIncludeDirs [UnitInfo]
ps))
getUnitLibraryPath :: DynFlags -> [UnitId] -> IO [String]
getUnitLibraryPath :: DynFlags -> [UnitId] -> IO [String]
getUnitLibraryPath DynFlags
dflags [UnitId]
pkgs =
DynFlags -> [UnitInfo] -> [String]
collectLibraryPaths DynFlags
dflags ([UnitInfo] -> [String]) -> IO [UnitInfo] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DynFlags -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd DynFlags
dflags [UnitId]
pkgs
collectLibraryPaths :: DynFlags -> [UnitInfo] -> [FilePath]
collectLibraryPaths :: DynFlags -> [UnitInfo] -> [String]
collectLibraryPaths DynFlags
dflags = [String] -> [String]
forall a. Ord a => [a] -> [a]
ordNub ([String] -> [String])
-> ([UnitInfo] -> [String]) -> [UnitInfo] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall a. [a] -> Bool
notNull
([String] -> [String])
-> ([UnitInfo] -> [String]) -> [UnitInfo] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInfo -> [String]) -> [UnitInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DynFlags -> UnitInfo -> [String]
libraryDirsForWay DynFlags
dflags)
getUnitLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String])
getUnitLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String])
getUnitLinkOpts DynFlags
dflags [UnitId]
pkgs =
DynFlags -> [UnitInfo] -> ([String], [String], [String])
collectLinkOpts DynFlags
dflags ([UnitInfo] -> ([String], [String], [String]))
-> IO [UnitInfo] -> IO ([String], [String], [String])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` DynFlags -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd DynFlags
dflags [UnitId]
pkgs
collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String])
collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String])
collectLinkOpts DynFlags
dflags [UnitInfo]
ps =
(
(UnitInfo -> [String]) -> [UnitInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-l" String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (UnitInfo -> [String]) -> UnitInfo -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> UnitInfo -> [String]
packageHsLibs DynFlags
dflags) [UnitInfo]
ps,
(UnitInfo -> [String]) -> [UnitInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"-l" String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String])
-> (UnitInfo -> [String]) -> UnitInfo -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfo -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitExtDepLibsSys) [UnitInfo]
ps,
(UnitInfo -> [String]) -> [UnitInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnitInfo -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitLinkerOptions [UnitInfo]
ps
)
collectArchives :: DynFlags -> UnitInfo -> IO [FilePath]
collectArchives :: DynFlags -> UnitInfo -> IO [String]
collectArchives DynFlags
dflags UnitInfo
pc =
(String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesFileExist [ String
searchPath String -> String -> String
</> (String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
lib String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".a")
| String
searchPath <- [String]
searchPaths
, String
lib <- [String]
libs ]
where searchPaths :: [String]
searchPaths = [String] -> [String]
forall a. Ord a => [a] -> [a]
ordNub ([String] -> [String])
-> (UnitInfo -> [String]) -> UnitInfo -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall a. [a] -> Bool
notNull ([String] -> [String])
-> (UnitInfo -> [String]) -> UnitInfo -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> UnitInfo -> [String]
libraryDirsForWay DynFlags
dflags (UnitInfo -> [String]) -> UnitInfo -> [String]
forall a b. (a -> b) -> a -> b
$ UnitInfo
pc
libs :: [String]
libs = DynFlags -> UnitInfo -> [String]
packageHsLibs DynFlags
dflags UnitInfo
pc [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ UnitInfo -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitExtDepLibsSys UnitInfo
pc
getLibs :: DynFlags -> [UnitId] -> IO [(String,String)]
getLibs :: DynFlags -> [UnitId] -> IO [(String, String)]
getLibs DynFlags
dflags [UnitId]
pkgs = do
[UnitInfo]
ps <- DynFlags -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd DynFlags
dflags [UnitId]
pkgs
([[(String, String)]] -> [(String, String)])
-> IO [[(String, String)]] -> IO [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[(String, String)]] -> [(String, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[(String, String)]] -> IO [(String, String)])
-> ((UnitInfo -> IO [(String, String)]) -> IO [[(String, String)]])
-> (UnitInfo -> IO [(String, String)])
-> IO [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitInfo]
-> (UnitInfo -> IO [(String, String)]) -> IO [[(String, String)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [UnitInfo]
ps ((UnitInfo -> IO [(String, String)]) -> IO [(String, String)])
-> (UnitInfo -> IO [(String, String)]) -> IO [(String, String)]
forall a b. (a -> b) -> a -> b
$ \UnitInfo
p -> do
let candidates :: [(String, String)]
candidates = [ (String
l String -> String -> String
</> String
f, String
f) | String
l <- DynFlags -> [UnitInfo] -> [String]
collectLibraryPaths DynFlags
dflags [UnitInfo
p]
, String
f <- (\String
n -> String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".a") (String -> String) -> [String] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DynFlags -> UnitInfo -> [String]
packageHsLibs DynFlags
dflags UnitInfo
p ]
((String, String) -> IO Bool)
-> [(String, String)] -> IO [(String, String)]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesFileExist (String -> IO Bool)
-> ((String, String) -> String) -> (String, String) -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
forall a b. (a, b) -> a
fst) [(String, String)]
candidates
packageHsLibs :: DynFlags -> UnitInfo -> [String]
packageHsLibs :: DynFlags -> UnitInfo -> [String]
packageHsLibs DynFlags
dflags UnitInfo
p = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
mkDynName (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
addSuffix) (UnitInfo -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitLibraries UnitInfo
p)
where
ways0 :: Set Way
ways0 = DynFlags -> Set Way
ways DynFlags
dflags
ways1 :: Set Way
ways1 = (Way -> Bool) -> Set Way -> Set Way
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Way -> Way -> Bool
forall a. Eq a => a -> a -> Bool
/= Way
WayDyn) Set Way
ways0
ways2 :: Set Way
ways2 | Way
WayDebug Way -> Set Way -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Way
ways1 Bool -> Bool -> Bool
|| Way
WayProf Way -> Set Way -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Way
ways1
= (Way -> Bool) -> Set Way -> Set Way
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Way -> Way -> Bool
forall a. Eq a => a -> a -> Bool
/= Way
WayEventLog) Set Way
ways1
| Bool
otherwise
= Set Way
ways1
tag :: String
tag = Set Way -> String
waysTag ((Way -> Bool) -> Set Way -> Set Way
forall a. (a -> Bool) -> Set a -> Set a
Set.filter (Bool -> Bool
not (Bool -> Bool) -> (Way -> Bool) -> Way -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Way -> Bool
wayRTSOnly) Set Way
ways2)
rts_tag :: String
rts_tag = Set Way -> String
waysTag Set Way
ways2
mkDynName :: String -> String
mkDynName String
x
| Way
WayDyn Way -> Set Way -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` DynFlags -> Set Way
ways DynFlags
dflags = String
x
| String
"HS" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
x =
String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'-'Char -> String -> String
forall a. a -> [a] -> [a]
:DynFlags -> String
programName DynFlags
dflags String -> String -> String
forall a. [a] -> [a] -> [a]
++ DynFlags -> String
projectVersion DynFlags
dflags
| Just String
x' <- String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"C" String
x = String
x'
| Bool
otherwise
= String -> String
forall a. String -> a
panic (String
"Don't understand library name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x)
addSuffix :: String -> String
addSuffix rts :: String
rts@String
"HSrts" = String
rts String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
expandTag String
rts_tag)
addSuffix rts :: String
rts@String
"HSrts-1.0.2"= String
rts String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
expandTag String
rts_tag)
addSuffix String
other_lib = String
other_lib String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String
expandTag String
tag)
expandTag :: String -> String
expandTag String
t | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
t = String
""
| Bool
otherwise = Char
'_'Char -> String -> String
forall a. a -> [a] -> [a]
:String
t
libraryDirsForWay :: DynFlags -> UnitInfo -> [String]
libraryDirsForWay :: DynFlags -> UnitInfo -> [String]
libraryDirsForWay DynFlags
dflags
| Way
WayDyn Way -> Set Way -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` DynFlags -> Set Way
ways DynFlags
dflags = UnitInfo -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitLibraryDynDirs
| Bool
otherwise = UnitInfo -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitLibraryDirs
getUnitExtraCcOpts :: DynFlags -> [UnitId] -> IO [String]
DynFlags
dflags [UnitId]
pkgs = do
[UnitInfo]
ps <- DynFlags -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd DynFlags
dflags [UnitId]
pkgs
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ((UnitInfo -> [String]) -> [UnitInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnitInfo -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitCcOptions [UnitInfo]
ps)
getUnitFrameworkPath :: DynFlags -> [UnitId] -> IO [String]
getUnitFrameworkPath :: DynFlags -> [UnitId] -> IO [String]
getUnitFrameworkPath DynFlags
dflags [UnitId]
pkgs = do
[UnitInfo]
ps <- DynFlags -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd DynFlags
dflags [UnitId]
pkgs
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> [String]
forall a. Ord a => [a] -> [a]
ordNub ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
forall a. [a] -> Bool
notNull ((UnitInfo -> [String]) -> [UnitInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnitInfo -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitExtDepFrameworkDirs [UnitInfo]
ps)))
getUnitFrameworks :: DynFlags -> [UnitId] -> IO [String]
getUnitFrameworks :: DynFlags -> [UnitId] -> IO [String]
getUnitFrameworks DynFlags
dflags [UnitId]
pkgs = do
[UnitInfo]
ps <- DynFlags -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd DynFlags
dflags [UnitId]
pkgs
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ((UnitInfo -> [String]) -> [UnitInfo] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap UnitInfo -> [String]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [String]
unitExtDepFrameworks [UnitInfo]
ps)
lookupModuleInAllUnits :: UnitState
-> ModuleName
-> [(Module, UnitInfo)]
lookupModuleInAllUnits :: UnitState -> ModuleName -> [(Module, UnitInfo)]
lookupModuleInAllUnits UnitState
pkgs ModuleName
m
= case UnitState -> ModuleName -> Maybe FastString -> LookupResult
lookupModuleWithSuggestions UnitState
pkgs ModuleName
m Maybe FastString
forall a. Maybe a
Nothing 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)
forall b. (Module, b) -> (Module, UnitInfo)
f [(Module, ModuleOrigin)]
rs
where f :: (Module, b) -> (Module, UnitInfo)
f (Module
m,b
_) = (Module
m, String -> Maybe UnitInfo -> UnitInfo
forall a. HasCallStack => 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
-> Maybe FastString
-> LookupResult
lookupModuleWithSuggestions :: UnitState -> ModuleName -> Maybe FastString -> LookupResult
lookupModuleWithSuggestions UnitState
pkgs
= UnitState
-> ModuleNameProvidersMap
-> ModuleName
-> Maybe FastString
-> LookupResult
lookupModuleWithSuggestions' UnitState
pkgs (UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap UnitState
pkgs)
lookupModulePackage :: UnitState -> ModuleName -> Maybe FastString -> Maybe [UnitInfo]
lookupModulePackage :: UnitState -> ModuleName -> Maybe FastString -> Maybe [UnitInfo]
lookupModulePackage UnitState
pkgs ModuleName
mn Maybe FastString
mfs =
case UnitState
-> ModuleNameProvidersMap
-> ModuleName
-> Maybe FastString
-> LookupResult
lookupModuleWithSuggestions' UnitState
pkgs (UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap UnitState
pkgs) ModuleName
mn Maybe FastString
mfs of
LookupFound Module
_ (UnitInfo
orig_unit, ModuleOrigin
origin) ->
case ModuleOrigin
origin of
ModOrigin {Maybe Bool
fromOrigUnit :: Maybe Bool
fromOrigUnit :: ModuleOrigin -> Maybe Bool
fromOrigUnit, [UnitInfo]
fromExposedReexport :: [UnitInfo]
fromExposedReexport :: ModuleOrigin -> [UnitInfo]
fromExposedReexport} ->
case Maybe Bool
fromOrigUnit of
Just Bool
True ->
[UnitInfo] -> Maybe [UnitInfo]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [UnitInfo
orig_unit]
Maybe Bool
_ -> [UnitInfo] -> Maybe [UnitInfo]
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
-> Maybe FastString
-> LookupResult
lookupPluginModuleWithSuggestions :: UnitState -> ModuleName -> Maybe FastString -> LookupResult
lookupPluginModuleWithSuggestions UnitState
pkgs
= UnitState
-> ModuleNameProvidersMap
-> ModuleName
-> Maybe FastString
-> LookupResult
lookupModuleWithSuggestions' UnitState
pkgs (UnitState -> ModuleNameProvidersMap
pluginModuleNameProvidersMap UnitState
pkgs)
lookupModuleWithSuggestions' :: UnitState
-> ModuleNameProvidersMap
-> ModuleName
-> Maybe FastString
-> LookupResult
lookupModuleWithSuggestions' :: UnitState
-> ModuleNameProvidersMap
-> ModuleName
-> Maybe FastString
-> LookupResult
lookupModuleWithSuggestions' UnitState
pkgs ModuleNameProvidersMap
mod_map ModuleName
m Maybe FastString
mb_pn
= case ModuleName
-> ModuleNameProvidersMap -> Maybe (Map Module ModuleOrigin)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ModuleName
m ModuleNameProvidersMap
mod_map of
Maybe (Map Module ModuleOrigin)
Nothing -> [ModuleSuggestion] -> LookupResult
LookupNotFound [ModuleSuggestion]
suggestions
Just Map 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 (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 ([],[],[], []) (Map Module ModuleOrigin -> [(Module, ModuleOrigin)]
forall k a. Map k a -> [(k, a)]
Map.toList Map 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 = Maybe FastString -> UnitInfo -> ModuleOrigin -> ModuleOrigin
filterOrigin Maybe FastString
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 UnusableUnitReason
_
-> ([(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
<+> 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 :: Maybe FastString
-> UnitInfo
-> ModuleOrigin
-> ModuleOrigin
filterOrigin :: Maybe FastString -> UnitInfo -> ModuleOrigin -> ModuleOrigin
filterOrigin Maybe FastString
Nothing UnitInfo
_ ModuleOrigin
o = ModuleOrigin
o
filterOrigin (Just FastString
pn) UnitInfo
pkg ModuleOrigin
o =
case ModuleOrigin
o of
ModuleOrigin
ModHidden -> if UnitInfo -> Bool
go UnitInfo
pkg then ModuleOrigin
ModHidden else ModuleOrigin
forall a. Monoid a => a
mempty
(ModUnusable UnusableUnitReason
_) -> if UnitInfo -> Bool
go UnitInfo
pkg then ModuleOrigin
o else 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 :: Maybe Bool -> [UnitInfo] -> [UnitInfo] -> Bool -> ModuleOrigin
ModOrigin {
fromOrigUnit :: Maybe Bool
fromOrigUnit = if UnitInfo -> Bool
go 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
go [UnitInfo]
res
, fromHiddenReexport :: [UnitInfo]
fromHiddenReexport = (UnitInfo -> Bool) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter UnitInfo -> Bool
go [UnitInfo]
rhs
, fromPackageFlag :: Bool
fromPackageFlag = Bool
False
}
where go :: UnitInfo -> Bool
go UnitInfo
pkg = FastString
pn FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> FastString
fsPackageName UnitInfo
pkg
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, Map Module ModuleOrigin
e) <- ModuleNameProvidersMap -> [(ModuleName, Map Module ModuleOrigin)]
forall k a. Map k a -> [(k, a)]
Map.toList (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) (Map Module ModuleOrigin -> [(Module, ModuleOrigin)]
forall k a. Map k a -> [(k, a)]
Map.toList Map 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, Map Module ModuleOrigin) -> ModuleName)
-> [(ModuleName, Map Module ModuleOrigin)] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, Map Module ModuleOrigin) -> ModuleName
forall a b. (a, b) -> a
fst (((ModuleName, Map Module ModuleOrigin) -> Bool)
-> [(ModuleName, Map Module ModuleOrigin)]
-> [(ModuleName, Map Module ModuleOrigin)]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleName, Map Module ModuleOrigin) -> Bool
forall a k. (a, Map k ModuleOrigin) -> Bool
visible (ModuleNameProvidersMap -> [(ModuleName, Map Module ModuleOrigin)]
forall k a. Map k a -> [(k, a)]
Map.toList (UnitState -> ModuleNameProvidersMap
moduleNameProvidersMap UnitState
state)))
where visible :: (a, Map k ModuleOrigin) -> Bool
visible (a
_, Map k ModuleOrigin
ms) = (ModuleOrigin -> Bool) -> [ModuleOrigin] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ModuleOrigin -> Bool
originVisible (Map k ModuleOrigin -> [ModuleOrigin]
forall k a. Map k a -> [a]
Map.elems Map k ModuleOrigin
ms)
getPreloadUnitsAnd :: DynFlags -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd :: DynFlags -> [UnitId] -> IO [UnitInfo]
getPreloadUnitsAnd DynFlags
dflags [UnitId]
ids0 =
let
ids :: [UnitId]
ids = [UnitId]
ids0 [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++
if DynFlags -> Bool
homeUnitIsIndefinite DynFlags
dflags
then []
else ((ModuleName, Module) -> UnitId)
-> [(ModuleName, Module)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (Unit -> UnitId
toUnitId (Unit -> UnitId)
-> ((ModuleName, Module) -> Unit) -> (ModuleName, Module) -> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Module -> Unit
forall unit. GenModule unit -> unit
moduleUnit (Module -> Unit)
-> ((ModuleName, Module) -> Module) -> (ModuleName, Module) -> Unit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ModuleName, Module) -> Module
forall a b. (a, b) -> b
snd)
(DynFlags -> [(ModuleName, Module)]
homeUnitInstantiations DynFlags
dflags)
state :: UnitState
state = DynFlags -> UnitState
unitState DynFlags
dflags
pkg_map :: UnitInfoMap
pkg_map = UnitState -> UnitInfoMap
unitInfoMap UnitState
state
preload :: [UnitId]
preload = UnitState -> [UnitId]
preloadUnits UnitState
state
ctx :: SDocContext
ctx = DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultUserStyle
in do
[UnitId]
all_pkgs <- SDocContext -> MaybeErr SDoc [UnitId] -> IO [UnitId]
forall a. SDocContext -> MaybeErr SDoc a -> IO a
throwErr SDocContext
ctx (UnitInfoMap
-> [UnitId] -> [(UnitId, Maybe UnitId)] -> MaybeErr SDoc [UnitId]
closeUnitDeps' UnitInfoMap
pkg_map [UnitId]
preload ([UnitId]
ids [UnitId] -> [Maybe UnitId] -> [(UnitId, Maybe UnitId)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` Maybe UnitId -> [Maybe UnitId]
forall a. a -> [a]
repeat Maybe UnitId
forall a. Maybe a
Nothing))
[UnitInfo] -> IO [UnitInfo]
forall (m :: * -> *) a. Monad m => a -> m a
return ((UnitId -> UnitInfo) -> [UnitId] -> [UnitInfo]
forall a b. (a -> b) -> [a] -> [b]
map (HasDebugCallStack => UnitState -> UnitId -> UnitInfo
UnitState -> UnitId -> UnitInfo
unsafeLookupUnitId UnitState
state) [UnitId]
all_pkgs)
throwErr :: SDocContext -> MaybeErr MsgDoc a -> IO a
throwErr :: SDocContext -> MaybeErr SDoc a -> IO a
throwErr SDocContext
ctx MaybeErr SDoc a
m = case MaybeErr SDoc a
m of
Failed SDoc
e -> GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO (String -> GhcException
CmdLineError (SDocContext -> SDoc -> String
renderWithStyle SDocContext
ctx SDoc
e))
Succeeded a
r -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr MsgDoc [UnitId]
closeUnitDeps :: UnitInfoMap -> [(UnitId, Maybe UnitId)] -> MaybeErr SDoc [UnitId]
closeUnitDeps UnitInfoMap
pkg_map [(UnitId, Maybe UnitId)]
ps = UnitInfoMap
-> [UnitId] -> [(UnitId, Maybe UnitId)] -> MaybeErr SDoc [UnitId]
closeUnitDeps' UnitInfoMap
pkg_map [] [(UnitId, Maybe UnitId)]
ps
closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr MsgDoc [UnitId]
closeUnitDeps' :: UnitInfoMap
-> [UnitId] -> [(UnitId, Maybe UnitId)] -> MaybeErr SDoc [UnitId]
closeUnitDeps' UnitInfoMap
pkg_map [UnitId]
current_ids [(UnitId, Maybe UnitId)]
ps = ([UnitId] -> (UnitId, Maybe UnitId) -> MaybeErr SDoc [UnitId])
-> [UnitId] -> [(UnitId, Maybe UnitId)] -> MaybeErr SDoc [UnitId]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (UnitInfoMap
-> [UnitId] -> (UnitId, Maybe UnitId) -> MaybeErr SDoc [UnitId]
add_unit UnitInfoMap
pkg_map) [UnitId]
current_ids [(UnitId, Maybe UnitId)]
ps
add_unit :: UnitInfoMap
-> [UnitId]
-> (UnitId,Maybe UnitId)
-> MaybeErr MsgDoc [UnitId]
add_unit :: UnitInfoMap
-> [UnitId] -> (UnitId, Maybe UnitId) -> MaybeErr SDoc [UnitId]
add_unit UnitInfoMap
pkg_map [UnitId]
ps (UnitId
p, Maybe UnitId
mb_parent)
| UnitId
p UnitId -> [UnitId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnitId]
ps = [UnitId] -> MaybeErr SDoc [UnitId]
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 -> SDoc -> MaybeErr SDoc [UnitId]
forall err val. err -> MaybeErr err val
Failed (SDoc -> MaybeErr SDoc [UnitId]) -> SDoc -> MaybeErr SDoc [UnitId]
forall a b. (a -> b) -> a -> b
$
(FastString -> SDoc
ftext (String -> FastString
fsLit String
"unknown package:") SDoc -> SDoc -> SDoc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
p)
SDoc -> SDoc -> SDoc
<> case Maybe UnitId
mb_parent of
Maybe UnitId
Nothing -> SDoc
Outputable.empty
Just UnitId
parent -> SDoc
space SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (String -> SDoc
text String
"dependency of"
SDoc -> SDoc -> SDoc
<+> FastString -> SDoc
ftext (UnitId -> FastString
unitIdFS UnitId
parent))
Just UnitInfo
info -> do
[UnitId]
ps' <- ([UnitId] -> UnitId -> MaybeErr SDoc [UnitId])
-> [UnitId] -> [UnitId] -> MaybeErr SDoc [UnitId]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [UnitId] -> UnitId -> MaybeErr SDoc [UnitId]
add_unit_key [UnitId]
ps (UnitInfo -> [UnitId]
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> [uid]
unitDepends UnitInfo
info)
[UnitId] -> MaybeErr SDoc [UnitId]
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitId
p UnitId -> [UnitId] -> [UnitId]
forall a. a -> [a] -> [a]
: [UnitId]
ps')
where
add_unit_key :: [UnitId] -> UnitId -> MaybeErr SDoc [UnitId]
add_unit_key [UnitId]
ps UnitId
key
= UnitInfoMap
-> [UnitId] -> (UnitId, Maybe UnitId) -> MaybeErr SDoc [UnitId]
add_unit UnitInfoMap
pkg_map [UnitId]
ps (UnitId
key, UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just UnitId
p)
mkIndefUnitId :: UnitState -> FastString -> IndefUnitId
mkIndefUnitId :: UnitState -> FastString -> IndefUnitId
mkIndefUnitId UnitState
pkgstate FastString
raw =
let uid :: UnitId
uid = FastString -> UnitId
UnitId FastString
raw
in case UnitState -> UnitId -> Maybe UnitInfo
lookupUnitId UnitState
pkgstate UnitId
uid of
Maybe UnitInfo
Nothing -> UnitId -> Maybe UnitPprInfo -> IndefUnitId
forall unit. unit -> Maybe UnitPprInfo -> Indefinite unit
Indefinite UnitId
uid Maybe UnitPprInfo
forall a. Maybe a
Nothing
Just UnitInfo
c -> UnitId -> Maybe UnitPprInfo -> IndefUnitId
forall unit. unit -> Maybe UnitPprInfo -> Indefinite unit
Indefinite UnitId
uid (Maybe UnitPprInfo -> IndefUnitId)
-> Maybe UnitPprInfo -> IndefUnitId
forall a b. (a -> b) -> a -> b
$ UnitPprInfo -> Maybe UnitPprInfo
forall a. a -> Maybe a
Just (UnitPprInfo -> Maybe UnitPprInfo)
-> UnitPprInfo -> Maybe UnitPprInfo
forall a b. (a -> b) -> a -> b
$ UnitInfo -> UnitPprInfo
forall u. GenUnitInfo u -> UnitPprInfo
mkUnitPprInfo UnitInfo
c
updateIndefUnitId :: UnitState -> IndefUnitId -> IndefUnitId
updateIndefUnitId :: UnitState -> IndefUnitId -> IndefUnitId
updateIndefUnitId UnitState
pkgstate IndefUnitId
uid = UnitState -> FastString -> IndefUnitId
mkIndefUnitId UnitState
pkgstate (UnitId -> FastString
unitIdFS (IndefUnitId -> UnitId
forall unit. Indefinite unit -> unit
indefUnit IndefUnitId
uid))
displayUnitId :: UnitState -> UnitId -> Maybe String
displayUnitId :: UnitState -> UnitId -> Maybe String
displayUnitId UnitState
pkgstate UnitId
uid =
(UnitInfo -> String) -> Maybe UnitInfo -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UnitInfo -> String
forall u. GenUnitInfo u -> String
unitPackageIdString (UnitState -> UnitId -> Maybe UnitInfo
lookupUnitId UnitState
pkgstate 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
vcat (SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
intersperse (String -> SDoc
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 compid srcpkgid srcpkgname modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
-> SDoc
pprIPI
where pprIPI :: GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
-> SDoc
pprIPI GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
ipi = let i :: FastString
i = UnitId -> FastString
unitIdFS (GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
-> UnitId
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> uid
unitId GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
ipi)
e :: SDoc
e = if GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
-> Bool
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitIsExposed GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
ipi then String -> SDoc
text String
"E" else String -> SDoc
text String
" "
t :: SDoc
t = if GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
-> Bool
forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitIsTrusted GenericUnitInfo compid srcpkgid srcpkgname UnitId modulename mod
ipi then String -> SDoc
text String
"T" else String -> SDoc
text String
" "
in SDoc
e SDoc -> SDoc -> SDoc
<> SDoc
t SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
" " SDoc -> SDoc -> SDoc
<> FastString -> SDoc
ftext FastString
i
pprModuleMap :: ModuleNameProvidersMap -> SDoc
pprModuleMap :: ModuleNameProvidersMap -> SDoc
pprModuleMap ModuleNameProvidersMap
mod_map =
[SDoc] -> SDoc
vcat (((ModuleName, Map Module ModuleOrigin) -> SDoc)
-> [(ModuleName, Map Module ModuleOrigin)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName, Map Module ModuleOrigin) -> SDoc
forall a. Outputable a => (ModuleName, Map Module a) -> SDoc
pprLine (ModuleNameProvidersMap -> [(ModuleName, Map Module ModuleOrigin)]
forall k a. Map k a -> [(k, a)]
Map.toList ModuleNameProvidersMap
mod_map))
where
pprLine :: (ModuleName, Map Module a) -> SDoc
pprLine (ModuleName
m,Map Module a
e) = ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModuleName
m SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
50 ([SDoc] -> SDoc
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) (Map Module a -> [(Module, a)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Module a
e)))
pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc
pprEntry :: 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
<+> SDoc -> SDoc
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
<+> SDoc -> SDoc
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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid 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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid 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 -> Indefinite unit
instUnitInstanceOf = IndefUnitId
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 key elt. UniqFM key elt -> Bool
isNullUFM ((ModuleName -> Module -> ModuleName)
-> UniqFM ModuleName ModuleName
-> UniqFM ModuleName Module
-> UniqFM ModuleName ModuleName
forall elt1 elt2 elt3 key.
(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 key 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
$
IndefUnitId -> [(ModuleName, Module)] -> Unit
mkVirtUnit IndefUnitId
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