module GHC.Unit.External.Validate (
  -- * Validation of unit databases
  validateDatabase,
  reportUnusable,
  UnusableUnits,
  UnusableUnit(..),
  UnusableUnitReason(..),
  pprReason,
  -- * Package resolver
  findPackages,
  selectPackages,
  -- * Unit database closure validation
  UnitErr(..),
  mayThrowUnitErr,
  closeUnitDeps,
  closeUnitDeps',
  -- * Utils
  ignoreUnits,
  pprFlag,
) where

import GHC.Prelude

import Control.Monad
import Data.Graph (SCC (..), stronglyConnComp)
import Data.List (partition)
import GHC.Data.Maybe
import GHC.Driver.DynFlags
import GHC.Types.Unique.Map
import GHC.Unit.External.Database
import GHC.Unit.External.Query
import GHC.Unit.External.Substitution
import GHC.Unit.Info
import GHC.Unit.Types
import GHC.Utils.Error
import GHC.Utils.Logger
import GHC.Utils.Outputable
import GHC.Utils.Outputable qualified as Outputable
import GHC.Utils.Panic

-- -----------------------------------------------------------------------------
-- Database validation

-- | Validates a database, removing unusable units from it
-- (this includes removing units that the user has explicitly
-- ignored.)  Our general strategy:
--
-- 1. Remove all broken units (dangling dependencies)
-- 2. Remove all units that are cyclic
-- 3. Apply ignore flags
-- 4. Remove all units which have deps with mismatching ABIs
--
validateDatabase :: [IgnorePackageFlag] -> UnitInfoMap
                 -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo])
validateDatabase :: [IgnorePackageFlag]
-> UnitInfoMap -> (UnitInfoMap, UnusableUnits, [SCC UnitInfo])
validateDatabase [IgnorePackageFlag]
flagsIgnored UnitInfoMap
pkg_map1 =
    (UnitInfoMap
pkg_map5, UnusableUnits
unusable, [SCC UnitInfo]
sccs)
  where
    ignore_flags :: [IgnorePackageFlag]
ignore_flags = [IgnorePackageFlag] -> [IgnorePackageFlag]
forall a. [a] -> [a]
reverse [IgnorePackageFlag]
flagsIgnored -- (unitConfigFlagsIgnored cfg)

    -- Compute the reverse dependency index
    index :: RevIndex
index = UnitInfoMap -> RevIndex
reverseDeps UnitInfoMap
pkg_map1

    -- Helper function
    mk_unusable :: (t -> b)
-> (t -> GenericUnitInfo srcpkgid srcpkgname k modulename mod -> t)
-> t
-> [GenericUnitInfo srcpkgid srcpkgname k modulename mod]
-> UniqMap
     k (GenericUnitInfo srcpkgid srcpkgname k modulename mod, b)
mk_unusable t -> b
mk_err t -> GenericUnitInfo srcpkgid srcpkgname k modulename mod -> t
dep_matcher t
m [GenericUnitInfo srcpkgid srcpkgname k modulename mod]
uids =
      [(k, (GenericUnitInfo srcpkgid srcpkgname k modulename mod, b))]
-> UniqMap
     k (GenericUnitInfo srcpkgid srcpkgname k modulename mod, b)
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap [ (GenericUnitInfo srcpkgid srcpkgname k modulename mod -> k
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId GenericUnitInfo srcpkgid srcpkgname k modulename mod
pkg, (GenericUnitInfo srcpkgid srcpkgname k modulename mod
pkg, t -> b
mk_err (t -> GenericUnitInfo srcpkgid srcpkgname k modulename mod -> t
dep_matcher t
m GenericUnitInfo srcpkgid srcpkgname k modulename mod
pkg)))
                    | GenericUnitInfo srcpkgid srcpkgname k modulename mod
pkg <- [GenericUnitInfo srcpkgid srcpkgname k modulename mod]
uids
                    ]

    -- Find broken units
    directly_broken :: [UnitInfo]
