{-# LANGUAGE NamedFieldPuns #-}

module Distribution.Client.CmdGenBounds
  ( genBounds
  , genBoundsCommand
  , genBoundsAction
  , GenBoundsFlags (..)
  , defaultGenBoundsFlags
  ) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import qualified Data.Map as Map

import Control.Monad (mapM_)

import Distribution.Client.Errors

import Distribution.Client.ProjectPlanning hiding (pruneInstallPlanToTargets)
import Distribution.Client.ProjectPlanning.Types
import Distribution.Client.Types.ConfiguredId (confInstId)
import Distribution.Client.Utils hiding (pvpize)
import Distribution.InstalledPackageInfo (InstalledPackageInfo, installedComponentId)
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Simple.Utils
import Distribution.Version

import Distribution.Client.Setup (GlobalFlags (..))

-- Project orchestration imports

import Distribution.Client.CmdErrorMessages
import Distribution.Client.GenBounds
import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.NixStyleOptions
import Distribution.Client.ProjectFlags
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ScriptUtils
import Distribution.Client.TargetProblem
import Distribution.Simple.Command
import Distribution.Types.Component
import Distribution.Verbosity

-- | The data type for gen-bounds command flags
data GenBoundsFlags = GenBoundsFlags {}

-- | Default values for the gen-bounds flags
defaultGenBoundsFlags :: GenBoundsFlags
defaultGenBoundsFlags :: GenBoundsFlags
defaultGenBoundsFlags = GenBoundsFlags{}

-- | The @gen-bounds@ command definition
genBoundsCommand :: CommandUI (NixStyleFlags GenBoundsFlags)
genBoundsCommand :: CommandUI (NixStyleFlags GenBoundsFlags)
genBoundsCommand =
  CommandUI
    { commandName :: String
commandName = String
"v2-gen-bounds"
    , commandSynopsis :: String
commandSynopsis = String
"Generate dependency bounds for packages in the project."
    , commandUsage :: String -> String
commandUsage = String -> [String] -> String -> String
usageAlternatives String
"v2-gen-bounds" [String
"[TARGETS] [FLAGS]"]
    , commandDescription :: Maybe (String -> String)
commandDescription = (String -> String) -> Maybe (String -> String)
forall a. a -> Maybe a
Just ((String -> String) -> Maybe (String -> String))
-> (String -> String) -> Maybe (String -> String)
forall a b. (a -> b) -> a -> b
$ \String
_ ->
        String
"Generate PVP-compliant dependency bounds for packages in the project."
    , commandNotes :: Maybe (String -> String)
commandNotes = (String -> String) -> Maybe (String -> String)
forall a. a -> Maybe a
Just ((String -> String) -> Maybe (String -> String))
-> (String -> String) -> Maybe (String -> String)
forall a b. (a -> b) -> a -> b
$ \String
pname ->
        String
"Examples:\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-gen-bounds\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    Generate bounds for the package in the current directory "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"or all packages in the project\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-gen-bounds pkgname\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    Generate bounds for the package named pkgname in the project\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v2-gen-bounds ./pkgfoo\n"
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"    Generate bounds for the package in the ./pkgfoo directory\n"
    , commandDefaultFlags :: NixStyleFlags GenBoundsFlags
commandDefaultFlags = GenBoundsFlags -> NixStyleFlags GenBoundsFlags
forall a. a -> NixStyleFlags a
defaultNixStyleFlags GenBoundsFlags
defaultGenBoundsFlags
    , commandOptions :: ShowOrParseArgs -> [OptionField (NixStyleFlags GenBoundsFlags)]
commandOptions =
        [OptionField (NixStyleFlags GenBoundsFlags)]
-> [OptionField (NixStyleFlags GenBoundsFlags)]
forall a. [OptionField a] -> [OptionField a]
removeIgnoreProjectOption
          ([OptionField (NixStyleFlags GenBoundsFlags)]
 -> [OptionField (NixStyleFlags GenBoundsFlags)])
-> (ShowOrParseArgs
    -> [OptionField (NixStyleFlags GenBoundsFlags)])
-> ShowOrParseArgs
-> [OptionField (NixStyleFlags GenBoundsFlags)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowOrParseArgs -> [OptionField GenBoundsFlags])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags GenBoundsFlags)]
forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions ([OptionField GenBoundsFlags]
-> ShowOrParseArgs -> [OptionField GenBoundsFlags]
forall a b. a -> b -> a
const [])
    }

