{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Stack.BuildPlan
( BuildPlanException (..)
, BuildPlanCheck (..)
, checkSnapBuildPlan
, DepError(..)
, DepErrors
, removeSrcPkgDefaultFlags
, selectBestSnapshot
, showItems
) where
import Stack.Prelude hiding (Display (..))
import qualified Data.Foldable as F
import qualified Data.Set as Set
import Data.List (intercalate)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Distribution.Package as C
import Distribution.PackageDescription (GenericPackageDescription,
flagDefault, flagManual,
flagName, genPackageFlags)
import qualified Distribution.PackageDescription as C
import Distribution.System (Platform)
import Distribution.Text (display)
import Distribution.Types.UnqualComponentName (unUnqualComponentName)
import qualified Distribution.Version as C
import qualified RIO
import Stack.Constants
import Stack.Package
import Stack.SourceMap
import Stack.Types.SourceMap
import Stack.Types.Version
import Stack.Types.Config
import Stack.Types.Compiler
data BuildPlanException
= UnknownPackages
(Path Abs File)
(Map PackageName (Maybe Version, Set PackageName))
(Map PackageName (Set PackageIdentifier))
| SnapshotNotFound SnapName
| NeitherCompilerOrResolverSpecified T.Text
deriving (Typeable)
instance Exception BuildPlanException
instance Show BuildPlanException where
show :: BuildPlanException -> String
show (SnapshotNotFound SnapName
snapName) = [String] -> String
unlines
[ String
"SnapshotNotFound " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
snapName'
, String
"Non existing resolver: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
snapName' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
, String
"For a complete list of available snapshots see https://www.stackage.org/snapshots"
]
where snapName' :: String
snapName' = SnapName -> String
forall a. Show a => a -> String
show SnapName
snapName
show (UnknownPackages Path Abs File
stackYaml Map PackageName (Maybe Version, Set PackageName)
unknown Map PackageName (Set PackageIdentifier)
shadowed) =
[String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
unknown' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
shadowed'
where
unknown' :: [String]
unknown' :: [String]
unknown'
| Map PackageName (Maybe Version, Set PackageName) -> Bool
forall k a. Map k a -> Bool
Map.null Map PackageName (Maybe Version, Set PackageName)
unknown = []
| Bool
otherwise = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"The following packages do not exist in the build plan:"]
, ((PackageName, (Maybe Version, Set PackageName)) -> String)
-> [(PackageName, (Maybe Version, Set PackageName))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, (Maybe Version, Set PackageName)) -> String
forall a. (PackageName, (a, Set PackageName)) -> String
go (Map PackageName (Maybe Version, Set PackageName)
-> [(PackageName, (Maybe Version, Set PackageName))]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Maybe Version, Set PackageName)
unknown)
, case ((PackageName, (Maybe Version, Set PackageName)) -> Maybe String)
-> [(PackageName, (Maybe Version, Set PackageName))] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PackageName, (Maybe Version, Set PackageName)) -> Maybe String
forall b. (PackageName, (Maybe Version, b)) -> Maybe String
goRecommend ([(PackageName, (Maybe Version, Set PackageName))] -> [String])
-> [(PackageName, (Maybe Version, Set PackageName))] -> [String]
forall a b. (a -> b) -> a -> b
$ Map PackageName (Maybe Version, Set PackageName)
-> [(PackageName, (Maybe Version, Set PackageName))]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Maybe Version, Set PackageName)
unknown of
[] -> []
[String]
rec ->
(String
"Recommended action: modify the extra-deps field of " String -> ShowS
forall a. [a] -> [a] -> [a]
++
Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
stackYaml String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
" to include the following:")
String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ([String]
rec
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"Note: further dependencies may need to be added"])
, case ((PackageName, (Maybe Version, Set PackageName))
-> Maybe PackageName)
-> [(PackageName, (Maybe Version, Set PackageName))]
-> [PackageName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PackageName, (Maybe Version, Set PackageName))
-> Maybe PackageName
forall a a b. (a, (Maybe a, b)) -> Maybe a
getNoKnown ([(PackageName, (Maybe Version, Set PackageName))]
-> [PackageName])
-> [(PackageName, (Maybe Version, Set PackageName))]
-> [PackageName]
forall a b. (a -> b) -> a -> b
$ Map PackageName (Maybe Version, Set PackageName)
-> [(PackageName, (Maybe Version, Set PackageName))]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Maybe Version, Set PackageName)
unknown of
[] -> []
[PackageName]
noKnown ->
[ String
"There are no known versions of the following packages:"
, String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString [PackageName]
noKnown
]
]
where
go :: (PackageName, (a, Set PackageName)) -> String
go (PackageName
dep, (a
_, Set PackageName
users)) | Set PackageName -> Bool
forall a. Set a -> Bool
Set.null Set PackageName
users = PackageName -> String
packageNameString PackageName
dep
go (PackageName
dep, (a
_, Set PackageName
users)) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ PackageName -> String
packageNameString PackageName
dep
, String
" (used by "
, String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString ([PackageName] -> [String]) -> [PackageName] -> [String]
forall a b. (a -> b) -> a -> b
$ Set PackageName -> [PackageName]
forall a. Set a -> [a]
Set.toList Set PackageName
users
, String
")"
]
goRecommend :: (PackageName, (Maybe Version, b)) -> Maybe String
goRecommend (PackageName
name, (Just Version
version, b
_)) =
String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
packageIdentifierString (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version)
goRecommend (PackageName
_, (Maybe Version
Nothing, b
_)) = Maybe String
forall a. Maybe a
Nothing
getNoKnown :: (a, (Maybe a, b)) -> Maybe a
getNoKnown (a
name, (Maybe a
Nothing, b
_)) = a -> Maybe a
forall a. a -> Maybe a
Just a
name
getNoKnown (a
_, (Just a
_, b
_)) = Maybe a
forall a. Maybe a
Nothing
shadowed' :: [String]
shadowed' :: [String]
shadowed'
| Map PackageName (Set PackageIdentifier) -> Bool
forall k a. Map k a -> Bool
Map.null Map PackageName (Set PackageIdentifier)
shadowed = []
| Bool
otherwise = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"The following packages are shadowed by local packages:"]
, ((PackageName, Set PackageIdentifier) -> String)
-> [(PackageName, Set PackageIdentifier)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, Set PackageIdentifier) -> String
go (Map PackageName (Set PackageIdentifier)
-> [(PackageName, Set PackageIdentifier)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Set PackageIdentifier)
shadowed)
, [String
"Recommended action: modify the extra-deps field of " String -> ShowS
forall a. [a] -> [a] -> [a]
++
Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
stackYaml String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
" to include the following:"]
, [String]
extraDeps
, [String
"Note: further dependencies may need to be added"]
]
where
go :: (PackageName, Set PackageIdentifier) -> String
go (PackageName
dep, Set PackageIdentifier
users) | Set PackageIdentifier -> Bool
forall a. Set a -> Bool
Set.null Set PackageIdentifier
users = PackageName -> String
packageNameString PackageName
dep String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (internal stack error: this should never be null)"
go (PackageName
dep, Set PackageIdentifier
users) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ PackageName -> String
packageNameString PackageName
dep
, String
" (used by "
, String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", "
([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (PackageIdentifier -> String) -> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName -> String
packageNameString (PackageName -> String)
-> (PackageIdentifier -> PackageName)
-> PackageIdentifier
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName)
([PackageIdentifier] -> [String])
-> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> a -> b
$ Set PackageIdentifier -> [PackageIdentifier]
forall a. Set a -> [a]
Set.toList Set PackageIdentifier
users
, String
")"
]
extraDeps :: [String]
extraDeps = (PackageIdentifier -> String) -> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\PackageIdentifier
ident -> String
"- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident)
([PackageIdentifier] -> [String])
-> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> a -> b
$ Set PackageIdentifier -> [PackageIdentifier]
forall a. Set a -> [a]
Set.toList
(Set PackageIdentifier -> [PackageIdentifier])
-> Set PackageIdentifier -> [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ [Set PackageIdentifier] -> Set PackageIdentifier
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
([Set PackageIdentifier] -> Set PackageIdentifier)
-> [Set PackageIdentifier] -> Set PackageIdentifier
forall a b. (a -> b) -> a -> b
$ Map PackageName (Set PackageIdentifier) -> [Set PackageIdentifier]
forall k a. Map k a -> [a]
Map.elems Map PackageName (Set PackageIdentifier)
shadowed
show (NeitherCompilerOrResolverSpecified Text
url) =
String
"Failed to load custom snapshot at " String -> ShowS
forall a. [a] -> [a] -> [a]
++
Text -> String
T.unpack Text
url String -> ShowS
forall a. [a] -> [a] -> [a]
++
String
", because no 'compiler' or 'resolver' is specified."
gpdPackages :: [GenericPackageDescription] -> Map PackageName Version
gpdPackages :: [GenericPackageDescription] -> Map PackageName Version
gpdPackages = [(PackageName, Version)] -> Map PackageName Version
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageName, Version)] -> Map PackageName Version)
-> ([GenericPackageDescription] -> [(PackageName, Version)])
-> [GenericPackageDescription]
-> Map PackageName Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenericPackageDescription -> (PackageName, Version))
-> [GenericPackageDescription] -> [(PackageName, Version)]
forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier -> (PackageName, Version)
toPair (PackageIdentifier -> (PackageName, Version))
-> (GenericPackageDescription -> PackageIdentifier)
-> GenericPackageDescription
-> (PackageName, Version)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDescription -> PackageIdentifier
C.package (PackageDescription -> PackageIdentifier)
-> (GenericPackageDescription -> PackageDescription)
-> GenericPackageDescription
-> PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageDescription
C.packageDescription)
where
toPair :: PackageIdentifier -> (PackageName, Version)
toPair (C.PackageIdentifier PackageName
name Version
version) = (PackageName
name, Version
version)
gpdPackageDeps
:: GenericPackageDescription
-> ActualCompiler
-> Platform
-> Map FlagName Bool
-> Map PackageName VersionRange
gpdPackageDeps :: GenericPackageDescription
-> ActualCompiler
-> Platform
-> Map FlagName Bool
-> Map PackageName VersionRange
gpdPackageDeps GenericPackageDescription
gpd ActualCompiler
ac Platform
platform Map FlagName Bool
flags =
(PackageName -> VersionRange -> Bool)
-> Map PackageName VersionRange -> Map PackageName VersionRange
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (Bool -> VersionRange -> Bool
forall a b. a -> b -> a
const (Bool -> VersionRange -> Bool)
-> (PackageName -> Bool) -> PackageName -> VersionRange -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> (PackageName -> Bool) -> PackageName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> Bool
isLocalLibrary) (PackageConfig -> PackageDescription -> Map PackageName VersionRange
packageDependencies PackageConfig
pkgConfig PackageDescription
pkgDesc)
where
isLocalLibrary :: PackageName -> Bool
isLocalLibrary PackageName
name' = PackageName
name' PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
name Bool -> Bool -> Bool
|| PackageName
name' PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
subs
name :: PackageName
name = GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd
subs :: Set PackageName
subs = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList
([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> PackageName)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PackageName
C.mkPackageName (String -> PackageName)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> String)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> UnqualComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> UnqualComponentName
forall a b. (a, b) -> a
fst)
([(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> [PackageName])
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> [PackageName]
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
C.condSubLibraries GenericPackageDescription
gpd
pkgDesc :: PackageDescription
pkgDesc = PackageDescriptionPair -> PackageDescription
pdpModifiedBuildable (PackageDescriptionPair -> PackageDescription)
-> PackageDescriptionPair -> PackageDescription
forall a b. (a -> b) -> a -> b
$ PackageConfig
-> GenericPackageDescription -> PackageDescriptionPair
resolvePackageDescription PackageConfig
pkgConfig GenericPackageDescription
gpd
pkgConfig :: PackageConfig
pkgConfig = PackageConfig :: Bool
-> Bool
-> Map FlagName Bool
-> [Text]
-> [Text]
-> ActualCompiler
-> Platform
-> PackageConfig
PackageConfig
{ packageConfigEnableTests :: Bool
packageConfigEnableTests = Bool
True
, packageConfigEnableBenchmarks :: Bool
packageConfigEnableBenchmarks = Bool
True
, packageConfigFlags :: Map FlagName Bool
packageConfigFlags = Map FlagName Bool
flags
, packageConfigGhcOptions :: [Text]
packageConfigGhcOptions = []
, packageConfigCabalConfigOpts :: [Text]
packageConfigCabalConfigOpts = []
, packageConfigCompilerVersion :: ActualCompiler
packageConfigCompilerVersion = ActualCompiler
ac
, packageConfigPlatform :: Platform
packageConfigPlatform = Platform
platform
}
removeSrcPkgDefaultFlags :: [C.GenericPackageDescription]
-> Map PackageName (Map FlagName Bool)
-> Map PackageName (Map FlagName Bool)
removeSrcPkgDefaultFlags :: [GenericPackageDescription]
-> Map PackageName (Map FlagName Bool)
-> Map PackageName (Map FlagName Bool)
removeSrcPkgDefaultFlags [GenericPackageDescription]
gpds Map PackageName (Map FlagName Bool)
flags =
let defaults :: Map PackageName (Map FlagName Bool)
defaults = [Map PackageName (Map FlagName Bool)]
-> Map PackageName (Map FlagName Bool)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ((GenericPackageDescription -> Map PackageName (Map FlagName Bool))
-> [GenericPackageDescription]
-> [Map PackageName (Map FlagName Bool)]
forall a b. (a -> b) -> [a] -> [b]
map GenericPackageDescription -> Map PackageName (Map FlagName Bool)
gpdDefaultFlags [GenericPackageDescription]
gpds)
flags' :: Map PackageName (Map FlagName Bool)
flags' = (Map FlagName Bool
-> Map FlagName Bool -> Maybe (Map FlagName Bool))
-> Map PackageName (Map FlagName Bool)
-> Map PackageName (Map FlagName Bool)
-> Map PackageName (Map FlagName Bool)
forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith Map FlagName Bool -> Map FlagName Bool -> Maybe (Map FlagName Bool)
forall k a. (Ord k, Eq a) => Map k a -> Map k a -> Maybe (Map k a)
removeSame Map PackageName (Map FlagName Bool)
flags Map PackageName (Map FlagName Bool)
defaults
in (Map FlagName Bool -> Bool)
-> Map PackageName (Map FlagName Bool)
-> Map PackageName (Map FlagName Bool)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool)
-> (Map FlagName Bool -> Bool) -> Map FlagName Bool -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map FlagName Bool -> Bool
forall k a. Map k a -> Bool
Map.null) Map PackageName (Map FlagName Bool)
flags'
where
removeSame :: Map k a -> Map k a -> Maybe (Map k a)
removeSame Map k a
f1 Map k a
f2 =
let diff :: a -> a -> Maybe a
diff a
v a
v' = if a
v a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v' then Maybe a
forall a. Maybe a
Nothing else a -> Maybe a
forall a. a -> Maybe a
Just a
v
in Map k a -> Maybe (Map k a)
forall a. a -> Maybe a
Just (Map k a -> Maybe (Map k a)) -> Map k a -> Maybe (Map k a)
forall a b. (a -> b) -> a -> b
$ (a -> a -> Maybe a) -> Map k a -> Map k a -> Map k a
forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith a -> a -> Maybe a
forall a. Eq a => a -> a -> Maybe a
diff Map k a
f1 Map k a
f2
gpdDefaultFlags :: GenericPackageDescription -> Map PackageName (Map FlagName Bool)
gpdDefaultFlags GenericPackageDescription
gpd =
let tuples :: [(FlagName, Bool)]
tuples = (Flag -> (FlagName, Bool)) -> [Flag] -> [(FlagName, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map Flag -> (FlagName, Bool)
getDefault (GenericPackageDescription -> [Flag]
C.genPackageFlags GenericPackageDescription
gpd)
in PackageName
-> Map FlagName Bool -> Map PackageName (Map FlagName Bool)
forall k a. k -> a -> Map k a
Map.singleton (GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd) ([(FlagName, Bool)] -> Map FlagName Bool
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(FlagName, Bool)]
tuples)
getDefault :: Flag -> (FlagName, Bool)
getDefault Flag
f
| Flag -> Bool
C.flagDefault Flag
f = (Flag -> FlagName
C.flagName Flag
f, Bool
True)
| Bool
otherwise = (Flag -> FlagName
C.flagName Flag
f, Bool
False)
selectPackageBuildPlan
:: Platform
-> ActualCompiler
-> Map PackageName Version
-> GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors)
selectPackageBuildPlan :: Platform
-> ActualCompiler
-> Map PackageName Version
-> GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors)
selectPackageBuildPlan Platform
platform ActualCompiler
compiler Map PackageName Version
pool GenericPackageDescription
gpd =
(NonEmpty (Map PackageName (Map FlagName Bool), DepErrors)
-> (Map PackageName (Map FlagName Bool), DepErrors)
forall a. NonEmpty (a, DepErrors) -> (a, DepErrors)
selectPlan (NonEmpty (Map PackageName (Map FlagName Bool), DepErrors)
-> (Map PackageName (Map FlagName Bool), DepErrors))
-> (NonEmpty [(FlagName, Bool)]
-> NonEmpty (Map PackageName (Map FlagName Bool), DepErrors))
-> NonEmpty [(FlagName, Bool)]
-> (Map PackageName (Map FlagName Bool), DepErrors)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Map PackageName (Map FlagName Bool), DepErrors)
-> NonEmpty (Map PackageName (Map FlagName Bool), DepErrors)
forall a. NonEmpty a -> NonEmpty a
limitSearchSpace (NonEmpty (Map PackageName (Map FlagName Bool), DepErrors)
-> NonEmpty (Map PackageName (Map FlagName Bool), DepErrors))
-> (NonEmpty [(FlagName, Bool)]
-> NonEmpty (Map PackageName (Map FlagName Bool), DepErrors))
-> NonEmpty [(FlagName, Bool)]
-> NonEmpty (Map PackageName (Map FlagName Bool), DepErrors)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(FlagName, Bool)]
-> (Map PackageName (Map FlagName Bool), DepErrors))
-> NonEmpty [(FlagName, Bool)]
-> NonEmpty (Map PackageName (Map FlagName Bool), DepErrors)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map [(FlagName, Bool)]
-> (Map PackageName (Map FlagName Bool), DepErrors)
makePlan) NonEmpty [(FlagName, Bool)]
flagCombinations
where
selectPlan :: NonEmpty (a, DepErrors) -> (a, DepErrors)
selectPlan :: NonEmpty (a, DepErrors) -> (a, DepErrors)
selectPlan = ((a, DepErrors) -> (a, DepErrors) -> (a, DepErrors))
-> NonEmpty (a, DepErrors) -> (a, DepErrors)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
F.foldr1 (a, DepErrors) -> (a, DepErrors) -> (a, DepErrors)
forall a k a. (a, Map k a) -> (a, Map k a) -> (a, Map k a)
fewerErrors
where
fewerErrors :: (a, Map k a) -> (a, Map k a) -> (a, Map k a)
fewerErrors (a, Map k a)
p1 (a, Map k a)
p2
| (a, Map k a) -> Int
forall a k a. (a, Map k a) -> Int
nErrors (a, Map k a)
p1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = (a, Map k a)
p1
| (a, Map k a) -> Int
forall a k a. (a, Map k a) -> Int
nErrors (a, Map k a)
p1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= (a, Map k a) -> Int
forall a k a. (a, Map k a) -> Int
nErrors (a, Map k a)
p2 = (a, Map k a)
p1
| Bool
otherwise = (a, Map k a)
p2
where nErrors :: (a, Map k a) -> Int
nErrors = Map k a -> Int
forall k a. Map k a -> Int
Map.size (Map k a -> Int)
-> ((a, Map k a) -> Map k a) -> (a, Map k a) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Map k a) -> Map k a
forall a b. (a, b) -> b
snd
limitSearchSpace :: NonEmpty a -> NonEmpty a
limitSearchSpace :: NonEmpty a -> NonEmpty a
limitSearchSpace (a
x :| [a]
xs) = a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
maxFlagCombinations Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
xs
where maxFlagCombinations :: Int
maxFlagCombinations = Int
128
makePlan :: [(FlagName, Bool)] -> (Map PackageName (Map FlagName Bool), DepErrors)
makePlan :: [(FlagName, Bool)]
-> (Map PackageName (Map FlagName Bool), DepErrors)
makePlan [(FlagName, Bool)]
flags = Platform
-> ActualCompiler
-> Map PackageName Version
-> Map FlagName Bool
-> GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors)
checkPackageBuildPlan Platform
platform ActualCompiler
compiler Map PackageName Version
pool ([(FlagName, Bool)] -> Map FlagName Bool
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(FlagName, Bool)]
flags) GenericPackageDescription
gpd
flagCombinations :: NonEmpty [(FlagName, Bool)]
flagCombinations :: NonEmpty [(FlagName, Bool)]
flagCombinations = (Flag -> NonEmpty (FlagName, Bool))
-> [Flag] -> NonEmpty [(FlagName, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Flag -> NonEmpty (FlagName, Bool)
getOptions (GenericPackageDescription -> [Flag]
genPackageFlags GenericPackageDescription
gpd)
where
getOptions :: C.Flag -> NonEmpty (FlagName, Bool)
getOptions :: Flag -> NonEmpty (FlagName, Bool)
getOptions Flag
f
| Flag -> Bool
flagManual Flag
f = (FlagName
fname, Flag -> Bool
flagDefault Flag
f) (FlagName, Bool) -> [(FlagName, Bool)] -> NonEmpty (FlagName, Bool)
forall a. a -> [a] -> NonEmpty a
:| []
| Flag -> Bool
flagDefault Flag
f = (FlagName
fname, Bool
True) (FlagName, Bool) -> [(FlagName, Bool)] -> NonEmpty (FlagName, Bool)
forall a. a -> [a] -> NonEmpty a
:| [(FlagName
fname, Bool
False)]
| Bool
otherwise = (FlagName
fname, Bool
False) (FlagName, Bool) -> [(FlagName, Bool)] -> NonEmpty (FlagName, Bool)
forall a. a -> [a] -> NonEmpty a
:| [(FlagName
fname, Bool
True)]
where fname :: FlagName
fname = Flag -> FlagName
flagName Flag
f
checkPackageBuildPlan
:: Platform
-> ActualCompiler
-> Map PackageName Version
-> Map FlagName Bool
-> GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors)
checkPackageBuildPlan :: Platform
-> ActualCompiler
-> Map PackageName Version
-> Map FlagName Bool
-> GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors)
checkPackageBuildPlan Platform
platform ActualCompiler
compiler Map PackageName Version
pool Map FlagName Bool
flags GenericPackageDescription
gpd =
(PackageName
-> Map FlagName Bool -> Map PackageName (Map FlagName Bool)
forall k a. k -> a -> Map k a
Map.singleton PackageName
pkg Map FlagName Bool
flags, DepErrors
errs)
where
pkg :: PackageName
pkg = GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd
errs :: DepErrors
errs = PackageName
-> Map PackageName VersionRange
-> Map PackageName Version
-> DepErrors
checkPackageDeps PackageName
pkg Map PackageName VersionRange
constraints Map PackageName Version
pool
constraints :: Map PackageName VersionRange
constraints = GenericPackageDescription
-> ActualCompiler
-> Platform
-> Map FlagName Bool
-> Map PackageName VersionRange
gpdPackageDeps GenericPackageDescription
gpd ActualCompiler
compiler Platform
platform Map FlagName Bool
flags
checkPackageDeps
:: PackageName
-> Map PackageName VersionRange
-> Map PackageName Version
-> DepErrors
checkPackageDeps :: PackageName
-> Map PackageName VersionRange
-> Map PackageName Version
-> DepErrors
checkPackageDeps PackageName
myName Map PackageName VersionRange
deps Map PackageName Version
packages =
(DepError -> DepError -> DepError) -> [DepErrors] -> DepErrors
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith DepError -> DepError -> DepError
combineDepError ([DepErrors] -> DepErrors) -> [DepErrors] -> DepErrors
forall a b. (a -> b) -> a -> b
$ ((PackageName, VersionRange) -> DepErrors)
-> [(PackageName, VersionRange)] -> [DepErrors]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, VersionRange) -> DepErrors
go ([(PackageName, VersionRange)] -> [DepErrors])
-> [(PackageName, VersionRange)] -> [DepErrors]
forall a b. (a -> b) -> a -> b
$ Map PackageName VersionRange -> [(PackageName, VersionRange)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName VersionRange
deps
where
go :: (PackageName, VersionRange) -> DepErrors
go :: (PackageName, VersionRange) -> DepErrors
go (PackageName
name, VersionRange
range) =
case PackageName -> Map PackageName Version -> Maybe Version
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName Version
packages of
Maybe Version
Nothing -> PackageName -> DepError -> DepErrors
forall k a. k -> a -> Map k a
Map.singleton PackageName
name DepError :: Maybe Version -> Map PackageName VersionRange -> DepError
DepError
{ deVersion :: Maybe Version
deVersion = Maybe Version
forall a. Maybe a
Nothing
, deNeededBy :: Map PackageName VersionRange
deNeededBy = PackageName -> VersionRange -> Map PackageName VersionRange
forall k a. k -> a -> Map k a
Map.singleton PackageName
myName VersionRange
range
}
Just Version
v
| Version -> VersionRange -> Bool
withinRange Version
v VersionRange
range -> DepErrors
forall k a. Map k a
Map.empty
| Bool
otherwise -> PackageName -> DepError -> DepErrors
forall k a. k -> a -> Map k a
Map.singleton PackageName
name DepError :: Maybe Version -> Map PackageName VersionRange -> DepError
DepError
{ deVersion :: Maybe Version
deVersion = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v
, deNeededBy :: Map PackageName VersionRange
deNeededBy = PackageName -> VersionRange -> Map PackageName VersionRange
forall k a. k -> a -> Map k a
Map.singleton PackageName
myName VersionRange
range
}
type DepErrors = Map PackageName DepError
data DepError = DepError
{ DepError -> Maybe Version
deVersion :: !(Maybe Version)
, DepError -> Map PackageName VersionRange
deNeededBy :: !(Map PackageName VersionRange)
} deriving Int -> DepError -> ShowS
[DepError] -> ShowS
DepError -> String
(Int -> DepError -> ShowS)
-> (DepError -> String) -> ([DepError] -> ShowS) -> Show DepError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DepError] -> ShowS
$cshowList :: [DepError] -> ShowS
show :: DepError -> String
$cshow :: DepError -> String
showsPrec :: Int -> DepError -> ShowS
$cshowsPrec :: Int -> DepError -> ShowS
Show
combineDepError :: DepError -> DepError -> DepError
combineDepError :: DepError -> DepError -> DepError
combineDepError (DepError Maybe Version
a Map PackageName VersionRange
x) (DepError Maybe Version
b Map PackageName VersionRange
y) =
Bool -> DepError -> DepError
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Maybe Version
a Maybe Version -> Maybe Version -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Version
b) (DepError -> DepError) -> DepError -> DepError
forall a b. (a -> b) -> a -> b
$ Maybe Version -> Map PackageName VersionRange -> DepError
DepError Maybe Version
a ((VersionRange -> VersionRange -> VersionRange)
-> Map PackageName VersionRange
-> Map PackageName VersionRange
-> Map PackageName VersionRange
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith VersionRange -> VersionRange -> VersionRange
C.intersectVersionRanges Map PackageName VersionRange
x Map PackageName VersionRange
y)
checkBundleBuildPlan
:: Platform
-> ActualCompiler
-> Map PackageName Version
-> Maybe (Map PackageName (Map FlagName Bool))
-> [GenericPackageDescription]
-> (Map PackageName (Map FlagName Bool), DepErrors)
checkBundleBuildPlan :: Platform
-> ActualCompiler
-> Map PackageName Version
-> Maybe (Map PackageName (Map FlagName Bool))
-> [GenericPackageDescription]
-> (Map PackageName (Map FlagName Bool), DepErrors)
checkBundleBuildPlan Platform
platform ActualCompiler
compiler Map PackageName Version
pool Maybe (Map PackageName (Map FlagName Bool))
flags [GenericPackageDescription]
gpds =
((Map FlagName Bool -> Map FlagName Bool -> Map FlagName Bool)
-> [Map PackageName (Map FlagName Bool)]
-> Map PackageName (Map FlagName Bool)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Map FlagName Bool -> Map FlagName Bool -> Map FlagName Bool
forall p p a. p -> p -> a
dupError (((Map PackageName (Map FlagName Bool), DepErrors)
-> Map PackageName (Map FlagName Bool))
-> [(Map PackageName (Map FlagName Bool), DepErrors)]
-> [Map PackageName (Map FlagName Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (Map PackageName (Map FlagName Bool), DepErrors)
-> Map PackageName (Map FlagName Bool)
forall a b. (a, b) -> a
fst [(Map PackageName (Map FlagName Bool), DepErrors)]
plans)
, (DepError -> DepError -> DepError) -> [DepErrors] -> DepErrors
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith DepError -> DepError -> DepError
combineDepError (((Map PackageName (Map FlagName Bool), DepErrors) -> DepErrors)
-> [(Map PackageName (Map FlagName Bool), DepErrors)]
-> [DepErrors]
forall a b. (a -> b) -> [a] -> [b]
map (Map PackageName (Map FlagName Bool), DepErrors) -> DepErrors
forall a b. (a, b) -> b
snd [(Map PackageName (Map FlagName Bool), DepErrors)]
plans))
where
plans :: [(Map PackageName (Map FlagName Bool), DepErrors)]
plans = (GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors))
-> [GenericPackageDescription]
-> [(Map PackageName (Map FlagName Bool), DepErrors)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe (Map PackageName (Map FlagName Bool))
-> GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors)
pkgPlan Maybe (Map PackageName (Map FlagName Bool))
flags) [GenericPackageDescription]
gpds
pkgPlan :: Maybe (Map PackageName (Map FlagName Bool))
-> GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors)
pkgPlan Maybe (Map PackageName (Map FlagName Bool))
Nothing GenericPackageDescription
gpd =
Platform
-> ActualCompiler
-> Map PackageName Version
-> GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors)
selectPackageBuildPlan Platform
platform ActualCompiler
compiler Map PackageName Version
pool' GenericPackageDescription
gpd
pkgPlan (Just Map PackageName (Map FlagName Bool)
f) GenericPackageDescription
gpd =
Platform
-> ActualCompiler
-> Map PackageName Version
-> Map FlagName Bool
-> GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors)
checkPackageBuildPlan Platform
platform ActualCompiler
compiler Map PackageName Version
pool' (Map PackageName (Map FlagName Bool)
-> GenericPackageDescription -> Map FlagName Bool
forall k a.
Map PackageName (Map k a) -> GenericPackageDescription -> Map k a
flags' Map PackageName (Map FlagName Bool)
f GenericPackageDescription
gpd) GenericPackageDescription
gpd
flags' :: Map PackageName (Map k a) -> GenericPackageDescription -> Map k a
flags' Map PackageName (Map k a)
f GenericPackageDescription
gpd = Map k a -> Maybe (Map k a) -> Map k a
forall a. a -> Maybe a -> a
fromMaybe Map k a
forall k a. Map k a
Map.empty (PackageName -> Map PackageName (Map k a) -> Maybe (Map k a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd) Map PackageName (Map k a)
f)
pool' :: Map PackageName Version
pool' = Map PackageName Version
-> Map PackageName Version -> Map PackageName Version
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ([GenericPackageDescription] -> Map PackageName Version
gpdPackages [GenericPackageDescription]
gpds) Map PackageName Version
pool
dupError :: p -> p -> a
dupError p
_ p
_ = String -> a
forall a. (?callStack::CallStack) => String -> a
error String
"Bug: Duplicate packages are not expected here"
data BuildPlanCheck =
BuildPlanCheckOk (Map PackageName (Map FlagName Bool))
| BuildPlanCheckPartial (Map PackageName (Map FlagName Bool)) DepErrors
| BuildPlanCheckFail (Map PackageName (Map FlagName Bool)) DepErrors
ActualCompiler
compareBuildPlanCheck :: BuildPlanCheck -> BuildPlanCheck -> Ordering
compareBuildPlanCheck :: BuildPlanCheck -> BuildPlanCheck -> Ordering
compareBuildPlanCheck (BuildPlanCheckPartial Map PackageName (Map FlagName Bool)
_ DepErrors
e1) (BuildPlanCheckPartial Map PackageName (Map FlagName Bool)
_ DepErrors
e2) =
Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (DepErrors -> Int
forall k a. Map k a -> Int
Map.size DepErrors
e2) (DepErrors -> Int
forall k a. Map k a -> Int
Map.size DepErrors
e1)
compareBuildPlanCheck (BuildPlanCheckFail Map PackageName (Map FlagName Bool)
_ DepErrors
e1 ActualCompiler
_) (BuildPlanCheckFail Map PackageName (Map FlagName Bool)
_ DepErrors
e2 ActualCompiler
_) =
let numUserPkgs :: Map k DepError -> Int
numUserPkgs Map k DepError
e = Map PackageName VersionRange -> Int
forall k a. Map k a -> Int
Map.size (Map PackageName VersionRange -> Int)
-> Map PackageName VersionRange -> Int
forall a b. (a -> b) -> a -> b
$ [Map PackageName VersionRange] -> Map PackageName VersionRange
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (Map k (Map PackageName VersionRange)
-> [Map PackageName VersionRange]
forall k a. Map k a -> [a]
Map.elems ((DepError -> Map PackageName VersionRange)
-> Map k DepError -> Map k (Map PackageName VersionRange)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DepError -> Map PackageName VersionRange
deNeededBy Map k DepError
e))
in Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (DepErrors -> Int
forall k. Map k DepError -> Int
numUserPkgs DepErrors
e2) (DepErrors -> Int
forall k. Map k DepError -> Int
numUserPkgs DepErrors
e1)
compareBuildPlanCheck BuildPlanCheckOk{} BuildPlanCheckOk{} = Ordering
EQ
compareBuildPlanCheck BuildPlanCheckOk{} BuildPlanCheckPartial{} = Ordering
GT
compareBuildPlanCheck BuildPlanCheckOk{} BuildPlanCheckFail{} = Ordering
GT
compareBuildPlanCheck BuildPlanCheckPartial{} BuildPlanCheckFail{} = Ordering
GT
compareBuildPlanCheck BuildPlanCheck
_ BuildPlanCheck
_ = Ordering
LT
instance Show BuildPlanCheck where
show :: BuildPlanCheck -> String
show BuildPlanCheckOk {} = String
""
show (BuildPlanCheckPartial Map PackageName (Map FlagName Bool)
f DepErrors
e) = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Map PackageName (Map FlagName Bool) -> DepErrors -> Text
showDepErrors Map PackageName (Map FlagName Bool)
f DepErrors
e
show (BuildPlanCheckFail Map PackageName (Map FlagName Bool)
f DepErrors
e ActualCompiler
c) = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Map PackageName (Map FlagName Bool)
-> DepErrors -> ActualCompiler -> Text
showCompilerErrors Map PackageName (Map FlagName Bool)
f DepErrors
e ActualCompiler
c
checkSnapBuildPlan
:: (HasConfig env, HasGHCVariant env)
=> [ResolvedPath Dir]
-> Maybe (Map PackageName (Map FlagName Bool))
-> SnapshotCandidate env
-> RIO env BuildPlanCheck
checkSnapBuildPlan :: [ResolvedPath Dir]
-> Maybe (Map PackageName (Map FlagName Bool))
-> SnapshotCandidate env
-> RIO env BuildPlanCheck
checkSnapBuildPlan [ResolvedPath Dir]
pkgDirs Maybe (Map PackageName (Map FlagName Bool))
flags SnapshotCandidate env
snapCandidate = do
Platform
platform <- Getting Platform env Platform -> RIO env Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform env Platform
forall env. HasPlatform env => Lens' env Platform
platformL
SMActual GlobalPackageVersion
sma <- SnapshotCandidate env
snapCandidate [ResolvedPath Dir]
pkgDirs
[GenericPackageDescription]
gpds <- IO [GenericPackageDescription]
-> RIO env [GenericPackageDescription]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [GenericPackageDescription]
-> RIO env [GenericPackageDescription])
-> IO [GenericPackageDescription]
-> RIO env [GenericPackageDescription]
forall a b. (a -> b) -> a -> b
$ [ProjectPackage]
-> (ProjectPackage -> IO GenericPackageDescription)
-> IO [GenericPackageDescription]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map PackageName ProjectPackage -> [ProjectPackage]
forall k a. Map k a -> [a]
Map.elems (Map PackageName ProjectPackage -> [ProjectPackage])
-> Map PackageName ProjectPackage -> [ProjectPackage]
forall a b. (a -> b) -> a -> b
$ SMActual GlobalPackageVersion -> Map PackageName ProjectPackage
forall global. SMActual global -> Map PackageName ProjectPackage
smaProject SMActual GlobalPackageVersion
sma) (CommonPackage -> IO GenericPackageDescription
cpGPD (CommonPackage -> IO GenericPackageDescription)
-> (ProjectPackage -> CommonPackage)
-> ProjectPackage
-> IO GenericPackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon)
let
compiler :: ActualCompiler
compiler = SMActual GlobalPackageVersion -> ActualCompiler
forall global. SMActual global -> ActualCompiler
smaCompiler SMActual GlobalPackageVersion
sma
globalVersion :: GlobalPackageVersion -> Version
globalVersion (GlobalPackageVersion Version
v) = Version
v
depVersion :: DepPackage -> Maybe Version
depVersion DepPackage
dep | PLImmutable PackageLocationImmutable
loc <- DepPackage -> PackageLocation
dpLocation DepPackage
dep =
Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> Version
packageLocationVersion PackageLocationImmutable
loc
| Bool
otherwise =
Maybe Version
forall a. Maybe a
Nothing
snapPkgs :: Map PackageName Version
snapPkgs = Map PackageName Version
-> Map PackageName Version -> Map PackageName Version
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union
((DepPackage -> Maybe Version)
-> Map PackageName DepPackage -> Map PackageName Version
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe DepPackage -> Maybe Version
depVersion (Map PackageName DepPackage -> Map PackageName Version)
-> Map PackageName DepPackage -> Map PackageName Version
forall a b. (a -> b) -> a -> b
$ SMActual GlobalPackageVersion -> Map PackageName DepPackage
forall global. SMActual global -> Map PackageName DepPackage
smaDeps SMActual GlobalPackageVersion
sma)
((GlobalPackageVersion -> Version)
-> Map PackageName GlobalPackageVersion -> Map PackageName Version
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map GlobalPackageVersion -> Version
globalVersion (Map PackageName GlobalPackageVersion -> Map PackageName Version)
-> Map PackageName GlobalPackageVersion -> Map PackageName Version
forall a b. (a -> b) -> a -> b
$ SMActual GlobalPackageVersion
-> Map PackageName GlobalPackageVersion
forall global. SMActual global -> Map PackageName global
smaGlobal SMActual GlobalPackageVersion
sma)
(Map PackageName (Map FlagName Bool)
f, DepErrors
errs) = Platform
-> ActualCompiler
-> Map PackageName Version
-> Maybe (Map PackageName (Map FlagName Bool))
-> [GenericPackageDescription]
-> (Map PackageName (Map FlagName Bool), DepErrors)
checkBundleBuildPlan Platform
platform ActualCompiler
compiler Map PackageName Version
snapPkgs Maybe (Map PackageName (Map FlagName Bool))
flags [GenericPackageDescription]
gpds
cerrs :: DepErrors
cerrs = ActualCompiler -> DepErrors -> DepErrors
forall p. ActualCompiler -> Map PackageName p -> Map PackageName p
compilerErrors ActualCompiler
compiler DepErrors
errs
if DepErrors -> Bool
forall k a. Map k a -> Bool
Map.null DepErrors
errs then
BuildPlanCheck -> RIO env BuildPlanCheck
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildPlanCheck -> RIO env BuildPlanCheck)
-> BuildPlanCheck -> RIO env BuildPlanCheck
forall a b. (a -> b) -> a -> b
$ Map PackageName (Map FlagName Bool) -> BuildPlanCheck
BuildPlanCheckOk Map PackageName (Map FlagName Bool)
f
else if DepErrors -> Bool
forall k a. Map k a -> Bool
Map.null DepErrors
cerrs then do
BuildPlanCheck -> RIO env BuildPlanCheck
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildPlanCheck -> RIO env BuildPlanCheck)
-> BuildPlanCheck -> RIO env BuildPlanCheck
forall a b. (a -> b) -> a -> b
$ Map PackageName (Map FlagName Bool) -> DepErrors -> BuildPlanCheck
BuildPlanCheckPartial Map PackageName (Map FlagName Bool)
f DepErrors
errs
else
BuildPlanCheck -> RIO env BuildPlanCheck
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildPlanCheck -> RIO env BuildPlanCheck)
-> BuildPlanCheck -> RIO env BuildPlanCheck
forall a b. (a -> b) -> a -> b
$ Map PackageName (Map FlagName Bool)
-> DepErrors -> ActualCompiler -> BuildPlanCheck
BuildPlanCheckFail Map PackageName (Map FlagName Bool)
f DepErrors
cerrs ActualCompiler
compiler
where
compilerErrors :: ActualCompiler -> Map PackageName p -> Map PackageName p
compilerErrors ActualCompiler
compiler Map PackageName p
errs
| ActualCompiler -> WhichCompiler
whichCompiler ActualCompiler
compiler WhichCompiler -> WhichCompiler -> Bool
forall a. Eq a => a -> a -> Bool
== WhichCompiler
Ghc = Map PackageName p -> Map PackageName p
forall p. Map PackageName p -> Map PackageName p
ghcErrors Map PackageName p
errs
| Bool
otherwise = Map PackageName p
forall k a. Map k a
Map.empty
isGhcWiredIn :: PackageName -> p -> Bool
isGhcWiredIn PackageName
p p
_ = PackageName
p PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wiredInPackages
ghcErrors :: Map PackageName p -> Map PackageName p
ghcErrors = (PackageName -> p -> Bool)
-> Map PackageName p -> Map PackageName p
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey PackageName -> p -> Bool
forall p. PackageName -> p -> Bool
isGhcWiredIn
selectBestSnapshot
:: (HasConfig env, HasGHCVariant env)
=> [ResolvedPath Dir]
-> NonEmpty SnapName
-> RIO env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
selectBestSnapshot :: [ResolvedPath Dir]
-> NonEmpty SnapName
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
selectBestSnapshot [ResolvedPath Dir]
pkgDirs NonEmpty SnapName
snaps = do
Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"Selecting the best among "
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow (NonEmpty SnapName -> Int
forall a. NonEmpty a -> Int
NonEmpty.length NonEmpty SnapName
snaps)
Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" snapshots...\n"
(RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck))
-> NonEmpty
(RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck))
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
F.foldr1 RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
forall (m :: * -> *) a b.
Monad m =>
m (a, b, BuildPlanCheck)
-> m (a, b, BuildPlanCheck) -> m (a, b, BuildPlanCheck)
go ((SnapName
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck))
-> NonEmpty SnapName
-> NonEmpty
(RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (RawSnapshotLocation
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
getResult (RawSnapshotLocation
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck))
-> (SnapName -> RIO env RawSnapshotLocation)
-> SnapName
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< SnapName -> RIO env RawSnapshotLocation
forall env.
HasPantryConfig env =>
SnapName -> RIO env RawSnapshotLocation
snapshotLocation) NonEmpty SnapName
snaps)
where
go :: m (a, b, BuildPlanCheck)
-> m (a, b, BuildPlanCheck) -> m (a, b, BuildPlanCheck)
go m (a, b, BuildPlanCheck)
mold m (a, b, BuildPlanCheck)
mnew = do
old :: (a, b, BuildPlanCheck)
old@(a
_snap, b
_loc, BuildPlanCheck
bpc) <- m (a, b, BuildPlanCheck)
mold
case BuildPlanCheck
bpc of
BuildPlanCheckOk {} -> (a, b, BuildPlanCheck) -> m (a, b, BuildPlanCheck)
forall (m :: * -> *) a. Monad m => a -> m a
return (a, b, BuildPlanCheck)
old
BuildPlanCheck
_ -> ((a, b, BuildPlanCheck) -> (a, b, BuildPlanCheck))
-> m (a, b, BuildPlanCheck) -> m (a, b, BuildPlanCheck)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a, b, BuildPlanCheck)
-> (a, b, BuildPlanCheck) -> (a, b, BuildPlanCheck)
forall a b.
(a, b, BuildPlanCheck)
-> (a, b, BuildPlanCheck) -> (a, b, BuildPlanCheck)
betterSnap (a, b, BuildPlanCheck)
old) m (a, b, BuildPlanCheck)
mnew
getResult :: RawSnapshotLocation
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
getResult RawSnapshotLocation
loc = do
SnapshotCandidate env
candidate <- RawSnapshotLocation
-> PrintWarnings -> Bool -> RIO env (SnapshotCandidate env)
forall env.
HasConfig env =>
RawSnapshotLocation
-> PrintWarnings -> Bool -> RIO env (SnapshotCandidate env)
loadProjectSnapshotCandidate RawSnapshotLocation
loc PrintWarnings
NoPrintWarnings Bool
False
BuildPlanCheck
result <- [ResolvedPath Dir]
-> Maybe (Map PackageName (Map FlagName Bool))
-> SnapshotCandidate env
-> RIO env BuildPlanCheck
forall env.
(HasConfig env, HasGHCVariant env) =>
[ResolvedPath Dir]
-> Maybe (Map PackageName (Map FlagName Bool))
-> SnapshotCandidate env
-> RIO env BuildPlanCheck
checkSnapBuildPlan [ResolvedPath Dir]
pkgDirs Maybe (Map PackageName (Map FlagName Bool))
forall a. Maybe a
Nothing SnapshotCandidate env
candidate
BuildPlanCheck -> RawSnapshotLocation -> RIO env ()
forall env (m :: * -> *) a.
(MonadReader env m, Display a, MonadIO m, HasLogFunc env) =>
BuildPlanCheck -> a -> m ()
reportResult BuildPlanCheck
result RawSnapshotLocation
loc
(SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
forall (m :: * -> *) a. Monad m => a -> m a
return (SnapshotCandidate env
candidate, RawSnapshotLocation
loc, BuildPlanCheck
result)
betterSnap :: (a, b, BuildPlanCheck)
-> (a, b, BuildPlanCheck) -> (a, b, BuildPlanCheck)
betterSnap (a
s1, b
l1, BuildPlanCheck
r1) (a
s2, b
l2, BuildPlanCheck
r2)
| BuildPlanCheck -> BuildPlanCheck -> Ordering
compareBuildPlanCheck BuildPlanCheck
r1 BuildPlanCheck
r2 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT = (a
s1, b
l1, BuildPlanCheck
r1)
| Bool
otherwise = (a
s2, b
l2, BuildPlanCheck
r2)
reportResult :: BuildPlanCheck -> a -> m ()
reportResult BuildPlanCheckOk {} a
loc = do
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"* Matches " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.display a
loc
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logInfo Utf8Builder
""
reportResult r :: BuildPlanCheck
r@BuildPlanCheckPartial {} a
loc = do
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"* Partially matches " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.display a
loc
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.display (Text -> Utf8Builder) -> Text -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Text -> Text
indent (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ BuildPlanCheck -> String
forall a. Show a => a -> String
show BuildPlanCheck
r
reportResult r :: BuildPlanCheck
r@BuildPlanCheckFail {} a
loc = do
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Utf8Builder
"* Rejected " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> a -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.display a
loc
Utf8Builder -> m ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env,
?callStack::CallStack) =>
Utf8Builder -> m ()
logWarn (Utf8Builder -> m ()) -> Utf8Builder -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> Utf8Builder
forall a. Display a => a -> Utf8Builder
RIO.display (Text -> Utf8Builder) -> Text -> Utf8Builder
forall a b. (a -> b) -> a -> b
$ Text -> Text
indent (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ BuildPlanCheck -> String
forall a. Show a => a -> String
show BuildPlanCheck
r
indent :: Text -> Text
indent Text
t = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> [Text]
T.lines Text
t)
showItems :: [String] -> Text
showItems :: [String] -> Text
showItems [String]
items = [Text] -> Text
T.concat ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
formatItem [String]
items)
where
formatItem :: String -> Text
formatItem String
item = [Text] -> Text
T.concat
[ Text
" - "
, String -> Text
T.pack String
item
, Text
"\n"
]
showPackageFlags :: PackageName -> Map FlagName Bool -> Text
showPackageFlags :: PackageName -> Map FlagName Bool -> Text
showPackageFlags PackageName
pkg Map FlagName Bool
fl =
if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map FlagName Bool -> Bool
forall k a. Map k a -> Bool
Map.null Map FlagName Bool
fl then
[Text] -> Text
T.concat
[ Text
" - "
, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
pkg
, Text
": "
, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", "
([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((FlagName, Bool) -> String) -> [(FlagName, Bool)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (FlagName, Bool) -> String
forall a a. (Show a, Show a) => (a, a) -> String
formatFlags (Map FlagName Bool -> [(FlagName, Bool)]
forall k a. Map k a -> [(k, a)]
Map.toList Map FlagName Bool
fl)
, Text
"\n"
]
else Text
""
where
formatFlags :: (a, a) -> String
formatFlags (a
f, a
v) = a -> String
forall a. Show a => a -> String
show a
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v
showMapPackages :: Map PackageName a -> Text
showMapPackages :: Map PackageName a -> Text
showMapPackages Map PackageName a
mp = [String] -> Text
showItems ([String] -> Text) -> [String] -> Text
forall a b. (a -> b) -> a -> b
$ (PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString ([PackageName] -> [String]) -> [PackageName] -> [String]
forall a b. (a -> b) -> a -> b
$ Map PackageName a -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName a
mp
showCompilerErrors
:: Map PackageName (Map FlagName Bool)
-> DepErrors
-> ActualCompiler
-> Text
showCompilerErrors :: Map PackageName (Map FlagName Bool)
-> DepErrors -> ActualCompiler -> Text
showCompilerErrors Map PackageName (Map FlagName Bool)
flags DepErrors
errs ActualCompiler
compiler =
[Text] -> Text
T.concat
[ ActualCompiler -> Text
compilerVersionText ActualCompiler
compiler
, Text
" cannot be used for these packages:\n"
, Map PackageName VersionRange -> Text
forall a. Map PackageName a -> Text
showMapPackages (Map PackageName VersionRange -> Text)
-> Map PackageName VersionRange -> Text
forall a b. (a -> b) -> a -> b
$ [Map PackageName VersionRange] -> Map PackageName VersionRange
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (Map PackageName (Map PackageName VersionRange)
-> [Map PackageName VersionRange]
forall k a. Map k a -> [a]
Map.elems ((DepError -> Map PackageName VersionRange)
-> DepErrors -> Map PackageName (Map PackageName VersionRange)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DepError -> Map PackageName VersionRange
deNeededBy DepErrors
errs))
, Map PackageName (Map FlagName Bool) -> DepErrors -> Text
showDepErrors Map PackageName (Map FlagName Bool)
flags DepErrors
errs
]
showDepErrors :: Map PackageName (Map FlagName Bool) -> DepErrors -> Text
showDepErrors :: Map PackageName (Map FlagName Bool) -> DepErrors -> Text
showDepErrors Map PackageName (Map FlagName Bool)
flags DepErrors
errs =
[Text] -> Text
T.concat
[ [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((PackageName, DepError) -> Text)
-> [(PackageName, DepError)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, DepError) -> Text
formatError (DepErrors -> [(PackageName, DepError)]
forall k a. Map k a -> [(k, a)]
Map.toList DepErrors
errs)
, if Text -> Bool
T.null Text
flagVals then Text
""
else Text
"Using package flags:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
flagVals
]
where
formatError :: (PackageName, DepError) -> Text
formatError (PackageName
depName, DepError Maybe Version
mversion Map PackageName VersionRange
neededBy) = [Text] -> Text
T.concat
[ PackageName -> Maybe Version -> Text
showDepVersion PackageName
depName Maybe Version
mversion
, [Text] -> Text
T.concat (((PackageName, VersionRange) -> Text)
-> [(PackageName, VersionRange)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, VersionRange) -> Text
forall a. Pretty a => (PackageName, a) -> Text
showRequirement (Map PackageName VersionRange -> [(PackageName, VersionRange)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName VersionRange
neededBy))
]
showDepVersion :: PackageName -> Maybe Version -> Text
showDepVersion PackageName
depName Maybe Version
mversion = [Text] -> Text
T.concat
[ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
depName
, case Maybe Version
mversion of
Maybe Version
Nothing -> Text
" not found"
Just Version
version -> [Text] -> Text
T.concat
[ Text
" version "
, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Version -> String
versionString Version
version
, Text
" found"
]
, Text
"\n"
]
showRequirement :: (PackageName, a) -> Text
showRequirement (PackageName
user, a
range) = [Text] -> Text
T.concat
[ Text
" - "
, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
user
, Text
" requires "
, String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Pretty a => a -> String
display a
range
, Text
"\n"
]
flagVals :: Text
flagVals = [Text] -> Text
T.concat ((PackageName -> Text) -> [PackageName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> Text
showFlags [PackageName]
userPkgs)
userPkgs :: [PackageName]
userPkgs = Map PackageName VersionRange -> [PackageName]
forall k a. Map k a -> [k]
Map.keys (Map PackageName VersionRange -> [PackageName])
-> Map PackageName VersionRange -> [PackageName]
forall a b. (a -> b) -> a -> b
$ [Map PackageName VersionRange] -> Map PackageName VersionRange
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (Map PackageName (Map PackageName VersionRange)
-> [Map PackageName VersionRange]
forall k a. Map k a -> [a]
Map.elems ((DepError -> Map PackageName VersionRange)
-> DepErrors -> Map PackageName (Map PackageName VersionRange)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DepError -> Map PackageName VersionRange
deNeededBy DepErrors
errs))
showFlags :: PackageName -> Text
showFlags PackageName
pkg = Text
-> (Map FlagName Bool -> Text) -> Maybe (Map FlagName Bool) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (PackageName -> Map FlagName Bool -> Text
showPackageFlags PackageName
pkg) (PackageName
-> Map PackageName (Map FlagName Bool) -> Maybe (Map FlagName Bool)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkg Map PackageName (Map FlagName Bool)
flags)