{-# 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 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
| DuplicatePackagesBug
deriving (Int -> BuildPlanException -> ShowS
[BuildPlanException] -> ShowS
BuildPlanException -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BuildPlanException] -> ShowS
$cshowList :: [BuildPlanException] -> ShowS
show :: BuildPlanException -> String
$cshow :: BuildPlanException -> String
showsPrec :: Int -> BuildPlanException -> ShowS
$cshowsPrec :: Int -> BuildPlanException -> ShowS
Show, Typeable)
instance Exception BuildPlanException where
displayException :: BuildPlanException -> String
displayException (SnapshotNotFound SnapName
snapName) = [String] -> String
unlines
[ String
"Error: [S-2045]"
, String
"SnapshotNotFound " forall a. [a] -> [a] -> [a]
++ String
snapName'
, String
"Non existing resolver: " forall a. [a] -> [a] -> [a]
++ String
snapName' forall a. [a] -> [a] -> [a]
++ String
"."
, String
"For a complete list of available snapshots see https://www.stackage.org/snapshots"
]
where snapName' :: String
snapName' = forall a. Show a => a -> String
show SnapName
snapName
displayException (UnknownPackages Path Abs File
stackYaml Map PackageName (Maybe Version, Set PackageName)
unknown Map PackageName (Set PackageIdentifier)
shadowed) =
String
"Error: [S-7571]\n"
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ([String]
unknown' forall a. [a] -> [a] -> [a]
++ [String]
shadowed')
where
unknown' :: [String]
unknown' :: [String]
unknown'
| forall k a. Map k a -> Bool
Map.null Map PackageName (Maybe Version, Set PackageName)
unknown = []
| Bool
otherwise = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"The following packages do not exist in the build plan:"]
, forall a b. (a -> b) -> [a] -> [b]
map forall {a}. (PackageName, (a, Set PackageName)) -> String
go (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Maybe Version, Set PackageName)
unknown)
, case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {b}. (PackageName, (Maybe Version, b)) -> Maybe String
goRecommend forall a b. (a -> b) -> a -> b
$ 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 " forall a. [a] -> [a] -> [a]
++
forall b t. Path b t -> String
toFilePath Path Abs File
stackYaml forall a. [a] -> [a] -> [a]
++
String
" to include the following:")
forall a. a -> [a] -> [a]
: ([String]
rec
forall a. [a] -> [a] -> [a]
++ [String
"Note: further dependencies may need to be added"])
, case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a} {a} {b}. (a, (Maybe a, b)) -> Maybe a
getNoKnown forall a b. (a -> b) -> a -> b
$ 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:"
, forall a. [a] -> [[a]] -> [a]
intercalate String
", " forall a b. (a -> b) -> a -> b
$ 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)) | forall a. Set a -> Bool
Set.null Set PackageName
users = PackageName -> String
packageNameString PackageName
dep
go (PackageName
dep, (a
_, Set PackageName
users)) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ PackageName -> String
packageNameString PackageName
dep
, String
" (used by "
, forall a. [a] -> [[a]] -> [a]
intercalate String
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString forall a b. (a -> b) -> a -> b
$ 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
_)) =
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ String
"- " forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
packageIdentifierString (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version)
goRecommend (PackageName
_, (Maybe Version
Nothing, b
_)) = forall a. Maybe a
Nothing
getNoKnown :: (a, (Maybe a, b)) -> Maybe a
getNoKnown (a
name, (Maybe a
Nothing, b
_)) = forall a. a -> Maybe a
Just a
name
getNoKnown (a
_, (Just a
_, b
_)) = forall a. Maybe a
Nothing
shadowed' :: [String]
shadowed' :: [String]
shadowed'
| forall k a. Map k a -> Bool
Map.null Map PackageName (Set PackageIdentifier)
shadowed = []
| Bool
otherwise = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [String
"The following packages are shadowed by local packages:"]
, forall a b. (a -> b) -> [a] -> [b]
map (PackageName, Set PackageIdentifier) -> String
go (forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Set PackageIdentifier)
shadowed)
, [String
"Recommended action: modify the extra-deps field of " forall a. [a] -> [a] -> [a]
++
forall b t. Path b t -> String
toFilePath Path Abs File
stackYaml 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) | forall a. Set a -> Bool
Set.null Set PackageIdentifier
users = PackageName -> String
packageNameString PackageName
dep forall a. [a] -> [a] -> [a]
++ String
" (internal Stack error: this should never be null)"
go (PackageName
dep, Set PackageIdentifier
users) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ PackageName -> String
packageNameString PackageName
dep
, String
" (used by "
, forall a. [a] -> [[a]] -> [a]
intercalate String
", "
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (PackageName -> String
packageNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName)
forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set PackageIdentifier
users
, String
")"
]
extraDeps :: [String]
extraDeps = forall a b. (a -> b) -> [a] -> [b]
map (\PackageIdentifier
ident -> String
"- " forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident)
forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList
forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [a]
Map.elems Map PackageName (Set PackageIdentifier)
shadowed
displayException (NeitherCompilerOrResolverSpecified Text
url) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ String
"Error: [S-8559]\n"
, String
"Failed to load custom snapshot at "
, Text -> String
T.unpack Text
url
, String
", because no 'compiler' or 'resolver' is specified."
]
displayException BuildPlanException
DuplicatePackagesBug = String -> ShowS
bugReport String
"[S-5743]"
String
"Duplicate packages are not expected here."
gpdPackages :: [GenericPackageDescription] -> Map PackageName Version
gpdPackages :: [GenericPackageDescription] -> Map PackageName Version
gpdPackages = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier -> (PackageName, Version)
toPair forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDescription -> PackageIdentifier
C.package 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 =
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not 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' forall a. Eq a => a -> a -> Bool
== PackageName
name Bool -> Bool -> Bool
|| PackageName
name' 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 = forall a. Ord a => [a] -> Set a
Set.fromList
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (String -> PackageName
C.mkPackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> String
unUnqualComponentName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
C.condSubLibraries GenericPackageDescription
gpd
pkgDesc :: PackageDescription
pkgDesc = PackageDescriptionPair -> PackageDescription
pdpModifiedBuildable forall a b. (a -> b) -> a -> b
$ PackageConfig
-> GenericPackageDescription -> PackageDescriptionPair
resolvePackageDescription PackageConfig
pkgConfig GenericPackageDescription
gpd
pkgConfig :: PackageConfig
pkgConfig = 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 = forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (forall a b. (a -> b) -> [a] -> [b]
map GenericPackageDescription -> Map PackageName (Map FlagName Bool)
gpdDefaultFlags [GenericPackageDescription]
gpds)
flags' :: Map PackageName (Map FlagName Bool)
flags' = forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith forall {k} {b}.
(Ord k, Eq b) =>
Map k b -> Map k b -> Maybe (Map k b)
removeSame Map PackageName (Map FlagName Bool)
flags Map PackageName (Map FlagName Bool)
defaults
in forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> Bool
Map.null) Map PackageName (Map FlagName Bool)
flags'
where
removeSame :: Map k b -> Map k b -> Maybe (Map k b)
removeSame Map k b
f1 Map k b
f2 =
let diff :: a -> a -> Maybe a
diff a
v a
v' = if a
v forall a. Eq a => a -> a -> Bool
== a
v' then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just a
v
in forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith forall {a}. Eq a => a -> a -> Maybe a
diff Map k b
f1 Map k b
f2
gpdDefaultFlags :: GenericPackageDescription -> Map PackageName (Map FlagName Bool)
gpdDefaultFlags GenericPackageDescription
gpd =
let tuples :: [(FlagName, Bool)]
tuples = forall a b. (a -> b) -> [a] -> [b]
map PackageFlag -> (FlagName, Bool)
getDefault (GenericPackageDescription -> [PackageFlag]
C.genPackageFlags GenericPackageDescription
gpd)
in forall k a. k -> a -> Map k a
Map.singleton (GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd) (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(FlagName, Bool)]
tuples)
getDefault :: PackageFlag -> (FlagName, Bool)
getDefault PackageFlag
f
| PackageFlag -> Bool
C.flagDefault PackageFlag
f = (PackageFlag -> FlagName
C.flagName PackageFlag
f, Bool
True)
| Bool
otherwise = (PackageFlag -> FlagName
C.flagName PackageFlag
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 =
(forall a. NonEmpty (a, DepErrors) -> (a, DepErrors)
selectPlan forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> NonEmpty a
limitSearchSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. NonEmpty (a, DepErrors) -> (a, DepErrors)
selectPlan = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
F.foldr1 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
| forall {a} {k} {a}. (a, Map k a) -> Int
nErrors (a, Map k a)
p1 forall a. Eq a => a -> a -> Bool
== Int
0 = (a, Map k a)
p1
| forall {a} {k} {a}. (a, Map k a) -> Int
nErrors (a, Map k a)
p1 forall a. Ord a => a -> a -> Bool
<= 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 = forall k a. Map k a -> Int
Map.size forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
limitSearchSpace :: NonEmpty a -> NonEmpty a
limitSearchSpace :: forall a. NonEmpty a -> NonEmpty a
limitSearchSpace (a
x :| [a]
xs) = a
x forall a. a -> [a] -> NonEmpty a
:| forall a. Int -> [a] -> [a]
take (Int
maxFlagCombinations 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 (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 = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PackageFlag -> NonEmpty (FlagName, Bool)
getOptions (GenericPackageDescription -> [PackageFlag]
genPackageFlags GenericPackageDescription
gpd)
where
getOptions :: C.PackageFlag -> NonEmpty (FlagName, Bool)
getOptions :: PackageFlag -> NonEmpty (FlagName, Bool)
getOptions PackageFlag
f
| PackageFlag -> Bool
flagManual PackageFlag
f = (FlagName
fname, PackageFlag -> Bool
flagDefault PackageFlag
f) forall a. a -> [a] -> NonEmpty a
:| []
| PackageFlag -> Bool
flagDefault PackageFlag
f = (FlagName
fname, Bool
True) forall a. a -> [a] -> NonEmpty a
:| [(FlagName
fname, Bool
False)]
| Bool
otherwise = (FlagName
fname, Bool
False) forall a. a -> [a] -> NonEmpty a
:| [(FlagName
fname, Bool
True)]
where fname :: FlagName
fname = PackageFlag -> FlagName
flagName PackageFlag
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 =
(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 =
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith DepError -> DepError -> DepError
combineDepError forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (PackageName, VersionRange) -> DepErrors
go forall a b. (a -> b) -> a -> b
$ 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 forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName Version
packages of
Maybe Version
Nothing -> forall k a. k -> a -> Map k a
Map.singleton PackageName
name DepError
{ deVersion :: Maybe Version
deVersion = forall a. Maybe a
Nothing
, deNeededBy :: Map PackageName VersionRange
deNeededBy = 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 -> forall k a. Map k a
Map.empty
| Bool
otherwise -> forall k a. k -> a -> Map k a
Map.singleton PackageName
name DepError
{ deVersion :: Maybe Version
deVersion = forall a. a -> Maybe a
Just Version
v
, deNeededBy :: Map PackageName VersionRange
deNeededBy = 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
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) =
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Maybe Version
a forall a. Eq a => a -> a -> Bool
== Maybe Version
b) forall a b. (a -> b) -> a -> b
$ Maybe Version -> Map PackageName VersionRange -> DepError
DepError Maybe Version
a (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 =
(forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith forall {p} {p} {a}. p -> p -> a
dupError (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Map PackageName (Map FlagName Bool), DepErrors)]
plans)
, forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith DepError -> DepError -> DepError
combineDepError (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Map PackageName (Map FlagName Bool), DepErrors)]
plans))
where
plans :: [(Map PackageName (Map FlagName Bool), DepErrors)]
plans = 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' (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 = forall a. a -> Maybe a -> a
fromMaybe forall k a. Map k a
Map.empty (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' = 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
_ = forall e a. Exception e => e -> a
impureThrow BuildPlanException
DuplicatePackagesBug
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) =
forall a. Ord a => a -> a -> Ordering
compare (forall k a. Map k a -> Int
Map.size DepErrors
e2) (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 = forall k a. Map k a -> Int
Map.size forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (forall k a. Map k a -> [a]
Map.elems (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DepError -> Map PackageName VersionRange
deNeededBy Map k DepError
e))
in forall a. Ord a => a -> a -> Ordering
compare (forall {k}. Map k DepError -> Int
numUserPkgs DepErrors
e2) (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 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 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 :: 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))
flags SnapshotCandidate env
snapCandidate = do
Platform
platform <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasPlatform env => Lens' env Platform
platformL
SMActual GlobalPackageVersion
sma <- SnapshotCandidate env
snapCandidate [ResolvedPath Dir]
pkgDirs
[GenericPackageDescription]
gpds <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ forall global. SMActual global -> Map PackageName ProjectPackage
smaProject SMActual GlobalPackageVersion
sma) (CommonPackage -> IO GenericPackageDescription
cpGPD forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon)
let
compiler :: ActualCompiler
compiler = 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 =
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> Version
packageLocationVersion PackageLocationImmutable
loc
| Bool
otherwise =
forall a. Maybe a
Nothing
snapPkgs :: Map PackageName Version
snapPkgs = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union
(forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe DepPackage -> Maybe Version
depVersion forall a b. (a -> b) -> a -> b
$ forall global. SMActual global -> Map PackageName DepPackage
smaDeps SMActual GlobalPackageVersion
sma)
(forall a b k. (a -> b) -> Map k a -> Map k b
Map.map GlobalPackageVersion -> Version
globalVersion forall a b. (a -> b) -> a -> b
$ 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 = forall {a}.
ActualCompiler -> Map PackageName a -> Map PackageName a
compilerErrors ActualCompiler
compiler DepErrors
errs
if forall k a. Map k a -> Bool
Map.null DepErrors
errs then
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Map PackageName (Map FlagName Bool) -> BuildPlanCheck
BuildPlanCheckOk Map PackageName (Map FlagName Bool)
f
else if forall k a. Map k a -> Bool
Map.null DepErrors
cerrs then do
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Map PackageName (Map FlagName Bool) -> DepErrors -> BuildPlanCheck
BuildPlanCheckPartial Map PackageName (Map FlagName Bool)
f DepErrors
errs
else
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 a -> Map PackageName a
compilerErrors ActualCompiler
compiler Map PackageName a
errs
| ActualCompiler -> WhichCompiler
whichCompiler ActualCompiler
compiler forall a. Eq a => a -> a -> Bool
== WhichCompiler
Ghc = forall {a}. Map PackageName a -> Map PackageName a
ghcErrors Map PackageName a
errs
| Bool
otherwise = forall k a. Map k a
Map.empty
isGhcWiredIn :: PackageName -> p -> Bool
isGhcWiredIn PackageName
p p
_ = PackageName
p forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wiredInPackages
ghcErrors :: Map PackageName a -> Map PackageName a
ghcErrors = forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey forall {p}. PackageName -> p -> Bool
isGhcWiredIn
selectBestSnapshot
:: (HasConfig env, HasGHCVariant env)
=> [ResolvedPath Dir]
-> NonEmpty SnapName
-> RIO env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
selectBestSnapshot :: forall env.
(HasConfig env, HasGHCVariant env) =>
[ResolvedPath Dir]
-> NonEmpty SnapName
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
selectBestSnapshot [ResolvedPath Dir]
pkgDirs NonEmpty SnapName
snaps = do
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyInfo forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Selecting the best among"
, forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (forall a. NonEmpty a -> Int
NonEmpty.length NonEmpty SnapName
snaps)
, StyleDoc
"snapshots..."
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
F.foldr1 forall {m :: * -> *} {a} {b}.
Monad m =>
m (a, b, BuildPlanCheck)
-> m (a, b, BuildPlanCheck) -> m (a, b, BuildPlanCheck)
go (forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (RawSnapshotLocation
-> RIO
env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
getResult forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< 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 {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (a, b, BuildPlanCheck)
old
BuildPlanCheck
_ -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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 <- forall env.
HasConfig env =>
RawSnapshotLocation
-> PrintWarnings -> Bool -> RIO env (SnapshotCandidate env)
loadProjectSnapshotCandidate RawSnapshotLocation
loc PrintWarnings
NoPrintWarnings Bool
False
BuildPlanCheck
result <- forall env.
(HasConfig env, HasGHCVariant env) =>
[ResolvedPath Dir]
-> Maybe (Map PackageName (Map FlagName Bool))
-> SnapshotCandidate env
-> RIO env BuildPlanCheck
checkSnapBuildPlan [ResolvedPath Dir]
pkgDirs forall a. Maybe a
Nothing SnapshotCandidate env
candidate
forall {env} {m :: * -> *}.
(MonadReader env m, HasTerm env, MonadIO m) =>
BuildPlanCheck -> RawSnapshotLocation -> m ()
reportResult BuildPlanCheck
result RawSnapshotLocation
loc
forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 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 -> RawSnapshotLocation -> m ()
reportResult BuildPlanCheckOk {} RawSnapshotLocation
loc =
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyNote forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Matches"
, forall a. Pretty a => a -> StyleDoc
pretty forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> PrettyRawSnapshotLocation
PrettyRawSnapshotLocation RawSnapshotLocation
loc
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
reportResult r :: BuildPlanCheck
r@BuildPlanCheckPartial {} RawSnapshotLocation
loc =
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Partially matches"
, forall a. Pretty a => a -> StyleDoc
pretty forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> PrettyRawSnapshotLocation
PrettyRawSnapshotLocation RawSnapshotLocation
loc
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4 (String -> StyleDoc
string (forall a. Show a => a -> String
show BuildPlanCheck
r))
reportResult r :: BuildPlanCheck
r@BuildPlanCheckFail {} RawSnapshotLocation
loc =
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
MonadIO m) =>
StyleDoc -> m ()
prettyWarn forall a b. (a -> b) -> a -> b
$
[StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Rejected"
, forall a. Pretty a => a -> StyleDoc
pretty forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> PrettyRawSnapshotLocation
PrettyRawSnapshotLocation RawSnapshotLocation
loc
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4 (String -> StyleDoc
string (forall a. Show a => a -> String
show BuildPlanCheck
r))
showItems :: [String] -> Text
showItems :: [String] -> Text
showItems [String]
items = [Text] -> Text
T.concat (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 forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> Bool
Map.null Map FlagName Bool
fl then
[Text] -> Text
T.concat
[ Text
" - "
, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
pkg
, Text
": "
, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
", "
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. (Show a, Show a) => (a, a) -> String
formatFlags (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) = forall a. Show a => a -> String
show a
f forall a. [a] -> [a] -> [a]
++ String
" = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
v
showMapPackages :: Map PackageName a -> Text
showMapPackages :: forall a. Map PackageName a -> Text
showMapPackages Map PackageName a
mp = [String] -> Text
showItems forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString forall a b. (a -> b) -> a -> b
$ 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"
, forall a. Map PackageName a -> Text
showMapPackages forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (forall k a. Map k a -> [a]
Map.elems (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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (PackageName, DepError) -> Text
formatError (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" 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 (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Pretty a => (PackageName, a) -> Text
showRequirement (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 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 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 forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
user
, Text
" requires "
, String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> String
display a
range
, Text
"\n"
]
flagVals :: Text
flagVals = [Text] -> Text
T.concat (forall a b. (a -> b) -> [a] -> [b]
map PackageName -> Text
showFlags [PackageName]
userPkgs)
userPkgs :: [PackageName]
userPkgs = forall k a. Map k a -> [k]
Map.keys forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (forall k a. Map k a -> [a]
Map.elems (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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (PackageName -> Map FlagName Bool -> Text
showPackageFlags PackageName
pkg) (forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkg Map PackageName (Map FlagName Bool)
flags)