-- | The action for the @gen-bounds@ command when used in a project context.
genBoundsAction :: NixStyleFlags GenBoundsFlags -> [String] -> GlobalFlags -> IO ()
genBoundsAction :: NixStyleFlags GenBoundsFlags -> [String] -> GlobalFlags -> IO ()
genBoundsAction NixStyleFlags GenBoundsFlags
flags [String]
targetStrings GlobalFlags
globalFlags =
  Verbosity
-> AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags GenBoundsFlags
-> [String]
-> GlobalFlags
-> CurrentCommand
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO ())
-> IO ()
forall a b.
Verbosity
-> AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags a
-> [String]
-> GlobalFlags
-> CurrentCommand
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO b)
-> IO b
withContextAndSelectors Verbosity
verbosity AcceptNoTargets
RejectNoTargets Maybe ComponentKind
forall a. Maybe a
Nothing NixStyleFlags GenBoundsFlags
flags [String]
targetStrings GlobalFlags
globalFlags CurrentCommand
OtherCommand ((TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO ())
 -> IO ())
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$ \TargetContext
targetCtx ProjectBaseContext
ctx [TargetSelector]
targetSelectors -> do
    ProjectBaseContext
baseCtx <- case TargetContext
targetCtx of
      TargetContext
ProjectContext -> ProjectBaseContext -> IO ProjectBaseContext
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext
ctx
      TargetContext
GlobalContext -> ProjectBaseContext -> IO ProjectBaseContext
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext
ctx
      ScriptContext String
path Executable
_ ->
        Verbosity -> CabalInstallException -> IO ProjectBaseContext
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO ProjectBaseContext)
-> CabalInstallException -> IO ProjectBaseContext
forall a b. (a -> b) -> a -> b
$
          String -> CabalInstallException
GenBoundsDoesNotSupportScript String
path

    let ProjectBaseContext{DistDirLayout
distDirLayout :: DistDirLayout
distDirLayout :: ProjectBaseContext -> DistDirLayout
distDirLayout, CabalDirLayout
cabalDirLayout :: CabalDirLayout
cabalDirLayout :: ProjectBaseContext -> CabalDirLayout
cabalDirLayout, ProjectConfig
projectConfig :: ProjectConfig
projectConfig :: ProjectBaseContext -> ProjectConfig
projectConfig, [PackageSpecifier UnresolvedSourcePackage]
localPackages :: [PackageSpecifier UnresolvedSourcePackage]
localPackages :: ProjectBaseContext -> [PackageSpecifier UnresolvedSourcePackage]
localPackages} = ProjectBaseContext
baseCtx

    -- Step 1: Create the install plan for the project.
    (ElaboratedInstallPlan
_, ElaboratedInstallPlan
elaboratedPlan, ElaboratedSharedConfig
_, TotalIndexState
_, ActiveRepos
_) <-
      Verbosity
-> DistDirLayout
-> CabalDirLayout
-> ProjectConfig
-> [PackageSpecifier UnresolvedSourcePackage]
-> Maybe InstalledPackageIndex
-> IO
     (ElaboratedInstallPlan, ElaboratedInstallPlan,
      ElaboratedSharedConfig, TotalIndexState, ActiveRepos)
rebuildInstallPlan
        Verbosity
verbosity
        DistDirLayout
distDirLayout
        CabalDirLayout
cabalDirLayout
        ProjectConfig
projectConfig
        [PackageSpecifier UnresolvedSourcePackage]
localPackages
        Maybe InstalledPackageIndex
forall a. Maybe a
Nothing

    -- Step 2: Resolve the targets for the gen-bounds command.
    TargetsMap