directly_broken = (UnitInfo -> Bool) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (UnitInfo -> Bool) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([UnitId] -> Bool) -> (UnitInfo -> [UnitId]) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfoMap -> UnitInfo -> [UnitId]
depsNotAvailable UnitInfoMap
pkg_map1)
                             (UnitInfoMap -> [UnitInfo]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap UnitInfoMap
pkg_map1)
    (UnitInfoMap
pkg_map2, [UnitInfo]
broken) = [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits ((UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
directly_broken) RevIndex
index UnitInfoMap
pkg_map1
    unusable_broken :: UnusableUnits
unusable_broken = ([UnitId] -> UnusableUnitReason)
-> (UnitInfoMap -> UnitInfo -> [UnitId])
-> UnitInfoMap
-> [UnitInfo]
-> UnusableUnits
forall {k} {t} {b} {t} {srcpkgid} {srcpkgname} {modulename} {mod}.
Uniquable k =>
(t -> b)
-> (t -> GenericUnitInfo srcpkgid srcpkgname k modulename mod -> t)
-> t
-> [GenericUnitInfo srcpkgid srcpkgname k modulename mod]
-> UniqMap
     k (GenericUnitInfo srcpkgid srcpkgname k modulename mod, b)
mk_unusable [UnitId] -> UnusableUnitReason
[UnitId] -> UnusableUnitReason
BrokenDependencies UnitInfoMap -> UnitInfo -> [UnitId]
depsNotAvailable UnitInfoMap
pkg_map2 [UnitInfo]
broken

    -- Find recursive units
    sccs :: [SCC UnitInfo]
sccs = [(UnitInfo, UnitId, [UnitId])] -> [SCC UnitInfo]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp [ (UnitInfo
pkg, UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
pkg, UnitInfo -> [UnitId]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends UnitInfo
pkg)
                            | UnitInfo
pkg <- UnitInfoMap -> [UnitInfo]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap UnitInfoMap
pkg_map2 ]
    getCyclicSCC :: SCC (GenericUnitInfo srcpkgid srcpkgname b modulename mod) -> [b]
getCyclicSCC (CyclicSCC [GenericUnitInfo srcpkgid srcpkgname b modulename mod]
vs) = (GenericUnitInfo srcpkgid srcpkgname b modulename mod -> b)
-> [GenericUnitInfo srcpkgid srcpkgname b modulename mod] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map GenericUnitInfo srcpkgid srcpkgname b modulename mod -> b
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [GenericUnitInfo srcpkgid srcpkgname b modulename mod]
vs
    getCyclicSCC (AcyclicSCC GenericUnitInfo srcpkgid srcpkgname b modulename mod
_) = []
    (UnitInfoMap
pkg_map3, [UnitInfo]
cyclic) = [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits ((SCC UnitInfo -> [UnitId]) -> [SCC UnitInfo] -> [UnitId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SCC UnitInfo -> [UnitId]
forall {srcpkgid} {srcpkgname} {b} {modulename} {mod}.
SCC (GenericUnitInfo srcpkgid srcpkgname b modulename mod) -> [b]
getCyclicSCC [SCC UnitInfo]
sccs) RevIndex
index UnitInfoMap
pkg_map2
    unusable_cyclic :: UnusableUnits
unusable_cyclic = ([UnitId] -> UnusableUnitReason)
-> (UnitInfoMap -> UnitInfo -> [UnitId])
-> UnitInfoMap
-> [UnitInfo]
-> UnusableUnits
forall {k} {t} {b} {t} {srcpkgid} {srcpkgname} {modulename} {mod}.
Uniquable k =>
(t -> b)
-> (t -> GenericUnitInfo srcpkgid srcpkgname k modulename mod -> t)
-> t
-> [GenericUnitInfo srcpkgid srcpkgname k modulename mod]
-> UniqMap
     k (GenericUnitInfo srcpkgid srcpkgname k modulename mod, b)
mk_unusable [UnitId] -> UnusableUnitReason
[UnitId] -> UnusableUnitReason
CyclicDependencies UnitInfoMap -> UnitInfo -> [UnitId]
depsNotAvailable UnitInfoMap
pkg_map3 [UnitInfo]
cyclic

    -- Apply ignore flags
    directly_ignored :: UnusableUnits
directly_ignored = [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits
ignoreUnits [IgnorePackageFlag]
ignore_flags (UnitInfoMap -> [UnitInfo]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap UnitInfoMap
pkg_map3)
    (UnitInfoMap
pkg_map4, [UnitInfo]
ignored) = [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits (UnusableUnits -> [UnitId]
forall k a. UniqMap k a -> [k]
nonDetKeysUniqMap UnusableUnits
directly_ignored) RevIndex
index UnitInfoMap
pkg_map3
    unusable_ignored :: UnusableUnits
unusable_ignored = ([UnitId] -> UnusableUnitReason)
-> (UnitInfoMap -> UnitInfo -> [UnitId])
-> UnitInfoMap
-> [UnitInfo]
-> UnusableUnits
forall {k} {t} {b} {t} {srcpkgid} {srcpkgname} {modulename} {mod}.
Uniquable k =>
(t -> b)
-> (t -> GenericUnitInfo srcpkgid srcpkgname k modulename mod -> t)
-> t
-> [GenericUnitInfo srcpkgid srcpkgname k modulename mod]
-> UniqMap
     k (GenericUnitInfo srcpkgid srcpkgname k modulename mod, b)
mk_unusable [UnitId] -> UnusableUnitReason
[UnitId] -> UnusableUnitReason
IgnoredDependencies UnitInfoMap -> UnitInfo -> [UnitId]
depsNotAvailable UnitInfoMap
pkg_map4 [UnitInfo]
ignored

    -- Knock out units whose dependencies don't agree with ABI
    -- (i.e., got invalidated due to shadowing)
    directly_shadowed :: [UnitInfo]
directly_shadowed = (UnitInfo -> Bool) -> [UnitInfo] -> [UnitInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (UnitInfo -> Bool) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [UnitId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([UnitId] -> Bool) -> (UnitInfo -> [UnitId]) -> UnitInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfoMap -> UnitInfo -> [UnitId]
depsAbiMismatch UnitInfoMap
pkg_map4)
                               (UnitInfoMap -> [UnitInfo]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap UnitInfoMap
pkg_map4)
    (UnitInfoMap
pkg_map5, [UnitInfo]
shadowed) = [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits ((UnitInfo -> UnitId) -> [UnitInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId [UnitInfo]
directly_shadowed) RevIndex
index UnitInfoMap
pkg_map4
    unusable_shadowed :: UnusableUnits
unusable_shadowed = ([UnitId] -> UnusableUnitReason)
-> (UnitInfoMap -> UnitInfo -> [UnitId])
-> UnitInfoMap
-> [UnitInfo]
-> UnusableUnits
forall {k} {t} {b} {t} {srcpkgid} {srcpkgname} {modulename} {mod}.
Uniquable k =>
(t -> b)
-> (t -> GenericUnitInfo srcpkgid srcpkgname k modulename mod -> t)
-> t
-> [GenericUnitInfo srcpkgid srcpkgname k modulename mod]
-> UniqMap
     k (GenericUnitInfo srcpkgid srcpkgname k modulename mod, b)
mk_unusable [UnitId] -> UnusableUnitReason
[UnitId] -> UnusableUnitReason
ShadowedDependencies UnitInfoMap -> UnitInfo -> [UnitId]
depsAbiMismatch UnitInfoMap
pkg_map5 [UnitInfo]
shadowed

    -- combine all unusables. The order is important for shadowing.
    -- plusUniqMapList folds using plusUFM which is right biased (opposite of
    -- Data.Map.union) so the head of the list should be the least preferred
    unusable :: UnusableUnits
unusable = [UnusableUnits] -> UnusableUnits
forall k a. [UniqMap k a] -> UniqMap k a
plusUniqMapList [ UnusableUnits
unusable_shadowed
                               , UnusableUnits
unusable_cyclic
                               , UnusableUnits
unusable_broken
                               , UnusableUnits
unusable_ignored
                               , UnusableUnits
directly_ignored
                               ]


type UnusableUnits = UniqMap UnitId (UnitInfo, UnusableUnitReason)

-- | A unusable unit module origin
data UnusableUnit = UnusableUnit
  { UnusableUnit -> Unit
uuUnit        :: !Unit               -- ^ Unusable unit
  , UnusableUnit -> UnusableUnitReason
uuReason      :: !UnusableUnitReason -- ^ Reason
  , UnusableUnit -> Bool
uuIsReexport  :: !Bool               -- ^ Is the "module" a reexport?
  }

-- | The reason why a unit is unusable.
data UnusableUnitReason
  = -- | We ignored it explicitly using @-ignore-package@.
    IgnoredWithFlag
    -- | This unit transitively depends on a unit that was never present
    -- in any of the provided databases.
  | BrokenDependencies   [UnitId]
    -- | This unit transitively depends on a unit involved in a cycle.
    -- Note that the list of 'UnitId' reports the direct dependencies
    -- of this unit that (transitively) depended on the cycle, and not
    -- the actual cycle itself (which we report separately at high verbosity.)
  | CyclicDependencies   [UnitId]
    -- | This unit transitively depends on a unit which was ignored.
  | IgnoredDependencies  [UnitId]
    -- | This unit transitively depends on a unit which was
    -- shadowed by an ABI-incompatible unit.
  | ShadowedDependencies [UnitId]

instance Outputable UnusableUnitReason where
    ppr :: UnusableUnitReason -> SDoc
ppr UnusableUnitReason
IgnoredWithFlag = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"[ignored with flag]"
    ppr (BrokenDependencies [UnitId]
uids)   = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"broken" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [UnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
uids)
    ppr (CyclicDependencies [UnitId]
uids)   = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cyclic" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [UnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
uids)
    ppr (IgnoredDependencies [UnitId]
uids)  = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ignored" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [UnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
uids)
    ppr (ShadowedDependencies [UnitId]
uids) = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"shadowed" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [UnitId] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
uids)

pprReason :: SDoc -> UnusableUnitReason -> SDoc
pprReason :: SDoc -> UnusableUnitReason -> SDoc
pprReason SDoc
pref UnusableUnitReason
reason = case UnusableUnitReason
reason of
  UnusableUnitReason
IgnoredWithFlag ->
      SDoc
pref SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"ignored due to an -ignore-package flag"
  BrokenDependencies [UnitId]
deps ->
      SDoc
pref SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"unusable due to missing dependencies:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
        Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ((UnitId -> SDoc) -> [UnitId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
deps))
  CyclicDependencies [UnitId]
deps ->
      SDoc
pref SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"unusable due to cyclic dependencies:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
        Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ((UnitId -> SDoc) -> [UnitId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
deps))
  IgnoredDependencies [UnitId]
deps ->
      SDoc
pref SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text (String
"unusable because the -ignore-package flag was used to " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                     String
"ignore at least one of its dependencies:") SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
        Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ((UnitId -> SDoc) -> [UnitId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
deps))
  ShadowedDependencies [UnitId]
deps ->
      SDoc
pref SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"unusable due to shadowed dependencies:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
        Int -> SDoc -> SDoc
nest Int
2 ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep ((UnitId -> SDoc) -> [UnitId] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr [UnitId]
deps))

reportUnusable :: Logger -> UnusableUnits -> IO ()
reportUnusable :: Logger -> UnusableUnits -> IO ()
reportUnusable Logger
logger UnusableUnits
pkgs = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> Int -> Bool
logVerbAtLeast Logger
logger Int
2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ((UnitId, (UnitInfo, UnusableUnitReason)) -> IO ())
-> [(UnitId, (UnitInfo, UnusableUnitReason))] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UnitId, (UnitInfo, UnusableUnitReason)) -> IO ()
report (UnusableUnits -> [(UnitId, (UnitInfo, UnusableUnitReason))]
forall k a. UniqMap k a -> [(k, a)]
nonDetUniqMapToList UnusableUnits
pkgs)
  where
    report :: (UnitId, (UnitInfo, UnusableUnitReason)) -> IO ()
report (UnitId
ipid, (UnitInfo
_, UnusableUnitReason
reason)) =
       Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
         SDoc -> UnusableUnitReason -> SDoc
pprReason
           (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"package" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
ipid SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is") UnusableUnitReason
reason

-- -----------------------------------------------------------------------------
-- Package Finding

-- | Like 'selectPackages', but doesn't return a list of unmatched
-- packages.  Furthermore, any packages it returns are *renamed*
-- if the 'UnitArg' has a renaming associated with it.
findPackages :: UnitPrecedenceMap
             -> UnitInfoMap
             -> PackageArg -> [UnitInfo]
             -> UnusableUnits
             -> Either [(UnitInfo, UnusableUnitReason)]
                [UnitInfo]
findPackages :: UnitPrecedenceMap
-> UnitInfoMap
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo]
findPackages UnitPrecedenceMap
prec_map UnitInfoMap
pkg_map PackageArg
arg [UnitInfo]
pkgs UnusableUnits
unusable
  = let ps :: [UnitInfo]
ps = (UnitInfo -> Maybe UnitInfo) -> [UnitInfo] -> [UnitInfo]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PackageArg -> UnitInfo -> Maybe UnitInfo
finder PackageArg
arg) [UnitInfo]
pkgs
    in if [UnitInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitInfo]
ps
        then [(UnitInfo, UnusableUnitReason)]
-> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo]
forall a b. a -> Either a b
Left (((UnitInfo, UnusableUnitReason)
 -> Maybe (UnitInfo, UnusableUnitReason))
-> [(UnitInfo, UnusableUnitReason)]
-> [(UnitInfo, UnusableUnitReason)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(UnitInfo
x,UnusableUnitReason
y) -> PackageArg -> UnitInfo -> Maybe UnitInfo
finder PackageArg
arg UnitInfo
x Maybe UnitInfo
-> (UnitInfo -> Maybe (UnitInfo, UnusableUnitReason))
-> Maybe (UnitInfo, UnusableUnitReason)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \UnitInfo
x' -> (UnitInfo, UnusableUnitReason)
-> Maybe (UnitInfo, UnusableUnitReason)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitInfo
x',UnusableUnitReason
y))
                            (UnusableUnits -> [(UnitInfo, UnusableUnitReason)]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap UnusableUnits
unusable))
        else [UnitInfo] -> Either [(UnitInfo, UnusableUnitReason)] [UnitInfo]
forall a b. b -> Either a b
Right (UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
sortByPreference UnitPrecedenceMap
prec_map [UnitInfo]
ps)
  where
    finder :: PackageArg -> UnitInfo -> Maybe UnitInfo
finder (PackageArg String
str) UnitInfo
p
      = if String -> UnitInfo -> Bool
matchingStr String
str UnitInfo
p
          then UnitInfo -> Maybe UnitInfo
forall a. a -> Maybe a
Just UnitInfo
p
          else Maybe UnitInfo
forall a. Maybe a
Nothing
    finder (UnitIdArg Unit
uid) UnitInfo
p
      = case Unit
uid of
          RealUnit (Definite UnitId
iuid)
            | UnitId
iuid UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
p
            -> UnitInfo -> Maybe UnitInfo
forall a. a -> Maybe a
Just UnitInfo
p
          VirtUnit GenInstantiatedUnit UnitId
inst
            | GenInstantiatedUnit UnitId -> UnitId
forall unit. GenInstantiatedUnit unit -> unit
instUnitInstanceOf GenInstantiatedUnit UnitId
inst UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
p
            -> UnitInfo -> Maybe UnitInfo
forall a. a -> Maybe a
Just (UnitInfoMap -> [(ModuleName, Module)] -> UnitInfo -> UnitInfo
renameUnitInfo UnitInfoMap
pkg_map (GenInstantiatedUnit UnitId -> [(ModuleName, Module)]
forall unit. GenInstantiatedUnit unit -> GenInstantiations unit
instUnitInsts GenInstantiatedUnit UnitId
inst) UnitInfo
p)
          Unit
_ -> Maybe UnitInfo
forall a. Maybe a
Nothing

selectPackages :: UnitPrecedenceMap -> PackageArg -> [UnitInfo]
               -> UnusableUnits
               -> Either [(UnitInfo, UnusableUnitReason)]
                  ([UnitInfo], [UnitInfo])
selectPackages :: UnitPrecedenceMap
-> PackageArg
-> [UnitInfo]
-> UnusableUnits
-> Either [(UnitInfo, UnusableUnitReason)] ([UnitInfo], [UnitInfo])
selectPackages UnitPrecedenceMap
prec_map PackageArg
arg [UnitInfo]
pkgs UnusableUnits
unusable
  = let matches :: UnitInfo -> Bool
matches = PackageArg -> UnitInfo -> Bool
matching PackageArg
arg
        ([UnitInfo]
ps,[UnitInfo]
rest) = (UnitInfo -> Bool) -> [UnitInfo] -> ([UnitInfo], [UnitInfo])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition UnitInfo -> Bool
matches [UnitInfo]
pkgs
    in if [UnitInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [UnitInfo]
ps
        then [(UnitInfo, UnusableUnitReason)]
-> Either [(UnitInfo, UnusableUnitReason)] ([UnitInfo], [UnitInfo])
forall a b. a -> Either a b
Left (((UnitInfo, UnusableUnitReason) -> Bool)
-> [(UnitInfo, UnusableUnitReason)]
-> [(UnitInfo, UnusableUnitReason)]
forall a. (a -> Bool) -> [a] -> [a]
filter (UnitInfo -> Bool
matches(UnitInfo -> Bool)
-> ((UnitInfo, UnusableUnitReason) -> UnitInfo)
-> (UnitInfo, UnusableUnitReason)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(UnitInfo, UnusableUnitReason) -> UnitInfo
forall a b. (a, b) -> a
fst) (UnusableUnits -> [(UnitInfo, UnusableUnitReason)]
forall k a. UniqMap k a -> [a]
nonDetEltsUniqMap UnusableUnits
unusable))
        else ([UnitInfo], [UnitInfo])
-> Either [(UnitInfo, UnusableUnitReason)] ([UnitInfo], [UnitInfo])
forall a b. b -> Either a b
Right (UnitPrecedenceMap -> [UnitInfo] -> [UnitInfo]
sortByPreference UnitPrecedenceMap
prec_map [UnitInfo]
ps, [UnitInfo]
rest)

-- -----------------------------------------------------------------------------
-- Ignore units

ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits
ignoreUnits :: [IgnorePackageFlag] -> [UnitInfo] -> UnusableUnits
ignoreUnits [IgnorePackageFlag]
flags [UnitInfo]
pkgs = [(UnitId, (UnitInfo, UnusableUnitReason))] -> UnusableUnits
forall k a. Uniquable k => [(k, a)] -> UniqMap k a
listToUniqMap ((IgnorePackageFlag -> [(UnitId, (UnitInfo, UnusableUnitReason))])
-> [IgnorePackageFlag]
-> [(UnitId, (UnitInfo, UnusableUnitReason))]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap IgnorePackageFlag -> [(UnitId, (UnitInfo, UnusableUnitReason))]
doit [IgnorePackageFlag]
flags)
  where
  doit :: IgnorePackageFlag -> [(UnitId, (UnitInfo, UnusableUnitReason))]
doit (IgnorePackage String
str) =
     case (UnitInfo -> Bool) -> [UnitInfo] -> ([UnitInfo], [UnitInfo])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (String -> UnitInfo -> Bool
matchingStr String
str) [UnitInfo]
pkgs of
         ([UnitInfo]
ps, [UnitInfo]
_) -> [ (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
p, (UnitInfo
p, UnusableUnitReason
IgnoredWithFlag))
                    | UnitInfo
p <- [UnitInfo]
ps ]
        -- missing unit is not an error for -ignore-package,
        -- because a common usage is to -ignore-package P as
        -- a preventative measure just in case P exists.

-- A package named on the command line can either include the
-- version, or just the name if it is unambiguous.
matchingStr :: String -> UnitInfo -> Bool
matchingStr :: String -> UnitInfo -> Bool
matchingStr String
str UnitInfo
p
        =  String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> String
forall u. GenUnitInfo u -> String
unitPackageIdString UnitInfo
p
        Bool -> Bool -> Bool
|| String
str String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> String
forall u. GenUnitInfo u -> String
unitPackageNameString UnitInfo
p

matchingId :: UnitId -> UnitInfo -> Bool
matchingId :: UnitId -> UnitInfo -> Bool
matchingId UnitId
uid UnitInfo
p = UnitId
uid UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
p

matching :: PackageArg -> UnitInfo -> Bool
matching :: PackageArg -> UnitInfo -> Bool
matching (PackageArg String
str) = String -> UnitInfo -> Bool
matchingStr String
str
matching (UnitIdArg (RealUnit (Definite UnitId
uid))) = UnitId -> UnitInfo -> Bool
matchingId UnitId
uid
matching (UnitIdArg Unit
_)  = \UnitInfo
_ -> Bool
False -- TODO: warn in this case

-- ----------------------------------------------------------------------------
--
-- Closures
--


-- | Takes a list of UnitIds (and their "parent" dependency, used for error
-- messages), and returns the list with dependencies included, in reverse
-- dependency order (a units appears before those it depends on).
closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
closeUnitDeps :: UnitInfoMap
-> [(UnitId, Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
closeUnitDeps UnitInfoMap
pkg_map [(UnitId, Maybe UnitId)]
ps = UnitInfoMap
-> [UnitId]
-> [(UnitId, Maybe UnitId)]
-> MaybeErr UnitErr [UnitId]
closeUnitDeps' UnitInfoMap
pkg_map [] [(UnitId, Maybe UnitId)]
ps

-- | Similar to closeUnitDeps but takes a list of already loaded units as an
-- additional argument.
closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId]
closeUnitDeps' :: UnitInfoMap
-> [UnitId]
-> [(UnitId, Maybe UnitId)]
-> MaybeErr UnitErr [UnitId]
closeUnitDeps' UnitInfoMap
pkg_map [UnitId]
current_ids [(UnitId, Maybe UnitId)]
ps = ([UnitId] -> (UnitId, Maybe UnitId) -> MaybeErr UnitErr [UnitId])
-> [UnitId]
-> [(UnitId, Maybe UnitId)]
-> MaybeErr UnitErr [UnitId]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ((UnitId -> Maybe UnitId -> MaybeErr UnitErr [UnitId])
-> (UnitId, Maybe UnitId) -> MaybeErr UnitErr [UnitId]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((UnitId -> Maybe UnitId -> MaybeErr UnitErr [UnitId])
 -> (UnitId, Maybe UnitId) -> MaybeErr UnitErr [UnitId])
-> ([UnitId]
    -> UnitId -> Maybe UnitId -> MaybeErr UnitErr [UnitId])
-> [UnitId]
-> (UnitId, Maybe UnitId)
-> MaybeErr UnitErr [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitInfoMap
-> [UnitId] -> UnitId -> Maybe UnitId -> MaybeErr UnitErr [UnitId]
add_unit UnitInfoMap
pkg_map) [UnitId]
current_ids [(UnitId, Maybe UnitId)]
ps

-- | Add a UnitId and those it depends on (recursively) to the given list of
-- UnitIds if they are not already in it. Return a list in reverse dependency
-- order (a unit appears before those it depends on).
--
-- The UnitId is looked up in the given UnitInfoMap (to find its dependencies).
-- It it's not found, the optional parent unit is used to return a more precise
-- error message ("dependency of <PARENT>").
add_unit :: UnitInfoMap
            -> [UnitId]
            -> UnitId
            -> Maybe UnitId
            -> MaybeErr UnitErr [UnitId]
add_unit :: UnitInfoMap
-> [UnitId] -> UnitId -> Maybe UnitId -> MaybeErr UnitErr [UnitId]
add_unit UnitInfoMap
pkg_map [UnitId]
ps UnitId
p Maybe UnitId
mb_parent
  | UnitId
p UnitId -> [UnitId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnitId]
ps = [UnitId] -> MaybeErr UnitErr [UnitId]
forall a. a -> MaybeErr UnitErr a
forall (m :: * -> *) a. Monad m => a -> m a
return [UnitId]
ps     -- Check if we've already added this unit
  | Bool
otherwise   = case UnitInfoMap -> UnitId -> Maybe UnitInfo
lookupUnitId' UnitInfoMap
pkg_map UnitId
p of
      Maybe UnitInfo
Nothing   -> UnitErr -> MaybeErr UnitErr [UnitId]
forall err val. err -> MaybeErr err val
Failed (UnitId -> Maybe UnitId -> UnitErr
CloseUnitErr UnitId
p Maybe UnitId
mb_parent)
      Just UnitInfo
info -> do
         -- Add the unit's dependents also
         ps' <- ([UnitId] -> UnitId -> MaybeErr UnitErr [UnitId])
-> [UnitId] -> [UnitId] -> MaybeErr UnitErr [UnitId]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [UnitId] -> UnitId -> MaybeErr UnitErr [UnitId]
add_unit_key [UnitId]
ps (UnitInfo -> [UnitId]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends UnitInfo
info)
         return (p : ps')
        where
          add_unit_key :: [UnitId] -> UnitId -> MaybeErr UnitErr [UnitId]
add_unit_key [UnitId]
xs UnitId
key
            = UnitInfoMap
-> [UnitId] -> UnitId -> Maybe UnitId -> MaybeErr UnitErr [UnitId]
add_unit UnitInfoMap
pkg_map [UnitId]
xs UnitId
key (UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just UnitId
p)
data UnitErr
  = CloseUnitErr !UnitId !(Maybe UnitId)
  | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)]
  | TrustFlagErr   !TrustFlag   ![(UnitInfo,UnusableUnitReason)]

mayThrowUnitErr :: MaybeErr UnitErr a -> IO a
mayThrowUnitErr :: forall a. MaybeErr UnitErr a -> IO a
mayThrowUnitErr = \case
    Failed UnitErr
e    -> GhcException -> IO a
forall a. GhcException -> IO a
throwGhcExceptionIO
                    (GhcException -> IO a) -> GhcException -> IO a
forall a b. (a -> b) -> a -> b
$ String -> GhcException
String -> GhcException
CmdLineError
                    (String -> GhcException) -> String -> GhcException
forall a b. (a -> b) -> a -> b
$ SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext
                    (SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ PprStyle -> SDoc -> SDoc
withPprStyle PprStyle
defaultUserStyle
                    (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ UnitErr -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitErr
e
    Succeeded a
a -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

instance Outputable UnitErr where
    ppr :: UnitErr -> SDoc
ppr = \case
        CloseUnitErr UnitId
p Maybe UnitId
mb_parent
            -> (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"unknown unit:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> UnitId -> SDoc
forall a. Outputable a => a -> SDoc
ppr UnitId
p)
               SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> case Maybe UnitId
mb_parent of
                     Maybe UnitId
Nothing     -> SDoc
forall doc. IsOutput doc => doc
Outputable.empty
                     Just UnitId
parent -> SDoc
forall doc. IsLine doc => doc
space SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"dependency of"
                                              SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FastString -> SDoc
forall doc. IsLine doc => FastString -> doc
ftext (UnitId -> FastString
unitIdFS UnitId
parent))
        PackageFlagErr PackageFlag
flag [(UnitInfo, UnusableUnitReason)]
reasons
            -> SDoc -> [(UnitInfo, UnusableUnitReason)] -> SDoc
forall {a} {srcpkgid} {srcpkgname} {modulename} {mod}.
Outputable a =>
SDoc
-> [(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
     UnusableUnitReason)]
-> SDoc
flag_err (PackageFlag -> SDoc
pprFlag PackageFlag
flag) [(UnitInfo, UnusableUnitReason)]
reasons

        TrustFlagErr TrustFlag
flag [(UnitInfo, UnusableUnitReason)]
reasons
            -> SDoc -> [(UnitInfo, UnusableUnitReason)] -> SDoc
forall {a} {srcpkgid} {srcpkgname} {modulename} {mod}.
Outputable a =>
SDoc
-> [(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
     UnusableUnitReason)]
-> SDoc
flag_err (TrustFlag -> SDoc
pprTrustFlag TrustFlag
flag) [(UnitInfo, UnusableUnitReason)]
reasons
      where
        flag_err :: SDoc
-> [(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
     UnusableUnitReason)]
-> SDoc
flag_err SDoc
flag_doc [(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
  UnusableUnitReason)]
reasons =
            String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"cannot satisfy "
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
flag_doc
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> (if [(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
  UnusableUnitReason)]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
  UnusableUnitReason)]
reasons then SDoc
forall doc. IsOutput doc => doc
Outputable.empty else String -> SDoc
forall doc. IsLine doc => String -> doc
text String
": ")
            SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Int -> SDoc -> SDoc
nest Int
4 ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (((GenericUnitInfo srcpkgid srcpkgname a modulename mod,
  UnusableUnitReason)
 -> SDoc)
-> [(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
     UnusableUnitReason)]
-> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (GenericUnitInfo srcpkgid srcpkgname a modulename mod,
 UnusableUnitReason)
-> SDoc
forall {a} {srcpkgid} {srcpkgname} {modulename} {mod}.
Outputable a =>
(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
 UnusableUnitReason)
-> SDoc
ppr_reason [(GenericUnitInfo srcpkgid srcpkgname a modulename mod,
  UnusableUnitReason)]
reasons) SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
                      String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"(use -v for more information)")

        ppr_reason :: (GenericUnitInfo srcpkgid srcpkgname a modulename mod,
 UnusableUnitReason)
-> SDoc
ppr_reason (GenericUnitInfo srcpkgid srcpkgname a modulename mod
p, UnusableUnitReason
reason) =
            SDoc -> UnusableUnitReason -> SDoc
pprReason (a -> SDoc
forall a. Outputable a => a -> SDoc
ppr (GenericUnitInfo srcpkgid srcpkgname a modulename mod -> a
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId GenericUnitInfo srcpkgid srcpkgname a modulename mod
p) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"is") UnusableUnitReason
reason


pprFlag :: PackageFlag -> SDoc
pprFlag :: PackageFlag -> SDoc
pprFlag PackageFlag
flag = case PackageFlag
flag of
    HidePackage String
p   -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-hide-package " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
p
    ExposePackage String
doc PackageArg
_ ModRenaming
_ -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
doc

pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag TrustFlag
flag = case TrustFlag
flag of
    TrustPackage String
p    -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-trust " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
p
    DistrustPackage String
p -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"-distrust " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
p

-- ----------------------------------------------------------------------------
--
-- Utilities on the database
--

-- | A reverse dependency index, mapping an 'UnitId' to
-- the 'UnitId's which have a dependency on it.
type RevIndex = UniqMap UnitId [UnitId]

-- | Compute the reverse dependency index of a unit database.
reverseDeps :: UnitInfoMap -> RevIndex
reverseDeps :: UnitInfoMap -> RevIndex
reverseDeps UnitInfoMap
db = ((UnitId, UnitInfo) -> RevIndex -> RevIndex)
-> RevIndex -> UnitInfoMap -> RevIndex
forall k a b. ((k, a) -> b -> b) -> b -> UniqMap k a -> b
nonDetFoldUniqMap (UnitId, UnitInfo) -> RevIndex -> RevIndex
go RevIndex
forall k a. UniqMap k a
emptyUniqMap UnitInfoMap
db
  where
    go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex
    go :: (UnitId, UnitInfo) -> RevIndex -> RevIndex
go (UnitId
_uid, UnitInfo
pkg) RevIndex
r = (RevIndex -> UnitId -> RevIndex)
-> RevIndex -> [UnitId] -> RevIndex
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (UnitId -> RevIndex -> UnitId -> RevIndex
forall {k} {a}.
Uniquable k =>
a -> UniqMap k [a] -> k -> UniqMap k [a]
go' (UnitInfo -> UnitId
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> uid
unitId UnitInfo
pkg)) RevIndex
r (UnitInfo -> [UnitId]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends UnitInfo
pkg)
    go' :: a -> UniqMap k [a] -> k -> UniqMap k [a]
