{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE ConstraintKinds     #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Resolving a build plan for a set of packages in a given Stackage

-- snapshot.


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

-- | Type representing exceptions thrown by functions exported by the

-- "Stack.BuildPlan" module.

data BuildPlanException
    = UnknownPackages
        (Path Abs File) -- stack.yaml file

        (Map PackageName (Maybe Version, Set PackageName)) -- truly unknown

        (Map PackageName (Set PackageIdentifier)) -- shadowed

    | 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

        -- Since tests and benchmarks are both enabled, doesn't matter

        -- if we choose modified or unmodified

        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
            }

-- Remove any src package flags having default values

-- Remove any package entries with no flags set

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)

-- | Find the set of @FlagName@s necessary to get the given

-- @GenericPackageDescription@ to compile against the given @BuildPlan@. Will

-- only modify non-manual flags, and will prefer default values for flags.

-- Returns the plan which produces least number of dep errors

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

    -- Avoid exponential complexity in flag combinations making us sad pandas.

    -- See: https://github.com/commercialhaskell/stack/issues/543

    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

-- | Check whether with the given set of flags a package's dependency

-- constraints can be satisfied against a given build plan or pool of packages.

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

-- | Checks if the given package dependencies can be satisfied by the given set

-- of packages. Will fail if a package is either missing or has a version

-- outside of the version range.

checkPackageDeps
    :: PackageName -- ^ package using dependencies, for constructing DepErrors

    -> Map PackageName VersionRange -- ^ dependency constraints

    -> Map PackageName Version -- ^ Available package pool or index

    -> 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

-- | Combine two 'DepError's for the same 'Version'.

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)

-- | Given a bundle of packages (a list of @GenericPackageDescriptions@'s) to

-- build and an available package pool (snapshot) check whether the bundle's

-- dependencies can be satisfied. If flags is passed as Nothing flag settings

-- will be chosen automatically.

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

-- | Compare 'BuildPlanCheck', where GT means a better plan.

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) =
    -- Note: order of comparison flipped, since it's better to have fewer errors.

    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

-- | Check a set of 'GenericPackageDescription's and a set of flags against a

-- given snapshot. Returns how well the snapshot satisfies the dependencies of

-- the packages.

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

-- | Find a snapshot and set of flags that is compatible with and matches as

-- best as possible with the given 'GenericPackageDescription's.

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 -- TODO only in debug mode

        ]

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)