{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE OverloadedStrings   #-}

-- | 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 qualified Data.Foldable as F
import           Data.List (intercalate)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Distribution.Package as C
import           Distribution.PackageDescription
                   ( GenericPackageDescription, flagDefault, flagName
                   , flagManual, 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 ( wiredInPackages )
import           Stack.Package
                   ( PackageConfig (..), packageDependencies
                   , pdpModifiedBuildable, resolvePackageDescription
                   )
import           Stack.Prelude hiding ( Display (..) )
import           Stack.SourceMap
                   ( SnapshotCandidate, loadProjectSnapshotCandidate )
import           Stack.Types.Compiler
                   ( ActualCompiler, WhichCompiler (..), compilerVersionText
                   , whichCompiler
                   )
import           Stack.Types.Config ( HasConfig )
import           Stack.Types.GHCVariant ( HasGHCVariant )
import           Stack.Types.Platform ( HasPlatform (..) )
import           Stack.Types.SourceMap
                   ( CommonPackage (..), DepPackage (..)
                   , GlobalPackageVersion (..), ProjectPackage (..)
                   , SMActual (..)
                   )
import           Stack.Types.Version ( VersionRange, withinRange )

-- | 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
(Int -> BuildPlanException -> ShowS)
-> (BuildPlanException -> String)
-> ([BuildPlanException] -> ShowS)
-> Show BuildPlanException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BuildPlanException -> ShowS
showsPrec :: Int -> BuildPlanException -> ShowS
$cshow :: BuildPlanException -> String
show :: BuildPlanException -> String
$cshowList :: [BuildPlanException] -> ShowS
showList :: [BuildPlanException] -> ShowS
Show, Typeable)

instance Exception BuildPlanException where
    displayException :: BuildPlanException -> String
displayException (SnapshotNotFound SnapName
snapName) = [String] -> String
unlines
        [ String
"Error: [S-2045]"
        , String
"SnapshotNotFound " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
snapName'
        , String
"Non existing resolver: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
snapName' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"."
        , String
"For a complete list of available snapshots see https://www.stackage.org/snapshots"
        ]
      where
        snapName' :: String
snapName' = SnapName -> String
forall a. Show a => a -> String
show SnapName
snapName
    displayException (UnknownPackages Path Abs File
stackYaml Map PackageName (Maybe Version, Set PackageName)
unknown Map PackageName (Set PackageIdentifier)
shadowed) =
        String
"Error: [S-7571]\n"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ([String]
unknown' [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
shadowed')
      where
        unknown' :: [String]
        unknown' :: [String]
unknown'
            | Map PackageName (Maybe Version, Set PackageName) -> Bool
forall k a. Map k a -> Bool
Map.null Map PackageName (Maybe Version, Set PackageName)
unknown = []
            | Bool
otherwise = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ [String
"The following packages do not exist in the build plan:"]
                , ((PackageName, (Maybe Version, Set PackageName)) -> String)
-> [(PackageName, (Maybe Version, Set PackageName))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, (Maybe Version, Set PackageName)) -> String
forall {a}. (PackageName, (a, Set PackageName)) -> String
go (Map PackageName (Maybe Version, Set PackageName)
-> [(PackageName, (Maybe Version, Set PackageName))]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Maybe Version, Set PackageName)
unknown)
                , case ((PackageName, (Maybe Version, Set PackageName)) -> Maybe String)
-> [(PackageName, (Maybe Version, Set PackageName))] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PackageName, (Maybe Version, Set PackageName)) -> Maybe String
forall {b}. (PackageName, (Maybe Version, b)) -> Maybe String
goRecommend ([(PackageName, (Maybe Version, Set PackageName))] -> [String])
-> [(PackageName, (Maybe Version, Set PackageName))] -> [String]
forall a b. (a -> b) -> a -> b
$ Map PackageName (Maybe Version, Set PackageName)
-> [(PackageName, (Maybe Version, Set PackageName))]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Maybe Version, Set PackageName)
unknown of
                    [] -> []
                    [String]
rec ->
                        (String
"Recommended action: modify the extra-deps field of " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                        Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
stackYaml String -> ShowS
forall a. [a] -> [a] -> [a]
++
                        String
" to include the following:")
                        String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ([String]
rec
                        [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"Note: further dependencies may need to be added"])
                , case ((PackageName, (Maybe Version, Set PackageName))
 -> Maybe PackageName)
-> [(PackageName, (Maybe Version, Set PackageName))]
-> [PackageName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (PackageName, (Maybe Version, Set PackageName))
-> Maybe PackageName
forall {a} {a} {b}. (a, (Maybe a, b)) -> Maybe a
getNoKnown ([(PackageName, (Maybe Version, Set PackageName))]
 -> [PackageName])
-> [(PackageName, (Maybe Version, Set PackageName))]
-> [PackageName]
forall a b. (a -> b) -> a -> b
$ Map PackageName (Maybe Version, Set PackageName)
-> [(PackageName, (Maybe Version, Set PackageName))]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Maybe Version, Set PackageName)
unknown of
                    [] -> []
                    [PackageName]
noKnown ->
                        [ String
"There are no known versions of the following packages:"
                        , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString [PackageName]
noKnown
                        ]
                ]
          where
            go :: (PackageName, (a, Set PackageName)) -> String
go (PackageName
dep, (a
_, Set PackageName
users)) | Set PackageName -> Bool
forall a. Set a -> Bool
Set.null Set PackageName
users = PackageName -> String
packageNameString PackageName
dep
            go (PackageName
dep, (a
_, Set PackageName
users)) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ PackageName -> String
packageNameString PackageName
dep
                , String
" (used by "
                , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString ([PackageName] -> [String]) -> [PackageName] -> [String]
forall a b. (a -> b) -> a -> b
$ Set PackageName -> [PackageName]
forall a. Set a -> [a]
Set.toList Set PackageName
users
                , String
")"
                ]

            goRecommend :: (PackageName, (Maybe Version, b)) -> Maybe String
goRecommend (PackageName
name, (Just Version
version, b
_)) =
                String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
packageIdentifierString (PackageName -> Version -> PackageIdentifier
PackageIdentifier PackageName
name Version
version)
            goRecommend (PackageName
_, (Maybe Version
Nothing, b
_)) = Maybe String
forall a. Maybe a
Nothing

            getNoKnown :: (a, (Maybe a, b)) -> Maybe a
getNoKnown (a
name, (Maybe a
Nothing, b
_)) = a -> Maybe a
forall a. a -> Maybe a
Just a
name
            getNoKnown (a
_, (Just a
_, b
_)) = Maybe a
forall a. Maybe a
Nothing

        shadowed' :: [String]
        shadowed' :: [String]