go' a
from UniqMap k [a]
r k
to = ([a] -> [a] -> [a]) -> UniqMap k [a] -> k -> [a] -> UniqMap k [a]
forall k a.
Uniquable k =>
(a -> a -> a) -> UniqMap k a -> k -> a -> UniqMap k a
addToUniqMap_C [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) UniqMap k [a]
r k
to [a
from]

-- | Given a list of 'UnitId's to remove, a database,
-- and a reverse dependency index (as computed by 'reverseDeps'),
-- remove those units, plus any units which depend on them.
-- Returns the pruned database, as well as a list of 'UnitInfo's
-- that was removed.
removeUnits :: [UnitId] -> RevIndex
               -> UnitInfoMap
               -> (UnitInfoMap, [UnitInfo])
removeUnits :: [UnitId] -> RevIndex -> UnitInfoMap -> (UnitInfoMap, [UnitInfo])
removeUnits [UnitId]
uids RevIndex
index UnitInfoMap
m = [UnitId] -> (UnitInfoMap, [UnitInfo]) -> (UnitInfoMap, [UnitInfo])
go [UnitId]
uids (UnitInfoMap
m,[])
  where
    go :: [UnitId] -> (UnitInfoMap, [UnitInfo]) -> (UnitInfoMap, [UnitInfo])