targets <-
      ([TargetProblem'] -> IO TargetsMap)
-> (TargetsMap -> IO TargetsMap)
-> Either [TargetProblem'] TargetsMap
-> IO TargetsMap
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> [TargetProblem'] -> IO TargetsMap
forall a. Verbosity -> [TargetProblem'] -> IO a
reportGenBoundsTargetProblems Verbosity
verbosity) TargetsMap -> IO TargetsMap
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [TargetProblem'] TargetsMap -> IO TargetsMap)
-> Either [TargetProblem'] TargetsMap -> IO TargetsMap
forall a b. (a -> b) -> a -> b
$
        (forall k.
 TargetSelector -> [AvailableTarget k] -> Either TargetProblem' [k])
-> (forall k.
    SubComponentTarget -> AvailableTarget k -> Either TargetProblem' k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem'] TargetsMap
forall err.
(forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either (TargetProblem err) [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either (TargetProblem err) k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [TargetProblem err] TargetsMap
resolveTargetsFromSolver
          TargetSelector -> [AvailableTarget k] -> Either TargetProblem' [k]
forall k.
TargetSelector -> [AvailableTarget k] -> Either TargetProblem' [k]
selectPackageTargets
          SubComponentTarget -> AvailableTarget k -> Either TargetProblem' k
forall k.
SubComponentTarget -> AvailableTarget k -> Either TargetProblem' k
selectComponentTarget
          ElaboratedInstallPlan
elaboratedPlan
          Maybe SourcePackageDb
forall a. Maybe a
Nothing
          [TargetSelector]
targetSelectors

    -- Step 3: Prune the install plan to the targets.
    let elaboratedPlan' :: ElaboratedInstallPlan
elaboratedPlan' =
          TargetAction
-> TargetsMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets
            TargetAction
TargetActionBuild
            TargetsMap
targets
            ElaboratedInstallPlan
elaboratedPlan

    let
      -- Step 4a: Find the local packages from the install plan. These are the
      -- candidates for which we will generate bounds.
      localPkgs :: [ElaboratedConfiguredPackage]
      localPkgs :: [ElaboratedConfiguredPackage]
localPkgs = (GenericPlanPackage
   InstalledPackageInfo ElaboratedConfiguredPackage
 -> Maybe ElaboratedConfiguredPackage)
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
-> [ElaboratedConfiguredPackage]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((InstalledPackageInfo -> Maybe ElaboratedConfiguredPackage)
-> (ElaboratedConfiguredPackage
    -> Maybe ElaboratedConfiguredPackage)
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
-> Maybe ElaboratedConfiguredPackage
forall ipkg a srcpkg.
(ipkg -> a) -> (srcpkg -> a) -> GenericPlanPackage ipkg srcpkg -> a
InstallPlan.foldPlanPackage (Maybe ElaboratedConfiguredPackage
-> InstalledPackageInfo -> Maybe ElaboratedConfiguredPackage
forall a b. a -> b -> a
const Maybe ElaboratedConfiguredPackage
forall a. Maybe a
Nothing) (\ElaboratedConfiguredPackage
p -> ElaboratedConfiguredPackage -> Maybe ElaboratedConfiguredPackage
forall a. a -> Maybe a
Just ElaboratedConfiguredPackage
p)) (ElaboratedInstallPlan
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
elaboratedPlan')

      -- Step 4b: Extract which versions we chose for each package from the pruned install plan.
      pkgVersionMap :: Map.Map ComponentId PackageIdentifier
      pkgVersionMap :: Map ComponentId PackageIdentifier
pkgVersionMap = [(ComponentId, PackageIdentifier)]
-> Map ComponentId PackageIdentifier
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((GenericPlanPackage
   InstalledPackageInfo ElaboratedConfiguredPackage
 -> (ComponentId, PackageIdentifier))
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
-> [(ComponentId, PackageIdentifier)]
forall a b. (a -> b) -> [a] -> [b]
map ((InstalledPackageInfo -> (ComponentId, PackageIdentifier))
-> (ElaboratedConfiguredPackage
    -> (ComponentId, PackageIdentifier))
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
-> (ComponentId, PackageIdentifier)
forall ipkg a srcpkg.
(ipkg -> a) -> (srcpkg -> a) -> GenericPlanPackage ipkg srcpkg -> a
InstallPlan.foldPlanPackage InstalledPackageInfo -> (ComponentId, PackageIdentifier)
externalVersion ElaboratedConfiguredPackage -> (ComponentId, PackageIdentifier)
localVersion) (ElaboratedInstallPlan
-> [GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage]
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]
InstallPlan.toList ElaboratedInstallPlan
elaboratedPlan'))

      externalVersion :: InstalledPackageInfo -> (ComponentId, PackageIdentifier)
      externalVersion :: InstalledPackageInfo -> (ComponentId, PackageIdentifier)
externalVersion InstalledPackageInfo
pkg = (InstalledPackageInfo -> ComponentId
installedComponentId InstalledPackageInfo
pkg, InstalledPackageInfo -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId InstalledPackageInfo
pkg)

      localVersion :: ElaboratedConfiguredPackage -> (ComponentId, PackageIdentifier)
      localVersion :: ElaboratedConfiguredPackage -> (ComponentId, PackageIdentifier)
localVersion ElaboratedConfiguredPackage
pkg = (ElaboratedConfiguredPackage -> ComponentId
elabComponentId ElaboratedConfiguredPackage
pkg, ElaboratedConfiguredPackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ElaboratedConfiguredPackage
pkg)

    let genBoundsActionForPkg :: ElaboratedConfiguredPackage -> [GenBoundsResult]
        genBoundsActionForPkg :: ElaboratedConfiguredPackage -> [GenBoundsResult]
genBoundsActionForPkg ElaboratedConfiguredPackage
pkg =
          -- Step 5: Match up the user specified targets with the local packages.
          case UnitId
-> TargetsMap -> Maybe [(ComponentTarget, NonEmpty TargetSelector)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ElaboratedConfiguredPackage -> UnitId
forall pkg. HasUnitId pkg => pkg -> UnitId
installedUnitId ElaboratedConfiguredPackage
pkg) TargetsMap
targets of
            Maybe [(ComponentTarget, NonEmpty TargetSelector)]
Nothing -> []
            Just [(ComponentTarget, NonEmpty TargetSelector)]
tgts ->
              ((ComponentTarget, NonEmpty TargetSelector) -> GenBoundsResult)
-> [(ComponentTarget, NonEmpty TargetSelector)]
-> [GenBoundsResult]
forall a b. (a -> b) -> [a] -> [b]
map (\(ComponentTarget
tgt, NonEmpty TargetSelector
_) -> ComponentTarget
-> ElaboratedConfiguredPackage
-> Map ComponentId PackageIdentifier
-> GenBoundsResult
getBoundsForComponent ComponentTarget
tgt ElaboratedConfiguredPackage
pkg Map ComponentId PackageIdentifier
pkgVersionMap) [(ComponentTarget, NonEmpty TargetSelector)]
tgts

    -- Process each package to find the ones needing bounds
    let boundsActions :: [GenBoundsResult]
boundsActions = (ElaboratedConfiguredPackage -> [GenBoundsResult])
-> [ElaboratedConfiguredPackage] -> [GenBoundsResult]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ElaboratedConfiguredPackage -> [GenBoundsResult]
genBoundsActionForPkg [ElaboratedConfiguredPackage]
localPkgs

    if ((GenBoundsResult -> Bool) -> [GenBoundsResult] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any GenBoundsResult -> Bool
isBoundsNeeded [GenBoundsResult]
boundsActions)
      then do
        Verbosity -> String -> IO ()
notice Verbosity
verbosity String
boundsNeededMsg
        (GenBoundsResult -> IO ()) -> [GenBoundsResult] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Verbosity -> GenBoundsResult -> IO ()
renderBoundsResult Verbosity
verbosity) [GenBoundsResult]
boundsActions
      else Verbosity -> String -> IO ()
notice Verbosity
verbosity String
"All bounds up-to-date"
  where
    verbosity :: Verbosity
verbosity = Verbosity -> NixStyleFlags GenBoundsFlags -> Verbosity
forall a. Verbosity -> NixStyleFlags a -> Verbosity
cfgVerbosity Verbosity
normal NixStyleFlags GenBoundsFlags
flags

data GenBoundsResult = GenBoundsResult PackageIdentifier ComponentTarget (Maybe [PackageIdentifier])

isBoundsNeeded :: GenBoundsResult -> Bool
isBoundsNeeded :: GenBoundsResult -> Bool
isBoundsNeeded (GenBoundsResult PackageIdentifier
_ ComponentTarget
_ Maybe [PackageIdentifier]
Nothing) = Bool
False
isBoundsNeeded GenBoundsResult
_ = Bool
True

renderBoundsResult :: Verbosity -> GenBoundsResult -> IO ()
renderBoundsResult :: Verbosity -> GenBoundsResult -> IO ()
renderBoundsResult Verbosity
verbosity (GenBoundsResult PackageIdentifier
pid ComponentTarget
tgt Maybe [PackageIdentifier]
bounds) =
  case Maybe [PackageIdentifier]
bounds of
    Maybe [PackageIdentifier]
Nothing ->
      Verbosity -> String -> IO ()
notice
        Verbosity
verbosity
        (String
"Congratulations, all dependencies for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageIdentifier
pid) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> ComponentTarget -> String
showComponentTarget PackageIdentifier
pid ComponentTarget
tgt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" have upper bounds!")
    Just [PackageIdentifier]
pkgBounds -> do
      Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"For component " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageName -> String
forall a. Pretty a => a -> String
prettyShow (PackageIdentifier -> PackageName
pkgName PackageIdentifier
pid) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageIdentifier -> ComponentTarget -> String
showComponentTarget PackageIdentifier
pid ComponentTarget
tgt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
      let padTo :: Int
padTo = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (PackageIdentifier -> Int) -> [PackageIdentifier] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int)
-> (PackageIdentifier -> String) -> PackageIdentifier -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> String
unPackageName (PackageName -> String)
-> (PackageIdentifier -> PackageName)
-> PackageIdentifier
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName) [PackageIdentifier]
pkgBounds
      (PackageIdentifier -> IO ()) -> [PackageIdentifier] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Verbosity -> String -> IO ()
notice Verbosity
verbosity (String -> IO ())
-> (PackageIdentifier -> String) -> PackageIdentifier -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
",") (String -> String)
-> (PackageIdentifier -> String) -> PackageIdentifier -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> PackageIdentifier -> String
forall pkg. Package pkg => Int -> pkg -> String
showBounds Int
padTo) [PackageIdentifier]
pkgBounds

-- | Process a single BuildInfo to identify and report missing upper bounds
getBoundsForComponent
  :: ComponentTarget
  -> ElaboratedConfiguredPackage
  -> Map.Map ComponentId PackageIdentifier
  -> GenBoundsResult
getBoundsForComponent :: ComponentTarget
-> ElaboratedConfiguredPackage
-> Map ComponentId PackageIdentifier
-> GenBoundsResult
getBoundsForComponent ComponentTarget
tgt ElaboratedConfiguredPackage
pkg Map ComponentId PackageIdentifier
pkgVersionMap =
  if [PackageName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PackageName]
needBounds
    then Maybe [PackageIdentifier] -> GenBoundsResult
boundsResult Maybe [PackageIdentifier]
forall a. Maybe a
Nothing
    else -- All the things we depend on.

      let componentDeps :: [(ConfiguredId, Bool)]
componentDeps = ElaboratedConfiguredPackage -> [(ConfiguredId, Bool)]
elabLibDependencies ElaboratedConfiguredPackage
pkg
          -- Match these up to package names, this is a list of Package name to versions.
          -- Now just match that up with what the user wrote in the build-depends section.
          depsWithVersions :: [PackageIdentifier]
depsWithVersions = ((ConfiguredId, Bool) -> Maybe PackageIdentifier)
-> [(ConfiguredId, Bool)] -> [PackageIdentifier]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(ConfiguredId, Bool)
cid -> ComponentId
-> Map ComponentId PackageIdentifier -> Maybe PackageIdentifier
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (ConfiguredId -> ComponentId
confInstId (ConfiguredId -> ComponentId) -> ConfiguredId -> ComponentId
forall a b. (a -> b) -> a -> b
$ (ConfiguredId, Bool) -> ConfiguredId
forall a b. (a, b) -> a
fst (ConfiguredId, Bool)
cid) Map ComponentId PackageIdentifier
pkgVersionMap) [(ConfiguredId, Bool)]
componentDeps
          isNeeded :: PackageIdentifier -> Bool
isNeeded = [PackageName] -> PackageName -> Bool
forall a. Ord a => [a] -> a -> Bool
hasElem [PackageName]
needBounds (PackageName -> Bool)
-> (PackageIdentifier -> PackageName) -> PackageIdentifier -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageIdentifier -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName
       in Maybe [PackageIdentifier] -> GenBoundsResult
boundsResult ([PackageIdentifier] -> Maybe [PackageIdentifier]
forall a. a -> Maybe a
Just ((PackageIdentifier -> Bool)
-> [PackageIdentifier] -> [PackageIdentifier]
forall a. (a -> Bool) -> [a] -> [a]
filter PackageIdentifier -> Bool
isNeeded [PackageIdentifier]
depsWithVersions))
  where
    pd :: PackageDescription
pd = ElaboratedConfiguredPackage -> PackageDescription
elabPkgDescription ElaboratedConfiguredPackage
pkg
    -- Extract the build-depends for the right part of the cabal file.
    bi :: BuildInfo
bi = PackageDescription -> ComponentTarget -> BuildInfo
buildInfoForTarget PackageDescription
pd ComponentTarget
tgt

    -- We need to generate bounds if
    -- \* the dependency does not have an upper bound
    -- \* the dependency is not the same package as the one we are processing
    boundFilter :: Dependency -> Bool
boundFilter Dependency
dep =
      (Bool -> Bool
not (VersionRange -> Bool
hasUpperBound (Dependency -> VersionRange
depVerRange Dependency
dep)))
        Bool -> Bool -> Bool
&& PackageDescription -> PackageName
forall pkg. Package pkg => pkg -> PackageName
packageName PackageDescription
pd PackageName -> PackageName -> Bool
forall a. Eq a => a -> a -> Bool
/= Dependency -> PackageName
depPkgName Dependency
dep

    -- The dependencies that need bounds.
    needBounds :: [PackageName]
needBounds = (Dependency -> PackageName) -> [Dependency] -> [PackageName]
forall a b. (a -> b) -> [a] -> [b]
map Dependency -> PackageName
depPkgName ([Dependency] -> [PackageName]) -> [Dependency] -> [PackageName]
forall a b. (a -> b) -> a -> b
$ (Dependency -> Bool) -> [Dependency] -> [Dependency]
forall a. (a -> Bool) -> [a] -> [a]
filter Dependency -> Bool
boundFilter ([Dependency] -> [Dependency]) -> [Dependency] -> [Dependency]
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [Dependency]
targetBuildDepends BuildInfo
bi

    boundsResult :: Maybe [PackageIdentifier] -> GenBoundsResult
boundsResult = PackageIdentifier
-> ComponentTarget -> Maybe [PackageIdentifier] -> GenBoundsResult
GenBoundsResult (ElaboratedConfiguredPackage -> PackageIdentifier
forall pkg. Package pkg => pkg -> PackageIdentifier
packageId ElaboratedConfiguredPackage
pkg) ComponentTarget
tgt

buildInfoForTarget :: PackageDescription -> ComponentTarget -> BuildInfo
buildInfoForTarget :: PackageDescription -> ComponentTarget -> BuildInfo
buildInfoForTarget PackageDescription
pd (ComponentTarget ComponentName
cname SubComponentTarget
_) = Component -> BuildInfo
componentBuildInfo (Component -> BuildInfo) -> Component -> BuildInfo
forall a b. (a -> b) -> a -> b
$ PackageDescription -> ComponentName -> Component
getComponent PackageDescription
pd ComponentName
cname

-- | This defines what a 'TargetSelector' means for the @gen-bounds@ command.
-- Copy of selectPackageTargets from CmdBuild.hs
selectPackageTargets
  :: TargetSelector
  -> [AvailableTarget k]
  -> Either TargetProblem' [k]
selectPackageTargets :: forall k.
TargetSelector -> [AvailableTarget k] -> Either TargetProblem' [k]
selectPackageTargets TargetSelector
targetSelector [AvailableTarget k]
targets
  -- If there are any buildable targets then we select those
  | Bool -> Bool
not ([k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsBuildable) =
      [k] -> Either TargetProblem' [k]
forall a b. b -> Either a b
Right [k]
targetsBuildable
  -- If there are targets but none are buildable then we report those
  | Bool -> Bool
not ([AvailableTarget k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AvailableTarget k]
targets) =
      TargetProblem' -> Either TargetProblem' [k]
forall a b. a -> Either a b
Left (TargetSelector -> [AvailableTarget ()] -> TargetProblem'
forall a. TargetSelector -> [AvailableTarget ()] -> TargetProblem a
TargetProblemNoneEnabled TargetSelector
targetSelector [AvailableTarget ()]
targets')
  -- If there are no targets at all then we report that
  | Bool
otherwise =
      TargetProblem' -> Either TargetProblem' [k]
forall a b. a -> Either a b
Left (TargetSelector -> TargetProblem'
forall a. TargetSelector -> TargetProblem a
TargetProblemNoTargets TargetSelector
targetSelector)
  where
    targets' :: [AvailableTarget ()]
targets' = [AvailableTarget k] -> [AvailableTarget ()]
forall k. [AvailableTarget k] -> [AvailableTarget ()]
forgetTargetsDetail [AvailableTarget k]
targets
    targetsBuildable :: [k]
targetsBuildable =
      (TargetRequested -> Bool) -> [AvailableTarget k] -> [k]
forall k. (TargetRequested -> Bool) -> [AvailableTarget k] -> [k]
selectBuildableTargetsWith
        (TargetSelector -> TargetRequested -> Bool
buildable TargetSelector
targetSelector)
        [AvailableTarget k]
targets

    -- When there's a target filter like "pkg:tests" then we do select tests,
    -- but if it's just a target like "pkg" then we don't build tests unless
    -- they are requested by default (i.e. by using --enable-tests)
    buildable :: TargetSelector -> TargetRequested -> Bool
buildable (TargetPackage TargetImplicitCwd
_ [PackageIdentifier]
_ Maybe ComponentKind
Nothing) TargetRequested
TargetNotRequestedByDefault = Bool
False
    buildable (TargetAllPackages Maybe ComponentKind
Nothing) TargetRequested
TargetNotRequestedByDefault = Bool
False
    buildable TargetSelector
_ TargetRequested
_ = Bool
True

-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected. Copy of selectComponentTarget from CmdBuild.hs
selectComponentTarget
  :: SubComponentTarget
  -> AvailableTarget k
  -> Either TargetProblem' k
selectComponentTarget :: forall k.
SubComponentTarget -> AvailableTarget k -> Either TargetProblem' k
selectComponentTarget = SubComponentTarget -> AvailableTarget k -> Either TargetProblem' k
forall k a.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem a) k
selectComponentTargetBasic

-- | Report target problems for gen-bounds command
reportGenBoundsTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
reportGenBoundsTargetProblems :: forall a. Verbosity -> [TargetProblem'] -> IO a
reportGenBoundsTargetProblems Verbosity
verbosity [TargetProblem']
problems =
  Verbosity -> String -> [TargetProblem'] -> IO a
forall a. Verbosity -> String -> [TargetProblem'] -> IO a
reportTargetProblems Verbosity
verbosity String
"gen-bounds" [TargetProblem']
problems