shadowed'
            | Map PackageName (Set PackageIdentifier) -> Bool
forall k a. Map k a -> Bool
Map.null Map PackageName (Set PackageIdentifier)
shadowed = []
            | Bool
otherwise = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ [String
"The following packages are shadowed by local packages:"]
                , ((PackageName, Set PackageIdentifier) -> String)
-> [(PackageName, Set PackageIdentifier)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, Set PackageIdentifier) -> String
go (Map PackageName (Set PackageIdentifier)
-> [(PackageName, Set PackageIdentifier)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName (Set PackageIdentifier)
shadowed)
                , [String
"Recommended action: modify the extra-deps field of " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                   Path Abs File -> String
forall b t. Path b t -> String
toFilePath Path Abs File
stackYaml String -> ShowS
forall a. [a] -> [a] -> [a]
++
                   String
" to include the following:"]
                , [String]
extraDeps
                , [String
"Note: further dependencies may need to be added"]
                ]
          where
            go :: (PackageName, Set PackageIdentifier) -> String
go (PackageName
dep, Set PackageIdentifier
users) | Set PackageIdentifier -> Bool
forall a. Set a -> Bool
Set.null Set PackageIdentifier
users = PackageName -> String
packageNameString PackageName
dep String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (internal Stack error: this should never be null)"
            go (PackageName
dep, Set PackageIdentifier
users) = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                [ PackageName -> String
packageNameString PackageName
dep
                , String
" (used by "
                , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", "
                    ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (PackageIdentifier -> String) -> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName -> String
packageNameString (PackageName -> String)
-> (PackageIdentifier -> PackageName)
-> PackageIdentifier
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
pkgName)
                    ([PackageIdentifier] -> [String])
-> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> a -> b
$ Set PackageIdentifier -> [PackageIdentifier]
forall a. Set a -> [a]
Set.toList Set PackageIdentifier
users
                , String
")"
                ]

            extraDeps :: [String]
extraDeps = (PackageIdentifier -> String) -> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\PackageIdentifier
ident -> String
"- " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> String
packageIdentifierString PackageIdentifier
ident)
                      ([PackageIdentifier] -> [String])
-> [PackageIdentifier] -> [String]
forall a b. (a -> b) -> a -> b
$ Set PackageIdentifier -> [PackageIdentifier]
forall a. Set a -> [a]
Set.toList
                      (Set PackageIdentifier -> [PackageIdentifier])
-> Set PackageIdentifier -> [PackageIdentifier]
forall a b. (a -> b) -> a -> b
$ [Set PackageIdentifier] -> Set PackageIdentifier
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions
                      ([Set PackageIdentifier] -> Set PackageIdentifier)
-> [Set PackageIdentifier] -> Set PackageIdentifier
forall a b. (a -> b) -> a -> b
$ Map PackageName (Set PackageIdentifier) -> [Set PackageIdentifier]
forall k a. Map k a -> [a]
Map.elems Map PackageName (Set PackageIdentifier)
shadowed
    displayException (NeitherCompilerOrResolverSpecified Text
url) = [String] -> String
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 = [(PackageName, Version)] -> Map PackageName Version
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PackageName, Version)] -> Map PackageName Version)
-> ([GenericPackageDescription] -> [(PackageName, Version)])
-> [GenericPackageDescription]
-> Map PackageName Version
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenericPackageDescription -> (PackageName, Version))
-> [GenericPackageDescription] -> [(PackageName, Version)]
forall a b. (a -> b) -> [a] -> [b]
map (PackageIdentifier -> (PackageName, Version)
toPair (PackageIdentifier -> (PackageName, Version))
-> (GenericPackageDescription -> PackageIdentifier)
-> GenericPackageDescription
-> (PackageName, Version)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDescription -> PackageIdentifier
C.package (PackageDescription -> PackageIdentifier)
-> (GenericPackageDescription -> PackageDescription)
-> GenericPackageDescription
-> PackageIdentifier
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenericPackageDescription -> PackageDescription
C.packageDescription)
    where
        toPair :: PackageIdentifier -> (PackageName, Version)
toPair (C.PackageIdentifier PackageName
name Version
version) = (PackageName
name, Version
version)

gpdPackageDeps ::
       GenericPackageDescription
    -> ActualCompiler
    -> Platform
    -> Map FlagName Bool
    -> Map PackageName VersionRange
gpdPackageDeps :: GenericPackageDescription
-> ActualCompiler
-> Platform
-> Map FlagName Bool
-> Map PackageName VersionRange
gpdPackageDeps GenericPackageDescription
gpd ActualCompiler
ac Platform
platform Map FlagName Bool
flags =
    (PackageName -> VersionRange -> Bool)
-> Map PackageName VersionRange -> Map PackageName VersionRange
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey (Bool -> VersionRange -> Bool
forall a b. a -> b -> a
const (Bool -> VersionRange -> Bool)
-> (PackageName -> Bool) -> PackageName -> VersionRange -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> Bool) -> (PackageName -> Bool) -> PackageName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> Bool
isLocalLibrary) (PackageDescription -> Map PackageName VersionRange
packageDependencies PackageDescription
pkgDesc)
    where
        isLocalLibrary :: PackageName -> Bool
isLocalLibrary PackageName
name' = PackageName
name' PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
== PackageName
name Bool -> Bool -> Bool
|| PackageName
name' PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
subs

        name :: PackageName
name = GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd
        subs :: Set PackageName
subs = [PackageName] -> Set PackageName
forall a. Ord a => [a] -> Set a
Set.fromList
             ([PackageName] -> Set PackageName)
-> [PackageName] -> Set PackageName
forall a b. (a -> b) -> a -> b
$ ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
 -> PackageName)
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> PackageName
C.mkPackageName (String -> PackageName)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
    -> String)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String)
-> ((UnqualComponentName, CondTree ConfVar [Dependency] Library)
    -> UnqualComponentName)
-> (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnqualComponentName, CondTree ConfVar [Dependency] Library)
-> UnqualComponentName
forall a b. (a, b) -> a
fst)
             ([(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
 -> [PackageName])
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
-> [PackageName]
forall a b. (a -> b) -> a -> b
$ GenericPackageDescription
-> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)]
C.condSubLibraries GenericPackageDescription
gpd

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

        -- if we choose modified or unmodified

        pkgDesc :: PackageDescription
pkgDesc = PackageDescriptionPair -> PackageDescription
pdpModifiedBuildable (PackageDescriptionPair -> PackageDescription)
-> PackageDescriptionPair -> PackageDescription
forall a b. (a -> b) -> a -> b
$ PackageConfig
-> GenericPackageDescription -> PackageDescriptionPair
resolvePackageDescription PackageConfig
pkgConfig GenericPackageDescription
gpd
        pkgConfig :: PackageConfig