go [] (UnitInfoMap
m,[UnitInfo]
pkgs) = (UnitInfoMap
m,[UnitInfo]
pkgs)
    go (UnitId
uid:[UnitId]
uids) (UnitInfoMap
m,[UnitInfo]
pkgs)
        | Just UnitInfo
pkg <- UnitInfoMap -> UnitId -> Maybe UnitInfo
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UnitInfoMap
m UnitId
uid
        = case RevIndex -> UnitId -> Maybe [UnitId]
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap RevIndex
index UnitId
uid of
            Maybe [UnitId]
Nothing    -> [UnitId] -> (UnitInfoMap, [UnitInfo]) -> (UnitInfoMap, [UnitInfo])
go [UnitId]
uids (UnitInfoMap -> UnitId -> UnitInfoMap
forall k a. Uniquable k => UniqMap k a -> k -> UniqMap k a
delFromUniqMap UnitInfoMap
m UnitId
uid, UnitInfo
pkgUnitInfo -> [UnitInfo] -> [UnitInfo]
forall a. a -> [a] -> [a]
:[UnitInfo]
pkgs)
            Just [UnitId]
rdeps -> [UnitId] -> (UnitInfoMap, [UnitInfo]) -> (UnitInfoMap, [UnitInfo])
go ([UnitId]
rdeps [UnitId] -> [UnitId] -> [UnitId]
forall a. [a] -> [a] -> [a]
++ [UnitId]
uids) (UnitInfoMap -> UnitId -> UnitInfoMap
forall k a. Uniquable k => UniqMap k a -> k -> UniqMap k a
delFromUniqMap UnitInfoMap
m UnitId
uid, UnitInfo
pkgUnitInfo -> [UnitInfo] -> [UnitInfo]
forall a. a -> [a] -> [a]
:[UnitInfo]
pkgs)
        | Bool
