{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# 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.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 qualified RIO.NonEmpty as NE
import           Stack.Constants ( wiredInPackages )
import           Stack.Package
                   ( PackageConfig (..), packageDependencies
                   , 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
compilerVersion 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 = PackageConfig -> GenericPackageDescription -> PackageDescription
resolvePackageDescription PackageConfig
pkgConfig GenericPackageDescription
gpd
  pkgConfig :: PackageConfig
pkgConfig = PackageConfig
    { $sel:enableTests:PackageConfig :: Bool
enableTests = Bool
True
    , $sel:enableBenchmarks:PackageConfig :: Bool
enableBenchmarks = Bool
True
    , Map FlagName Bool
flags :: Map FlagName Bool
$sel:flags:PackageConfig :: Map FlagName Bool
flags
    , $sel:ghcOptions:PackageConfig :: [Text]
ghcOptions = []
    , $sel:cabalConfigOpts:PackageConfig :: [Text]
cabalConfigOpts = []
    , ActualCompiler
compilerVersion :: ActualCompiler
$sel:compilerVersion:PackageConfig :: ActualCompiler
compilerVersion
    , Platform
platform :: Platform
$sel:platform:PackageConfig :: 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
NE.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
        { $sel:version:DepError :: Maybe Version
version = Maybe Version
forall a. Maybe a
Nothing
        , $sel:neededBy:DepError :: Map PackageName VersionRange
neededBy = 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
            { $sel:version:DepError :: Maybe Version
version = Version -> Maybe Version
forall a. a -> Maybe a
Just Version
v
            , $sel:neededBy:DepError :: Map PackageName VersionRange
neededBy = 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
version :: !(Maybe Version)
  , DepError -> Map PackageName VersionRange
neededBy :: !(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 a -> Int
numUserPkgs Map k a
e = Map k a -> Int
forall k a. Map k a -> Int
Map.size (Map k a -> Int) -> Map k a -> Int
forall a b. (a -> b) -> a -> b
$ [Map k a] -> Map k a
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions (Map k (Map k a) -> [Map k a]
forall k a. Map k a -> [a]
Map.elems ((a -> Map k a) -> Map k a -> Map k (Map k a)
forall a b. (a -> b) -> Map k a -> Map k b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (.neededBy) Map k a
e))
  in  Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (DepErrors -> Int
forall {k} {a} {a} {k}.
(Ord k, HasField "neededBy" a (Map k a)) =>
Map k a -> Int
numUserPkgs DepErrors
e2) (DepErrors -> Int
forall {k} {a} {a} {k}.
(Ord k, HasField "neededBy" a (Map k a)) =>
Map k a -> 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 SMActual GlobalPackageVersion
sma.project) (.projectCommon.gpd)

  let compiler :: ActualCompiler
compiler = SMActual GlobalPackageVersion
sma.compiler
      globalVersion :: GlobalPackageVersion -> Version
globalVersion (GlobalPackageVersion Version
v) = Version
v
      depVersion :: r -> Maybe Version
depVersion r
dep
        | PLImmutable PackageLocationImmutable
loc <- r
dep.location = 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
forall {r}.
HasField "location" r PackageLocation =>
r -> Maybe Version
depVersion SMActual GlobalPackageVersion
sma.deps)
        ((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 SMActual GlobalPackageVersion
sma.globals)
      (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
NE.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
NE.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 (.neededBy) 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 (.neededBy) 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)