pkgConfig = PackageConfig
            { 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 = [Map PackageName (Map FlagName Bool)]
-> Map PackageName (Map FlagName Bool)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ((GenericPackageDescription -> Map PackageName (Map FlagName Bool))
-> [GenericPackageDescription]
-> [Map PackageName (Map FlagName Bool)]
forall a b. (a -> b) -> [a] -> [b]
map GenericPackageDescription -> Map PackageName (Map FlagName Bool)
gpdDefaultFlags [GenericPackageDescription]
gpds)
        flags' :: Map PackageName (Map FlagName Bool)
flags'   = (Map FlagName Bool
 -> Map FlagName Bool -> Maybe (Map FlagName Bool))
-> Map PackageName (Map FlagName Bool)
-> Map PackageName (Map FlagName Bool)
-> Map PackageName (Map FlagName Bool)
forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith Map FlagName Bool -> Map FlagName Bool -> Maybe (Map FlagName Bool)
forall {k} {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  (Map FlagName Bool -> Bool)
-> Map PackageName (Map FlagName Bool)
-> Map PackageName (Map FlagName Bool)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool)
-> (Map FlagName Bool -> Bool) -> Map FlagName Bool -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map FlagName Bool -> Bool
forall k a. Map k a -> Bool
Map.null) Map PackageName (Map FlagName Bool)
flags'
    where
        removeSame :: Map k 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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v' then Maybe a
forall a. Maybe a
Nothing else a -> Maybe a
forall a. a -> Maybe a
Just a
v
            in  Map k b -> Maybe (Map k b)
forall a. a -> Maybe a
Just (Map k b -> Maybe (Map k b)) -> Map k b -> Maybe (Map k b)
forall a b. (a -> b) -> a -> b
$ (b -> b -> Maybe b) -> Map k b -> Map k b -> Map k b
forall k a b.
Ord k =>
(a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a
Map.differenceWith b -> b -> Maybe b
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 = (PackageFlag -> (FlagName, Bool))
-> [PackageFlag] -> [(FlagName, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map PackageFlag -> (FlagName, Bool)
getDefault (GenericPackageDescription -> [PackageFlag]
C.genPackageFlags GenericPackageDescription
gpd)
            in  PackageName
-> Map FlagName Bool -> Map PackageName (Map FlagName Bool)
forall k a. k -> a -> Map k a
Map.singleton (GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd) ([(FlagName, Bool)] -> Map FlagName Bool
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(FlagName, Bool)]
tuples)

        getDefault :: 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 =
    (NonEmpty (Map PackageName (Map FlagName Bool), DepErrors)
-> (Map PackageName (Map FlagName Bool), DepErrors)
forall a. NonEmpty (a, DepErrors) -> (a, DepErrors)
selectPlan (NonEmpty (Map PackageName (Map FlagName Bool), DepErrors)
 -> (Map PackageName (Map FlagName Bool), DepErrors))
-> (NonEmpty [(FlagName, Bool)]
    -> NonEmpty (Map PackageName (Map FlagName Bool), DepErrors))
-> NonEmpty [(FlagName, Bool)]
-> (Map PackageName (Map FlagName Bool), DepErrors)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Map PackageName (Map FlagName Bool), DepErrors)
-> NonEmpty (Map PackageName (Map FlagName Bool), DepErrors)
forall a. NonEmpty a -> NonEmpty a
limitSearchSpace (NonEmpty (Map PackageName (Map FlagName Bool), DepErrors)
 -> NonEmpty (Map PackageName (Map FlagName Bool), DepErrors))
-> (NonEmpty [(FlagName, Bool)]
    -> NonEmpty (Map PackageName (Map FlagName Bool), DepErrors))
-> NonEmpty [(FlagName, Bool)]
-> NonEmpty (Map PackageName (Map FlagName Bool), DepErrors)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([(FlagName, Bool)]
 -> (Map PackageName (Map FlagName Bool), DepErrors))
-> NonEmpty [(FlagName, Bool)]
-> NonEmpty (Map PackageName (Map FlagName Bool), DepErrors)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map [(FlagName, Bool)]
-> (Map PackageName (Map FlagName Bool), DepErrors)
makePlan) NonEmpty [(FlagName, Bool)]
flagCombinations
  where
    selectPlan :: NonEmpty (a, DepErrors) -> (a, DepErrors)
    selectPlan :: forall a. NonEmpty (a, DepErrors) -> (a, DepErrors)
selectPlan = ((a, DepErrors) -> (a, DepErrors) -> (a, DepErrors))
-> NonEmpty (a, DepErrors) -> (a, DepErrors)
forall a. (a -> a -> a) -> NonEmpty a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
F.foldr1 (a, DepErrors) -> (a, DepErrors) -> (a, DepErrors)
forall {a} {k} {a}. (a, Map k a) -> (a, Map k a) -> (a, Map k a)
fewerErrors
      where
        fewerErrors :: (a, Map k a) -> (a, Map k a) -> (a, Map k a)
fewerErrors (a, Map k a)
p1 (a, Map k a)
p2
            | (a, Map k a) -> Int
forall {a} {k} {a}. (a, Map k a) -> Int
nErrors (a, Map k a)
p1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = (a, Map k a)
p1
            | (a, Map k a) -> Int
forall {a} {k} {a}. (a, Map k a) -> Int
nErrors (a, Map k a)
p1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= (a, Map k a) -> Int
forall {a} {k} {a}. (a, Map k a) -> Int
nErrors (a, Map k a)
p2 = (a, Map k a)
p1
            | Bool
otherwise = (a, Map k a)
p2
          where
            nErrors :: (a, Map k a) -> Int
nErrors = Map k a -> Int
forall k a. Map k a -> Int
Map.size (Map k a -> Int)
-> ((a, Map k a) -> Map k a) -> (a, Map k a) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Map k a) -> Map k a
forall a b. (a, b) -> b
snd

    -- 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 a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take (Int
maxFlagCombinations Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
xs
     where
      maxFlagCombinations :: Int
maxFlagCombinations = Int
128

    makePlan :: [(FlagName, Bool)] -> (Map PackageName (Map FlagName Bool), DepErrors)
    makePlan :: [(FlagName, Bool)]
-> (Map PackageName (Map FlagName Bool), DepErrors)
makePlan [(FlagName, Bool)]
flags = Platform
-> ActualCompiler
-> Map PackageName Version
-> Map FlagName Bool
-> GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors)
checkPackageBuildPlan Platform
platform ActualCompiler
compiler Map PackageName Version
pool ([(FlagName, Bool)] -> Map FlagName Bool
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(FlagName, Bool)]
flags) GenericPackageDescription
gpd

    flagCombinations :: NonEmpty [(FlagName, Bool)]
    flagCombinations :: NonEmpty [(FlagName, Bool)]