otherwise
        = [UnitId] -> (UnitInfoMap, [UnitInfo]) -> (UnitInfoMap, [UnitInfo])
go [UnitId]
uids (UnitInfoMap
m,[UnitInfo]
pkgs)

-- | Given a 'UnitInfo' from some 'UnitInfoMap', return all entries in 'depends'
-- which correspond to units that do not exist in the index.
depsNotAvailable :: UnitInfoMap
                 -> UnitInfo
                 -> [UnitId]
depsNotAvailable :: UnitInfoMap -> UnitInfo -> [UnitId]
depsNotAvailable UnitInfoMap
pkg_map UnitInfo
pkg = (UnitId -> Bool) -> [UnitId] -> [UnitId]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (UnitId -> Bool) -> UnitId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId -> UnitInfoMap -> Bool
forall k a. Uniquable k => k -> UniqMap k a -> Bool
`elemUniqMap` UnitInfoMap
pkg_map)) (UnitInfo -> [UnitId]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> [uid]
unitDepends UnitInfo
pkg)

-- | Given a 'UnitInfo' from some 'UnitInfoMap' return all entries in
-- 'unitAbiDepends' which correspond to units that do not exist, OR have
-- mismatching ABIs.
depsAbiMismatch :: UnitInfoMap
                -> UnitInfo
                -> [UnitId]