flagCombinations = (PackageFlag -> NonEmpty (FlagName, Bool))
-> [PackageFlag] -> NonEmpty [(FlagName, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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) (FlagName, Bool) -> [(FlagName, Bool)] -> NonEmpty (FlagName, Bool)
forall a. a -> [a] -> NonEmpty a
:| []
            | PackageFlag -> Bool
flagDefault PackageFlag
f = (FlagName
fname, Bool
True) (FlagName, Bool) -> [(FlagName, Bool)] -> NonEmpty (FlagName, Bool)
forall a. a -> [a] -> NonEmpty a
:| [(FlagName
fname, Bool
False)]
            | Bool
otherwise = (FlagName
fname, Bool
False) (FlagName, Bool) -> [(FlagName, Bool)] -> NonEmpty (FlagName, Bool)
forall a. a -> [a] -> NonEmpty a
:| [(FlagName
fname, Bool
True)]
          where
            fname :: FlagName
fname = 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 =
    (PackageName
-> Map FlagName Bool -> Map PackageName (Map FlagName Bool)
forall k a. k -> a -> Map k a
Map.singleton PackageName
pkg Map FlagName Bool
flags, DepErrors
errs)
    where
        pkg :: PackageName
pkg         = GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd
        errs :: DepErrors
errs        = PackageName
-> Map PackageName VersionRange
-> Map PackageName Version
-> DepErrors
checkPackageDeps PackageName
pkg Map PackageName VersionRange
constraints Map PackageName Version
pool
        constraints :: Map PackageName VersionRange
constraints = GenericPackageDescription
-> ActualCompiler
-> Platform
-> Map FlagName Bool
-> Map PackageName VersionRange
gpdPackageDeps GenericPackageDescription
gpd ActualCompiler
compiler Platform
platform Map FlagName Bool
flags

-- | 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 =
    (DepError -> DepError -> DepError) -> [DepErrors] -> DepErrors
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith DepError -> DepError -> DepError
combineDepError ([DepErrors] -> DepErrors) -> [DepErrors] -> DepErrors
forall a b. (a -> b) -> a -> b
$ ((PackageName, VersionRange) -> DepErrors)
-> [(PackageName, VersionRange)] -> [DepErrors]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, VersionRange) -> DepErrors
go ([(PackageName, VersionRange)] -> [DepErrors])
-> [(PackageName, VersionRange)] -> [DepErrors]
forall a b. (a -> b) -> a -> b
$ Map PackageName VersionRange -> [(PackageName, VersionRange)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName VersionRange
deps
  where
    go :: (PackageName, VersionRange) -> DepErrors
    go :: (PackageName, VersionRange) -> DepErrors
go (PackageName
name, VersionRange
range) =
        case PackageName -> Map PackageName Version -> Maybe Version
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
name Map PackageName Version
packages of
            Maybe Version
Nothing -> PackageName -> DepError -> DepErrors
forall k a. k -> a -> Map k a
Map.singleton PackageName
name DepError
                { deVersion :: Maybe Version
deVersion = Maybe Version
forall a. Maybe a
Nothing
                , deNeededBy :: Map PackageName VersionRange
deNeededBy = PackageName -> VersionRange -> Map PackageName VersionRange
forall k a. k -> a -> Map k a
Map.singleton PackageName
myName VersionRange
range
                }
            Just Version
v
                | Version -> VersionRange -> Bool
withinRange Version
v VersionRange
range -> DepErrors
forall k a. Map k a
Map.empty
                | Bool
otherwise -> PackageName -> DepError -> DepErrors
forall k a. k -> a -> Map k a
Map.singleton PackageName
name DepError
                    { deVersion :: Maybe Version
deVersion = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v
                    , deNeededBy :: Map PackageName VersionRange
deNeededBy = PackageName -> VersionRange -> Map PackageName VersionRange
forall k a. k -> a -> Map k a
Map.singleton PackageName
myName VersionRange
range
                    }

type DepErrors = Map PackageName DepError
data DepError = DepError
    { DepError -> Maybe Version
deVersion :: !(Maybe Version)
    , DepError -> Map PackageName VersionRange
deNeededBy :: !(Map PackageName VersionRange)
    }
    deriving Int -> DepError -> ShowS
[DepError] -> ShowS
DepError -> String
(Int -> DepError -> ShowS)
-> (DepError -> String) -> ([DepError] -> ShowS) -> Show DepError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DepError -> ShowS
showsPrec :: Int -> DepError -> ShowS
$cshow :: DepError -> String
show :: DepError -> String
$cshowList :: [DepError] -> ShowS
showList :: [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) =
    Bool -> DepError -> DepError
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Maybe Version
a Maybe Version -> Maybe Version -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Version
b) (DepError -> DepError) -> DepError -> DepError
forall a b. (a -> b) -> a -> b
$ Maybe Version -> Map PackageName VersionRange -> DepError
DepError Maybe Version
a ((VersionRange -> VersionRange -> VersionRange)
-> Map PackageName VersionRange
-> Map PackageName VersionRange
-> Map PackageName VersionRange
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith VersionRange -> VersionRange -> VersionRange
C.intersectVersionRanges Map PackageName VersionRange
x Map PackageName VersionRange
y)

-- | 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 =
    ((Map FlagName Bool -> Map FlagName Bool -> Map FlagName Bool)
-> [Map PackageName (Map FlagName Bool)]
-> Map PackageName (Map FlagName Bool)
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith Map FlagName Bool -> Map FlagName Bool -> Map FlagName Bool
forall {p} {p} {a}. p -> p -> a
dupError (((Map PackageName (Map FlagName Bool), DepErrors)
 -> Map PackageName (Map FlagName Bool))
-> [(Map PackageName (Map FlagName Bool), DepErrors)]
-> [Map PackageName (Map FlagName Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (Map PackageName (Map FlagName Bool), DepErrors)
-> Map PackageName (Map FlagName Bool)
forall a b. (a, b) -> a
fst [(Map PackageName (Map FlagName Bool), DepErrors)]
plans)
    , (DepError -> DepError -> DepError) -> [DepErrors] -> DepErrors
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
Map.unionsWith DepError -> DepError -> DepError
combineDepError (((Map PackageName (Map FlagName Bool), DepErrors) -> DepErrors)
-> [(Map PackageName (Map FlagName Bool), DepErrors)]
-> [DepErrors]
forall a b. (a -> b) -> [a] -> [b]
map (Map PackageName (Map FlagName Bool), DepErrors) -> DepErrors
forall a b. (a, b) -> b
snd [(Map PackageName (Map FlagName Bool), DepErrors)]
plans))

    where
        plans :: [(Map PackageName (Map FlagName Bool), DepErrors)]
plans = (GenericPackageDescription
 -> (Map PackageName (Map FlagName Bool), DepErrors))
-> [GenericPackageDescription]
-> [(Map PackageName (Map FlagName Bool), DepErrors)]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe (Map PackageName (Map FlagName Bool))
-> GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors)
pkgPlan Maybe (Map PackageName (Map FlagName Bool))
flags) [GenericPackageDescription]
gpds
        pkgPlan :: Maybe (Map PackageName (Map FlagName Bool))
-> GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors)
pkgPlan Maybe (Map PackageName (Map FlagName Bool))
Nothing GenericPackageDescription
gpd =
            Platform
-> ActualCompiler
-> Map PackageName Version
-> GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors)
selectPackageBuildPlan Platform
platform ActualCompiler
compiler Map PackageName Version
pool' GenericPackageDescription
gpd
        pkgPlan (Just Map PackageName (Map FlagName Bool)
f) GenericPackageDescription
gpd =
            Platform
-> ActualCompiler
-> Map PackageName Version
-> Map FlagName Bool
-> GenericPackageDescription
-> (Map PackageName (Map FlagName Bool), DepErrors)
checkPackageBuildPlan Platform
platform ActualCompiler
compiler Map PackageName Version
pool' (Map PackageName (Map FlagName Bool)
-> GenericPackageDescription -> Map FlagName Bool
forall {k} {a}.
Map PackageName (Map k a) -> GenericPackageDescription -> Map k a
flags' Map PackageName (Map FlagName Bool)
f GenericPackageDescription
gpd) GenericPackageDescription
gpd
        flags' :: Map PackageName (Map k a) -> GenericPackageDescription -> Map k a
flags' Map PackageName (Map k a)
f GenericPackageDescription
gpd = Map k a -> Maybe (Map k a) -> Map k a
forall a. a -> Maybe a -> a
fromMaybe Map k a
forall k a. Map k a
Map.empty (PackageName -> Map PackageName (Map k a) -> Maybe (Map k a)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (GenericPackageDescription -> PackageName
gpdPackageName GenericPackageDescription
gpd) Map PackageName (Map k a)
f)
        pool' :: Map PackageName Version
pool' = Map PackageName Version
-> Map PackageName Version -> Map PackageName Version
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ([GenericPackageDescription] -> Map PackageName Version
gpdPackages [GenericPackageDescription]
gpds) Map PackageName Version
pool

        dupError :: p -> p -> a
dupError p
_ p
_ = BuildPlanException -> a
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.

    Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (DepErrors -> Int
forall k a. Map k a -> Int
Map.size DepErrors
e2) (DepErrors -> Int
forall k a. Map k a -> Int
Map.size DepErrors
e1)
compareBuildPlanCheck (BuildPlanCheckFail Map PackageName (Map FlagName Bool)
_ DepErrors
e1 ActualCompiler
_) (BuildPlanCheckFail Map PackageName (Map FlagName Bool)
_ DepErrors
e2 ActualCompiler
_) =
    let numUserPkgs :: Map k DepError -> Int
numUserPkgs Map k DepError
e = Map PackageName VersionRange -> Int
forall k a. Map k a -> Int
Map.size (Map PackageName VersionRange -> Int)
-> Map PackageName VersionRange -> Int
forall a b. (a -> b) -> a -> b
$ [Map PackageName VersionRange] -> Map PackageName VersionRange
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (Map k (Map PackageName VersionRange)
-> [Map PackageName VersionRange]
forall k a. Map k a -> [a]
Map.elems ((DepError -> Map PackageName VersionRange)
-> Map k DepError -> Map k (Map PackageName VersionRange)
forall a b. (a -> b) -> Map k a -> Map k b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DepError -> Map PackageName VersionRange
deNeededBy Map k DepError
e))
    in  Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (DepErrors -> Int
forall {k}. Map k DepError -> Int
numUserPkgs DepErrors
e2) (DepErrors -> Int
forall {k}. Map k DepError -> Int
numUserPkgs DepErrors
e1)
compareBuildPlanCheck BuildPlanCheckOk{}      BuildPlanCheckOk{}      = Ordering
EQ
compareBuildPlanCheck BuildPlanCheckOk{}      BuildPlanCheckPartial{} = Ordering
GT
compareBuildPlanCheck BuildPlanCheckOk{}      BuildPlanCheckFail{}    = Ordering
GT
compareBuildPlanCheck BuildPlanCheckPartial{} BuildPlanCheckFail{}    = Ordering
GT
compareBuildPlanCheck BuildPlanCheck
_                       BuildPlanCheck
_                       = Ordering
LT

instance Show BuildPlanCheck where
    show :: BuildPlanCheck -> String
show BuildPlanCheckOk {} = String
""
    show (BuildPlanCheckPartial Map PackageName (Map FlagName Bool)
f DepErrors
e)  = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Map PackageName (Map FlagName Bool) -> DepErrors -> Text
showDepErrors Map PackageName (Map FlagName Bool)
f DepErrors
e
    show (BuildPlanCheckFail Map PackageName (Map FlagName Bool)
f DepErrors
e ActualCompiler
c) = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Map PackageName (Map FlagName Bool)
-> DepErrors -> ActualCompiler -> Text
showCompilerErrors Map PackageName (Map FlagName Bool)
f DepErrors
e ActualCompiler
c

-- | 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 <- Getting Platform env Platform -> RIO env Platform
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Platform env Platform
forall env. HasPlatform env => Lens' env Platform
Lens' env Platform
platformL
    SMActual GlobalPackageVersion
sma <- SnapshotCandidate env
snapCandidate [ResolvedPath Dir]
pkgDirs
    [GenericPackageDescription]
gpds <- IO [GenericPackageDescription]
-> RIO env [GenericPackageDescription]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [GenericPackageDescription]
 -> RIO env [GenericPackageDescription])
-> IO [GenericPackageDescription]
-> RIO env [GenericPackageDescription]
forall a b. (a -> b) -> a -> b
$ [ProjectPackage]
-> (ProjectPackage -> IO GenericPackageDescription)
-> IO [GenericPackageDescription]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map PackageName ProjectPackage -> [ProjectPackage]
forall k a. Map k a -> [a]
Map.elems (Map PackageName ProjectPackage -> [ProjectPackage])
-> Map PackageName ProjectPackage -> [ProjectPackage]
forall a b. (a -> b) -> a -> b
$ SMActual GlobalPackageVersion -> Map PackageName ProjectPackage
forall global. SMActual global -> Map PackageName ProjectPackage
smaProject SMActual GlobalPackageVersion
sma) (CommonPackage -> IO GenericPackageDescription
cpGPD (CommonPackage -> IO GenericPackageDescription)
-> (ProjectPackage -> CommonPackage)
-> ProjectPackage
-> IO GenericPackageDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjectPackage -> CommonPackage
ppCommon)

    let
        compiler :: ActualCompiler