depsAbiMismatch :: UnitInfoMap -> UnitInfo -> [UnitId]
depsAbiMismatch UnitInfoMap
pkg_map UnitInfo
pkg = ((UnitId, ShortText) -> UnitId)
-> [(UnitId, ShortText)] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId, ShortText) -> UnitId
forall a b. (a, b) -> a
fst ([(UnitId, ShortText)] -> [UnitId])
-> ([(UnitId, ShortText)] -> [(UnitId, ShortText)])
-> [(UnitId, ShortText)]
-> [UnitId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((UnitId, ShortText) -> Bool)
-> [(UnitId, ShortText)] -> [(UnitId, ShortText)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((UnitId, ShortText) -> Bool) -> (UnitId, ShortText) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitId, ShortText) -> Bool
abiMatch) ([(UnitId, ShortText)] -> [UnitId])
-> [(UnitId, ShortText)] -> [UnitId]
forall a b. (a -> b) -> a -> b
$ UnitInfo -> [(UnitId, ShortText)]
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod
-> [(uid, ShortText)]
unitAbiDepends UnitInfo
pkg
  where
    abiMatch :: (UnitId, ShortText) -> Bool
abiMatch (UnitId
dep_uid, ShortText
abi)
        | Just UnitInfo
dep_pkg <- UnitInfoMap -> UnitId -> Maybe UnitInfo
forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap UnitInfoMap
pkg_map UnitId
dep_uid
        = UnitInfo -> ShortText
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> ShortText
unitAbiHash UnitInfo
dep_pkg ShortText -> ShortText -> Bool
forall a. Eq a => a -> a -> Bool
== ShortText
abi
        | Bool
otherwise
        = Bool
False