compiler = SMActual GlobalPackageVersion -> ActualCompiler
forall global. SMActual global -> ActualCompiler
smaCompiler SMActual GlobalPackageVersion
sma
        globalVersion :: GlobalPackageVersion -> Version
globalVersion (GlobalPackageVersion Version
v) = Version
v
        depVersion :: DepPackage -> Maybe Version
depVersion DepPackage
dep | PLImmutable PackageLocationImmutable
loc <- DepPackage -> PackageLocation
dpLocation DepPackage
dep =
                           Version -> Maybe Version
forall a. a -> Maybe a
Just (Version -> Maybe Version) -> Version -> Maybe Version
forall a b. (a -> b) -> a -> b
$ PackageLocationImmutable -> Version
packageLocationVersion PackageLocationImmutable
loc
                       | Bool
otherwise =
                           Maybe Version
forall a. Maybe a
Nothing
        snapPkgs :: Map PackageName Version
snapPkgs = Map PackageName Version
-> Map PackageName Version -> Map PackageName Version
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union
          ((DepPackage -> Maybe Version)
-> Map PackageName DepPackage -> Map PackageName Version
forall a b k. (a -> Maybe b) -> Map k a -> Map k b
Map.mapMaybe DepPackage -> Maybe Version
depVersion (Map PackageName DepPackage -> Map PackageName Version)
-> Map PackageName DepPackage -> Map PackageName Version
forall a b. (a -> b) -> a -> b
$ SMActual GlobalPackageVersion -> Map PackageName DepPackage
forall global. SMActual global -> Map PackageName DepPackage
smaDeps SMActual GlobalPackageVersion
sma)
          ((GlobalPackageVersion -> Version)
-> Map PackageName GlobalPackageVersion -> Map PackageName Version
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map GlobalPackageVersion -> Version
globalVersion (Map PackageName GlobalPackageVersion -> Map PackageName Version)
-> Map PackageName GlobalPackageVersion -> Map PackageName Version
forall a b. (a -> b) -> a -> b
$ SMActual GlobalPackageVersion
-> Map PackageName GlobalPackageVersion
forall global. SMActual global -> Map PackageName global
smaGlobal SMActual GlobalPackageVersion
sma)
        (Map PackageName (Map FlagName Bool)
f, DepErrors
errs) = Platform
-> ActualCompiler
-> Map PackageName Version
-> Maybe (Map PackageName (Map FlagName Bool))
-> [GenericPackageDescription]
-> (Map PackageName (Map FlagName Bool), DepErrors)
checkBundleBuildPlan Platform
platform ActualCompiler
compiler Map PackageName Version
snapPkgs Maybe (Map PackageName (Map FlagName Bool))
flags [GenericPackageDescription]
gpds
        cerrs :: DepErrors
cerrs = ActualCompiler -> DepErrors -> DepErrors
forall {a}.
ActualCompiler -> Map PackageName a -> Map PackageName a
compilerErrors ActualCompiler
compiler DepErrors
errs

    if DepErrors -> Bool
forall k a. Map k a -> Bool
Map.null DepErrors
errs then
        BuildPlanCheck -> RIO env BuildPlanCheck
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BuildPlanCheck -> RIO env BuildPlanCheck)
-> BuildPlanCheck -> RIO env BuildPlanCheck
forall a b. (a -> b) -> a -> b
$ Map PackageName (Map FlagName Bool) -> BuildPlanCheck
BuildPlanCheckOk Map PackageName (Map FlagName Bool)
f
    else if DepErrors -> Bool
forall k a. Map k a -> Bool
Map.null DepErrors
cerrs then
            BuildPlanCheck -> RIO env BuildPlanCheck
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BuildPlanCheck -> RIO env BuildPlanCheck)
-> BuildPlanCheck -> RIO env BuildPlanCheck
forall a b. (a -> b) -> a -> b
$ Map PackageName (Map FlagName Bool) -> DepErrors -> BuildPlanCheck
BuildPlanCheckPartial Map PackageName (Map FlagName Bool)
f DepErrors
errs
        else
            BuildPlanCheck -> RIO env BuildPlanCheck
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BuildPlanCheck -> RIO env BuildPlanCheck)
-> BuildPlanCheck -> RIO env BuildPlanCheck
forall a b. (a -> b) -> a -> b
$ Map PackageName (Map FlagName Bool)
-> DepErrors -> ActualCompiler -> BuildPlanCheck
BuildPlanCheckFail Map PackageName (Map FlagName Bool)
f DepErrors
cerrs ActualCompiler
compiler
    where
        compilerErrors :: ActualCompiler -> Map PackageName a -> Map PackageName a
compilerErrors ActualCompiler
compiler Map PackageName a
errs
            | ActualCompiler -> WhichCompiler
whichCompiler ActualCompiler
compiler WhichCompiler -> WhichCompiler -> Bool
forall a. Eq a => a -> a -> Bool
== WhichCompiler
Ghc = Map PackageName a -> Map PackageName a
forall {a}. Map PackageName a -> Map PackageName a
ghcErrors Map PackageName a
errs
            | Bool
otherwise = Map PackageName a
forall k a. Map k a
Map.empty

        isGhcWiredIn :: PackageName -> p -> Bool
isGhcWiredIn PackageName
p p
_ = PackageName
p PackageName -> Set PackageName -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PackageName
wiredInPackages
        ghcErrors :: Map PackageName a -> Map PackageName a
ghcErrors = (PackageName -> a -> Bool)
-> Map PackageName a -> Map PackageName a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
Map.filterWithKey PackageName -> a -> Bool
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
    StyleDoc -> RIO env ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyInfo (StyleDoc -> RIO env ()) -> StyleDoc -> RIO env ()
forall a b. (a -> b) -> a -> b
$
           [StyleDoc] -> StyleDoc
fillSep
             [ String -> StyleDoc
flow String
"Selecting the best among"
             , String -> StyleDoc
forall a. IsString a => String -> a
fromString (String -> StyleDoc) -> String -> StyleDoc
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (NonEmpty SnapName -> Int
forall a. NonEmpty a -> Int
NonEmpty.length NonEmpty SnapName
snaps)
             , StyleDoc
"snapshots..."
             ]
        StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    (RIO
   env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
 -> RIO
      env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
 -> RIO
      env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck))
-> NonEmpty
     (RIO
        env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck))
-> RIO
     env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
forall a. (a -> a -> a) -> NonEmpty a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
F.foldr1 RIO
  env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
-> RIO
     env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
-> RIO
     env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
forall {m :: * -> *} {a} {b}.
Monad m =>
m (a, b, BuildPlanCheck)
-> m (a, b, BuildPlanCheck) -> m (a, b, BuildPlanCheck)
go ((SnapName
 -> RIO
      env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck))
-> NonEmpty SnapName
-> NonEmpty
     (RIO
        env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck))
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (RawSnapshotLocation
-> RIO
     env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
getResult (RawSnapshotLocation
 -> RIO
      env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck))
-> (SnapName -> RIO env RawSnapshotLocation)
-> SnapName
-> RIO
     env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< SnapName -> RIO env RawSnapshotLocation
forall env.
HasPantryConfig env =>
SnapName -> RIO env RawSnapshotLocation
snapshotLocation) NonEmpty SnapName
snaps)
    where
        go :: m (a, b, BuildPlanCheck)
-> m (a, b, BuildPlanCheck) -> m (a, b, BuildPlanCheck)
go m (a, b, BuildPlanCheck)
mold m (a, b, BuildPlanCheck)
mnew = do
            old :: (a, b, BuildPlanCheck)
old@(a
_snap, b
_loc, BuildPlanCheck
bpc) <- m (a, b, BuildPlanCheck)
mold
            case BuildPlanCheck
bpc of
                BuildPlanCheckOk {} -> (a, b, BuildPlanCheck) -> m (a, b, BuildPlanCheck)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a, b, BuildPlanCheck)
old
                BuildPlanCheck
_ -> ((a, b, BuildPlanCheck) -> (a, b, BuildPlanCheck))
-> m (a, b, BuildPlanCheck) -> m (a, b, BuildPlanCheck)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a, b, BuildPlanCheck)
-> (a, b, BuildPlanCheck) -> (a, b, BuildPlanCheck)
forall {a} {b}.
(a, b, BuildPlanCheck)
-> (a, b, BuildPlanCheck) -> (a, b, BuildPlanCheck)
betterSnap (a, b, BuildPlanCheck)
old) m (a, b, BuildPlanCheck)
mnew

        getResult :: RawSnapshotLocation
-> RIO
     env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
getResult RawSnapshotLocation
loc = do
            SnapshotCandidate env
candidate <- RawSnapshotLocation
-> PrintWarnings -> Bool -> RIO env (SnapshotCandidate env)
forall env.
HasConfig env =>
RawSnapshotLocation
-> PrintWarnings -> Bool -> RIO env (SnapshotCandidate env)
loadProjectSnapshotCandidate RawSnapshotLocation
loc PrintWarnings
NoPrintWarnings Bool
False
            BuildPlanCheck
result <- [ResolvedPath Dir]
-> Maybe (Map PackageName (Map FlagName Bool))
-> SnapshotCandidate env
-> RIO env BuildPlanCheck
forall env.
(HasConfig env, HasGHCVariant env) =>
[ResolvedPath Dir]
-> Maybe (Map PackageName (Map FlagName Bool))
-> SnapshotCandidate env
-> RIO env BuildPlanCheck
checkSnapBuildPlan [ResolvedPath Dir]
pkgDirs Maybe (Map PackageName (Map FlagName Bool))
forall a. Maybe a
Nothing SnapshotCandidate env
candidate
            BuildPlanCheck -> RawSnapshotLocation -> RIO env ()
forall {m :: * -> *} {env}.
(MonadIO m, HasTerm env, MonadReader env m) =>
BuildPlanCheck -> RawSnapshotLocation -> m ()
reportResult BuildPlanCheck
result RawSnapshotLocation
loc
            (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
-> RIO
     env (SnapshotCandidate env, RawSnapshotLocation, BuildPlanCheck)
forall a. a -> RIO env a
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 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
/= Ordering
LT = (a
s1, b
l1, BuildPlanCheck
r1)
          | Bool
otherwise = (a
s2, b
l2, BuildPlanCheck
r2)

        reportResult :: BuildPlanCheck -> RawSnapshotLocation -> m ()
reportResult BuildPlanCheckOk {} RawSnapshotLocation
loc =
            StyleDoc -> m ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyNote (StyleDoc -> m ()) -> StyleDoc -> m ()
forall a b. (a -> b) -> a -> b
$
                   [StyleDoc] -> StyleDoc
fillSep
                      [ String -> StyleDoc
flow String
"Matches"
                      , PrettyRawSnapshotLocation -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty (PrettyRawSnapshotLocation -> StyleDoc)
-> PrettyRawSnapshotLocation -> StyleDoc
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> PrettyRawSnapshotLocation
PrettyRawSnapshotLocation RawSnapshotLocation
loc
                      ]
                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line

        reportResult r :: BuildPlanCheck
r@BuildPlanCheckPartial {} RawSnapshotLocation
loc =
            StyleDoc -> m ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> m ()) -> StyleDoc -> m ()
forall a b. (a -> b) -> a -> b
$
                   [StyleDoc] -> StyleDoc
fillSep
                     [ String -> StyleDoc
flow String
"Partially matches"
                     , PrettyRawSnapshotLocation -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty (PrettyRawSnapshotLocation -> StyleDoc)
-> PrettyRawSnapshotLocation -> StyleDoc
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> PrettyRawSnapshotLocation
PrettyRawSnapshotLocation RawSnapshotLocation
loc
                     ]
                 StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                 StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4 (String -> StyleDoc
string (BuildPlanCheck -> String
forall a. Show a => a -> String
show BuildPlanCheck
r))

        reportResult r :: BuildPlanCheck
r@BuildPlanCheckFail {} RawSnapshotLocation
loc =
            StyleDoc -> m ()
forall env (m :: * -> *).
(?callStack::CallStack, HasTerm env, MonadReader env m,
 MonadIO m) =>
StyleDoc -> m ()
prettyWarn (StyleDoc -> m ()) -> StyleDoc -> m ()
forall a b. (a -> b) -> a -> b
$
                   [StyleDoc] -> StyleDoc
fillSep
                     [ String -> StyleDoc
flow String
"Rejected"
                     , PrettyRawSnapshotLocation -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty (PrettyRawSnapshotLocation -> StyleDoc)
-> PrettyRawSnapshotLocation -> StyleDoc
forall a b. (a -> b) -> a -> b
$ RawSnapshotLocation -> PrettyRawSnapshotLocation
PrettyRawSnapshotLocation RawSnapshotLocation
loc
                     ]
                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
                StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> Int -> StyleDoc -> StyleDoc
indent Int
4 (String -> StyleDoc
string (BuildPlanCheck -> String
forall a. Show a => a -> String
show BuildPlanCheck
r))

showItems :: [String] -> Text
showItems :: [String] -> Text
showItems [String]
items = [Text] -> Text
T.concat ((String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
formatItem [String]
items)
    where
        formatItem :: String -> Text
formatItem String
item = [Text] -> Text
T.concat
            [ Text
"    - "
            , String -> Text
T.pack String
item
            , Text
"\n"
            ]

showPackageFlags :: PackageName -> Map FlagName Bool -> Text
showPackageFlags :: PackageName -> Map FlagName Bool -> Text
showPackageFlags PackageName
pkg Map FlagName Bool
fl =
    if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Map FlagName Bool -> Bool
forall k a. Map k a -> Bool
Map.null Map FlagName Bool
fl then
        [Text] -> Text
T.concat
            [ Text
"    - "
            , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
pkg
            , Text
": "
            , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", "
                     ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((FlagName, Bool) -> String) -> [(FlagName, Bool)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (FlagName, Bool) -> String
forall {a} {a}. (Show a, Show a) => (a, a) -> String
formatFlags (Map FlagName Bool -> [(FlagName, Bool)]
forall k a. Map k a -> [(k, a)]
Map.toList Map FlagName Bool
fl)
            , Text
"\n"
            ]
    else Text
""
    where
        formatFlags :: (a, a) -> String
formatFlags (a
f, a
v) = a -> String
forall a. Show a => a -> String
show a
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" = " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
v

showMapPackages :: Map PackageName a -> Text
showMapPackages :: forall a. Map PackageName a -> Text
showMapPackages Map PackageName a
mp = [String] -> Text
showItems ([String] -> Text) -> [String] -> Text
forall a b. (a -> b) -> a -> b
$ (PackageName -> String) -> [PackageName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> String
packageNameString ([PackageName] -> [String]) -> [PackageName] -> [String]
forall a b. (a -> b) -> a -> b
$ Map PackageName a -> [PackageName]
forall k a. Map k a -> [k]
Map.keys Map PackageName a
mp

showCompilerErrors ::
       Map PackageName (Map FlagName Bool)
    -> DepErrors
    -> ActualCompiler
    -> Text
showCompilerErrors :: Map PackageName (Map FlagName Bool)
-> DepErrors -> ActualCompiler -> Text
showCompilerErrors Map PackageName (Map FlagName Bool)
flags DepErrors
errs ActualCompiler
compiler =
    [Text] -> Text
T.concat
        [ ActualCompiler -> Text
compilerVersionText ActualCompiler
compiler
        , Text
" cannot be used for these packages:\n"
        , Map PackageName VersionRange -> Text
forall a. Map PackageName a -> Text
showMapPackages (Map PackageName VersionRange -> Text)
-> Map PackageName VersionRange -> Text
forall a b. (a -> b) -> a -> b
$ [Map PackageName VersionRange] -> Map PackageName VersionRange
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (Map PackageName (Map PackageName VersionRange)
-> [Map PackageName VersionRange]
forall k a. Map k a -> [a]
Map.elems ((DepError -> Map PackageName VersionRange)
-> DepErrors -> Map PackageName (Map PackageName VersionRange)
forall a b. (a -> b) -> Map PackageName a -> Map PackageName b
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 ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((PackageName, DepError) -> Text)
-> [(PackageName, DepError)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, DepError) -> Text
formatError (DepErrors -> [(PackageName, DepError)]
forall k a. Map k a -> [(k, a)]
Map.toList DepErrors
errs)
        , if Text -> Bool
T.null Text
flagVals then Text
""
          else Text
"Using package flags:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
flagVals
        ]
    where
        formatError :: (PackageName, DepError) -> Text
formatError (PackageName
depName, DepError Maybe Version
mversion Map PackageName VersionRange
neededBy) = [Text] -> Text
T.concat
            [ PackageName -> Maybe Version -> Text
showDepVersion PackageName
depName Maybe Version
mversion
            , [Text] -> Text
T.concat (((PackageName, VersionRange) -> Text)
-> [(PackageName, VersionRange)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (PackageName, VersionRange) -> Text
forall {a}. Pretty a => (PackageName, a) -> Text
showRequirement (Map PackageName VersionRange -> [(PackageName, VersionRange)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PackageName VersionRange
neededBy))
            ]

        showDepVersion :: PackageName -> Maybe Version -> Text
showDepVersion PackageName
depName Maybe Version
mversion = [Text] -> Text
T.concat
            [ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
depName
            , case Maybe Version
mversion of
                Maybe Version
Nothing -> Text
" not found"
                Just Version
version -> [Text] -> Text
T.concat
                    [ Text
" version "
                    , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Version -> String
versionString Version
version
                    , Text
" found"
                    ]
            , Text
"\n"
            ]

        showRequirement :: (PackageName, a) -> Text
showRequirement (PackageName
user, a
range) = [Text] -> Text
T.concat
            [ Text
"    - "
            , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ PackageName -> String
packageNameString PackageName
user
            , Text
" requires "
            , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Pretty a => a -> String
display a
range
            , Text
"\n"
            ]

        flagVals :: Text
flagVals = [Text] -> Text
T.concat ((PackageName -> Text) -> [PackageName] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map PackageName -> Text
showFlags [PackageName]
userPkgs)
        userPkgs :: [PackageName]
userPkgs = Map PackageName VersionRange -> [PackageName]
forall k a. Map k a -> [k]
Map.keys (Map PackageName VersionRange -> [PackageName])
-> Map PackageName VersionRange -> [PackageName]
forall a b. (a -> b) -> a -> b
$ [Map PackageName VersionRange] -> Map PackageName VersionRange
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (Map PackageName (Map PackageName VersionRange)
-> [Map PackageName VersionRange]
forall k a. Map k a -> [a]
Map.elems ((DepError -> Map PackageName VersionRange)
-> DepErrors -> Map PackageName (Map PackageName VersionRange)
forall a b. (a -> b) -> Map PackageName a -> Map PackageName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DepError -> Map PackageName VersionRange
deNeededBy DepErrors
errs))
        showFlags :: PackageName -> Text
showFlags PackageName
pkg = Text
-> (Map FlagName Bool -> Text) -> Maybe (Map FlagName Bool) -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" (PackageName -> Map FlagName Bool -> Text
showPackageFlags PackageName
pkg) (PackageName
-> Map PackageName (Map FlagName Bool) -> Maybe (Map FlagName Bool)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PackageName
pkg Map PackageName (Map FlagName Bool)
flags)