{-# LANGUAGE MultiWayIf        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TupleSections     #-}
module Distribution.Client.CmdListBin (
    listbinCommand,
    listbinAction,

    -- * Internals exposed for testing
    selectPackageTargets,
    selectComponentTarget,
    noComponentsProblem,
    matchesMultipleProblem,
    multipleTargetsProblem,
    componentNotRightKindProblem
) where

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

import Distribution.Client.CmdErrorMessages
       (plural, renderListCommaAnd, renderTargetProblem, renderTargetProblemNoTargets,
       renderTargetSelector, showTargetSelector, targetSelectorFilter, targetSelectorPluralPkgs)
import Distribution.Client.DistDirLayout         (DistDirLayout (..))
import Distribution.Client.NixStyleOptions
       (NixStyleFlags (..), defaultNixStyleFlags, nixStyleOptions)
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning.Types
import Distribution.Client.ScriptUtils
       (AcceptNoTargets(..), TargetContext(..), updateContextAndWriteProjectFile, withContextAndSelectors)
import Distribution.Client.Setup                 (GlobalFlags (..))
import Distribution.Client.TargetProblem         (TargetProblem (..))
import Distribution.Simple.BuildPaths            (dllExtension, exeExtension)
import Distribution.Simple.Command               (CommandUI (..))
import Distribution.Simple.Setup                 (configVerbosity, fromFlagOrDefault)
import Distribution.Simple.Utils                 (die', wrapText)
import Distribution.System                       (Platform)
import Distribution.Types.ComponentName          (showComponentName)
import Distribution.Types.UnitId                 (UnitId)
import Distribution.Types.UnqualComponentName    (UnqualComponentName)
import Distribution.Verbosity                    (silent, verboseStderr)
import System.FilePath                           ((<.>), (</>))

import qualified Data.Map                                as Map
import qualified Data.Set                                as Set
import qualified Distribution.Client.InstallPlan         as IP
import qualified Distribution.Simple.InstallDirs         as InstallDirs
import qualified Distribution.Solver.Types.ComponentDeps as CD

-------------------------------------------------------------------------------
-- Command
-------------------------------------------------------------------------------

listbinCommand :: CommandUI (NixStyleFlags ())
listbinCommand :: CommandUI (NixStyleFlags ())
listbinCommand = CommandUI :: forall flags.
String
-> String
-> (String -> String)
-> Maybe (String -> String)
-> Maybe (String -> String)
-> flags
-> (ShowOrParseArgs -> [OptionField flags])
-> CommandUI flags
CommandUI
    { commandName :: String
commandName = String
"list-bin"
    , commandSynopsis :: String
commandSynopsis = String
"List the path to a single executable."
    , commandUsage :: String -> String
commandUsage = \String
pname ->
        String
"Usage: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
pname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" list-bin [FLAGS] TARGET\n"
    , 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 -> String
wrapText
        String
"List the path to a build product."
    , commandNotes :: Maybe (String -> String)
commandNotes = Maybe (String -> String)
forall a. Maybe a
Nothing
    , commandDefaultFlags :: NixStyleFlags ()
commandDefaultFlags = () -> NixStyleFlags ()
forall a. a -> NixStyleFlags a
defaultNixStyleFlags ()
    , commandOptions :: ShowOrParseArgs -> [OptionField (NixStyleFlags ())]
commandOptions      = (ShowOrParseArgs -> [OptionField ()])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags ())]
forall a.
(ShowOrParseArgs -> [OptionField a])
-> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
nixStyleOptions ([OptionField ()] -> ShowOrParseArgs -> [OptionField ()]
forall a b. a -> b -> a
const [])
    }

-------------------------------------------------------------------------------
-- Action
-------------------------------------------------------------------------------

listbinAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
listbinAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
listbinAction flags :: NixStyleFlags ()
flags@NixStyleFlags{()
ConfigFlags
HaddockFlags
TestFlags
BenchmarkFlags
ProjectFlags
InstallFlags
ConfigExFlags
extraFlags :: forall a. NixStyleFlags a -> a
projectFlags :: forall a. NixStyleFlags a -> ProjectFlags
benchmarkFlags :: forall a. NixStyleFlags a -> BenchmarkFlags
testFlags :: forall a. NixStyleFlags a -> TestFlags
haddockFlags :: forall a. NixStyleFlags a -> HaddockFlags
installFlags :: forall a. NixStyleFlags a -> InstallFlags
configExFlags :: forall a. NixStyleFlags a -> ConfigExFlags
configFlags :: forall a. NixStyleFlags a -> ConfigFlags
extraFlags :: ()
projectFlags :: ProjectFlags
benchmarkFlags :: BenchmarkFlags
testFlags :: TestFlags
haddockFlags :: HaddockFlags
installFlags :: InstallFlags
configExFlags :: ConfigExFlags
configFlags :: ConfigFlags
..} [String]
args GlobalFlags
globalFlags = do
  -- fail early if multiple target selectors specified
  String
target <- case [String]
args of
      []  -> Verbosity -> String -> IO String
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"One target is required, none provided"
      [String
x] -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
x
      [String]
_   -> Verbosity -> String -> IO String
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"One target is required, given multiple"

  -- configure and elaborate target selectors
  AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags ()
-> [String]
-> GlobalFlags
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO ())
-> IO ()
forall a b.
AcceptNoTargets
-> Maybe ComponentKind
-> NixStyleFlags a
-> [String]
-> GlobalFlags
-> (TargetContext
    -> ProjectBaseContext -> [TargetSelector] -> IO b)
-> IO b
withContextAndSelectors AcceptNoTargets
RejectNoTargets (ComponentKind -> Maybe ComponentKind
forall a. a -> Maybe a
Just ComponentKind
ExeKind) NixStyleFlags ()
flags [String
target] GlobalFlags
globalFlags ((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 (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext
ctx
      TargetContext
GlobalContext              -> ProjectBaseContext -> IO ProjectBaseContext
forall (m :: * -> *) a. Monad m => a -> m a
return ProjectBaseContext
ctx
      ScriptContext String
path Executable
exemeta -> ProjectBaseContext -> String -> Executable -> IO ProjectBaseContext
updateContextAndWriteProjectFile ProjectBaseContext
ctx String
path Executable
exemeta

    ProjectBuildContext
buildCtx <-
      Verbosity
-> ProjectBaseContext
-> (ElaboratedInstallPlan
    -> IO (ElaboratedInstallPlan, TargetsMap))
-> IO ProjectBuildContext
runProjectPreBuildPhase Verbosity
verbosity ProjectBaseContext
baseCtx ((ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap))
 -> IO ProjectBuildContext)
-> (ElaboratedInstallPlan
    -> IO (ElaboratedInstallPlan, TargetsMap))
-> IO ProjectBuildContext
forall a b. (a -> b) -> a -> b
$ \ElaboratedInstallPlan
elaboratedPlan -> do
            -- Interpret the targets on the command line as build targets
            -- (as opposed to say repl or haddock targets).
            TargetsMap
targets <- ([ListBinTargetProblem] -> IO TargetsMap)
-> (TargetsMap -> IO TargetsMap)
-> Either [ListBinTargetProblem] TargetsMap
-> IO TargetsMap
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Verbosity -> [ListBinTargetProblem] -> IO TargetsMap
forall a. Verbosity -> [ListBinTargetProblem] -> IO a
reportTargetProblems Verbosity
verbosity) TargetsMap -> IO TargetsMap
forall (m :: * -> *) a. Monad m => a -> m a
return
                     (Either [ListBinTargetProblem] TargetsMap -> IO TargetsMap)
-> Either [ListBinTargetProblem] TargetsMap -> IO TargetsMap
forall a b. (a -> b) -> a -> b
$ (forall k.
 TargetSelector
 -> [AvailableTarget k] -> Either ListBinTargetProblem [k])
-> (forall k.
    SubComponentTarget
    -> AvailableTarget k -> Either ListBinTargetProblem k)
-> ElaboratedInstallPlan
-> Maybe SourcePackageDb
-> [TargetSelector]
-> Either [ListBinTargetProblem] 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
resolveTargets
                         forall k.
TargetSelector
-> [AvailableTarget k] -> Either ListBinTargetProblem [k]
selectPackageTargets
                         forall k.
SubComponentTarget
-> AvailableTarget k -> Either ListBinTargetProblem k
selectComponentTarget
                         ElaboratedInstallPlan
elaboratedPlan
                         Maybe SourcePackageDb
forall a. Maybe a
Nothing
                         [TargetSelector]
targetSelectors

            -- Reject multiple targets, or at least targets in different
            -- components. It is ok to have two module/file targets in the
            -- same component, but not two that live in different components.
            --
            -- Note that we discard the target and return the whole 'TargetsMap',
            -- so this check will be repeated (and must succeed) after
            -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this.
            (UnitId, UnqualComponentName)
_ <- IO (UnitId, UnqualComponentName)
-> TargetsMap -> IO (UnitId, UnqualComponentName)
singleComponentOrElse
                   (Verbosity
-> [ListBinTargetProblem] -> IO (UnitId, UnqualComponentName)
forall a. Verbosity -> [ListBinTargetProblem] -> IO a
reportTargetProblems
                      Verbosity
verbosity
                      [TargetsMap -> ListBinTargetProblem
multipleTargetsProblem TargetsMap
targets])
                   TargetsMap
targets

            let elaboratedPlan' :: ElaboratedInstallPlan
elaboratedPlan' = TargetAction
-> TargetsMap -> ElaboratedInstallPlan -> ElaboratedInstallPlan
pruneInstallPlanToTargets
                                    TargetAction
TargetActionBuild
                                    TargetsMap
targets
                                    ElaboratedInstallPlan
elaboratedPlan
            (ElaboratedInstallPlan, TargetsMap)
-> IO (ElaboratedInstallPlan, TargetsMap)
forall (m :: * -> *) a. Monad m => a -> m a
return (ElaboratedInstallPlan
elaboratedPlan', TargetsMap
targets)

    (UnitId
selectedUnitId, UnqualComponentName
selectedComponent) <-
      -- Slight duplication with 'runProjectPreBuildPhase'.
      IO (UnitId, UnqualComponentName)
-> TargetsMap -> IO (UnitId, UnqualComponentName)
singleComponentOrElse
        (Verbosity -> String -> IO (UnitId, UnqualComponentName)
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO (UnitId, UnqualComponentName))
-> String -> IO (UnitId, UnqualComponentName)
forall a b. (a -> b) -> a -> b
$ String
"No or multiple targets given, but the run "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"phase has been reached. This is a bug.")
        (TargetsMap -> IO (UnitId, UnqualComponentName))
-> TargetsMap -> IO (UnitId, UnqualComponentName)
forall a b. (a -> b) -> a -> b
$ ProjectBuildContext -> TargetsMap
targetsMap ProjectBuildContext
buildCtx

    Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO ()
printPlan Verbosity
verbosity ProjectBaseContext
baseCtx ProjectBuildContext
buildCtx

    [String]
binfiles <- case UnitId
-> Map
     UnitId
     (GenericPlanPackage
        InstalledPackageInfo ElaboratedConfiguredPackage)
-> Maybe
     (GenericPlanPackage
        InstalledPackageInfo ElaboratedConfiguredPackage)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup UnitId
selectedUnitId (Map
   UnitId
   (GenericPlanPackage
      InstalledPackageInfo ElaboratedConfiguredPackage)
 -> Maybe
      (GenericPlanPackage
         InstalledPackageInfo ElaboratedConfiguredPackage))
-> Map
     UnitId
     (GenericPlanPackage
        InstalledPackageInfo ElaboratedConfiguredPackage)
-> Maybe
     (GenericPlanPackage
        InstalledPackageInfo ElaboratedConfiguredPackage)
forall a b. (a -> b) -> a -> b
$ ElaboratedInstallPlan
-> Map
     UnitId
     (GenericPlanPackage
        InstalledPackageInfo ElaboratedConfiguredPackage)
forall ipkg srcpkg.
GenericInstallPlan ipkg srcpkg
-> Map UnitId (GenericPlanPackage ipkg srcpkg)
IP.toMap (ProjectBuildContext -> ElaboratedInstallPlan
elaboratedPlanOriginal ProjectBuildContext
buildCtx) of
        Maybe
  (GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage)
Nothing  -> Verbosity -> String -> IO [String]
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"No or multiple targets given..."
        Just GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
gpp -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (InstalledPackageInfo -> [String])
-> (ElaboratedConfiguredPackage -> [String])
-> GenericPlanPackage
     InstalledPackageInfo ElaboratedConfiguredPackage
-> [String]
forall ipkg a srcpkg.
(ipkg -> a) -> (srcpkg -> a) -> GenericPlanPackage ipkg srcpkg -> a
IP.foldPlanPackage
            ([String] -> InstalledPackageInfo -> [String]
forall a b. a -> b -> a
const []) -- IPI don't have executables
            (DistDirLayout
-> ElaboratedSharedConfig
-> UnqualComponentName
-> ElaboratedConfiguredPackage
-> [String]
elaboratedPackage (ProjectBaseContext -> DistDirLayout
distDirLayout ProjectBaseContext
baseCtx) (ProjectBuildContext -> ElaboratedSharedConfig
elaboratedShared ProjectBuildContext
buildCtx) UnqualComponentName
selectedComponent)
            GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
gpp

    case [String]
binfiles of
        []     -> Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"No target found"
        [String
exe] -> String -> IO ()
putStrLn String
exe
        [String]
_ -> Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity String
"Multiple targets found"
  where
    defaultVerbosity :: Verbosity
defaultVerbosity = Verbosity -> Verbosity
verboseStderr Verbosity
silent
    verbosity :: Verbosity
verbosity = Verbosity -> Flag Verbosity -> Verbosity
forall a. a -> Flag a -> a
fromFlagOrDefault Verbosity
defaultVerbosity (ConfigFlags -> Flag Verbosity
configVerbosity ConfigFlags
configFlags)

    -- this is copied from
    elaboratedPackage
        :: DistDirLayout
        -> ElaboratedSharedConfig
        -> UnqualComponentName
        -> ElaboratedConfiguredPackage
        -> [FilePath]
    elaboratedPackage :: DistDirLayout
-> ElaboratedSharedConfig
-> UnqualComponentName
-> ElaboratedConfiguredPackage
-> [String]
elaboratedPackage DistDirLayout
distDirLayout ElaboratedSharedConfig
elaboratedSharedConfig UnqualComponentName
selectedComponent ElaboratedConfiguredPackage
elab = case ElaboratedConfiguredPackage -> ElaboratedPackageOrComponent
elabPkgOrComp ElaboratedConfiguredPackage
elab of
        ElabPackage ElaboratedPackage
pkg ->
            [ String
bin
            | (Component
c, ([ConfiguredId], [ConfiguredId])
_) <- ComponentDeps ([ConfiguredId], [ConfiguredId])
-> [(Component, ([ConfiguredId], [ConfiguredId]))]
forall a. ComponentDeps a -> [ComponentDep a]
CD.toList (ComponentDeps ([ConfiguredId], [ConfiguredId])
 -> [(Component, ([ConfiguredId], [ConfiguredId]))])
-> ComponentDeps ([ConfiguredId], [ConfiguredId])
-> [(Component, ([ConfiguredId], [ConfiguredId]))]
forall a b. (a -> b) -> a -> b
$ ComponentDeps [ConfiguredId]
-> ComponentDeps [ConfiguredId]
-> ComponentDeps ([ConfiguredId], [ConfiguredId])
forall a b.
(Monoid a, Monoid b) =>
ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b)
CD.zip (ElaboratedPackage -> ComponentDeps [ConfiguredId]
pkgLibDependencies ElaboratedPackage
pkg)
                                           (ElaboratedPackage -> ComponentDeps [ConfiguredId]
pkgExeDependencies ElaboratedPackage
pkg)
            , String
bin <- Component -> [String]
bin_file Component
c
            ]
        ElabComponent ElaboratedComponent
comp -> Component -> [String]
bin_file (ElaboratedComponent -> Component
compSolverName ElaboratedComponent
comp)
      where
        dist_dir :: String
dist_dir = DistDirLayout -> DistDirParams -> String
distBuildDirectory DistDirLayout
distDirLayout (ElaboratedSharedConfig
-> ElaboratedConfiguredPackage -> DistDirParams
elabDistDirParams ElaboratedSharedConfig
elaboratedSharedConfig ElaboratedConfiguredPackage
elab)

        bin_file :: Component -> [String]
bin_file Component
c = case Component
c of
            CD.ComponentExe UnqualComponentName
s
               | UnqualComponentName
s UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== UnqualComponentName
selectedComponent -> [UnqualComponentName -> String
forall a. Pretty a => a -> String
bin_file' UnqualComponentName
s]
            CD.ComponentTest UnqualComponentName
s
               | UnqualComponentName
s UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== UnqualComponentName
selectedComponent -> [UnqualComponentName -> String
forall a. Pretty a => a -> String
bin_file' UnqualComponentName
s]
            CD.ComponentBench UnqualComponentName
s
               | UnqualComponentName
s UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== UnqualComponentName
selectedComponent -> [UnqualComponentName -> String
forall a. Pretty a => a -> String
bin_file' UnqualComponentName
s]
            CD.ComponentFLib UnqualComponentName
s
               | UnqualComponentName
s UnqualComponentName -> UnqualComponentName -> Bool
forall a. Eq a => a -> a -> Bool
== UnqualComponentName
selectedComponent -> [UnqualComponentName -> String
forall a. Pretty a => a -> String
flib_file' UnqualComponentName
s]
            Component
_ -> []

        plat :: Platform
        plat :: Platform
plat = ElaboratedSharedConfig -> Platform
pkgConfigPlatform ElaboratedSharedConfig
elaboratedSharedConfig

        -- here and in PlanOutput,
        -- use binDirectoryFor?
        bin_file' :: a -> String
bin_file' a
s =
            if ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
elab BuildStyle -> BuildStyle -> Bool
forall a. Eq a => a -> a -> Bool
== BuildStyle
BuildInplaceOnly
            then String
dist_dir String -> String -> String
</> String
"build" String -> String -> String
</> a -> String
forall a. Pretty a => a -> String
prettyShow a
s String -> String -> String
</> a -> String
forall a. Pretty a => a -> String
prettyShow a
s String -> String -> String
<.> Platform -> String
exeExtension Platform
plat
            else InstallDirs String -> String
forall dir. InstallDirs dir -> dir
InstallDirs.bindir (ElaboratedConfiguredPackage -> InstallDirs String
elabInstallDirs ElaboratedConfiguredPackage
elab) String -> String -> String
</> a -> String
forall a. Pretty a => a -> String
prettyShow a
s String -> String -> String
<.> Platform -> String
exeExtension Platform
plat

        flib_file' :: a -> String
flib_file' a
s =
            if ElaboratedConfiguredPackage -> BuildStyle
elabBuildStyle ElaboratedConfiguredPackage
elab BuildStyle -> BuildStyle -> Bool
forall a. Eq a => a -> a -> Bool
== BuildStyle
BuildInplaceOnly
            then String
dist_dir String -> String -> String
</> String
"build" String -> String -> String
</> a -> String
forall a. Pretty a => a -> String
prettyShow a
s String -> String -> String
</> (String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Pretty a => a -> String
prettyShow a
s) String -> String -> String
<.> Platform -> String
dllExtension Platform
plat
            else InstallDirs String -> String
forall dir. InstallDirs dir -> dir
InstallDirs.bindir (ElaboratedConfiguredPackage -> InstallDirs String
elabInstallDirs ElaboratedConfiguredPackage
elab) String -> String -> String
</> (String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Pretty a => a -> String
prettyShow a
s) String -> String -> String
<.> Platform -> String
dllExtension Platform
plat

-------------------------------------------------------------------------------
-- Target Problem: the very similar to CmdRun
-------------------------------------------------------------------------------

singleComponentOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName)
singleComponentOrElse :: IO (UnitId, UnqualComponentName)
-> TargetsMap -> IO (UnitId, UnqualComponentName)
singleComponentOrElse IO (UnitId, UnqualComponentName)
action TargetsMap
targetsMap =
  case Set (UnitId, ComponentName) -> [(UnitId, ComponentName)]
forall a. Set a -> [a]
Set.toList (Set (UnitId, ComponentName) -> [(UnitId, ComponentName)])
-> (TargetsMap -> Set (UnitId, ComponentName))
-> TargetsMap
-> [(UnitId, ComponentName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetsMap -> Set (UnitId, ComponentName)
distinctTargetComponents (TargetsMap -> [(UnitId, ComponentName)])
-> TargetsMap -> [(UnitId, ComponentName)]
forall a b. (a -> b) -> a -> b
$ TargetsMap
targetsMap
  of [(UnitId
unitId, CExeName UnqualComponentName
component)] -> (UnitId, UnqualComponentName) -> IO (UnitId, UnqualComponentName)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitId
unitId, UnqualComponentName
component)
     [(UnitId
unitId, CTestName UnqualComponentName
component)] -> (UnitId, UnqualComponentName) -> IO (UnitId, UnqualComponentName)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitId
unitId, UnqualComponentName
component)
     [(UnitId
unitId, CBenchName UnqualComponentName
component)] -> (UnitId, UnqualComponentName) -> IO (UnitId, UnqualComponentName)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitId
unitId, UnqualComponentName
component)
     [(UnitId
unitId, CFLibName UnqualComponentName
component)] -> (UnitId, UnqualComponentName) -> IO (UnitId, UnqualComponentName)
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitId
unitId, UnqualComponentName
component)
     [(UnitId, ComponentName)]
_   -> IO (UnitId, UnqualComponentName)
action

-- | This defines what a 'TargetSelector' means for the @list-bin@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
-- or otherwise classifies the problem.
--
-- For the @list-bin@ command we select the exe or flib if there is only one
-- and it's buildable. Fail if there are no or multiple buildable exe components.
--
selectPackageTargets :: TargetSelector
                     -> [AvailableTarget k] -> Either ListBinTargetProblem [k]
selectPackageTargets :: TargetSelector
-> [AvailableTarget k] -> Either ListBinTargetProblem [k]
selectPackageTargets TargetSelector
targetSelector [AvailableTarget k]
targets

  -- If there is a single executable component, select that. See #7403
  | [k
target] <- [k]
targetsExesBuildable
  = [k] -> Either ListBinTargetProblem [k]
forall a b. b -> Either a b
Right [k
target]

  -- Otherwise, if there is a single executable-like component left, select that.
  | [k
target] <- [k]
targetsExeLikesBuildable
  = [k] -> Either ListBinTargetProblem [k]
forall a b. b -> Either a b
Right [k
target]

    -- but fail if there are multiple buildable executables.
  | Bool -> Bool
not ([k] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [k]
targetsExeLikesBuildable)
  = ListBinTargetProblem -> Either ListBinTargetProblem [k]
forall a b. a -> Either a b
Left (TargetSelector -> [AvailableTarget ()] -> ListBinTargetProblem
matchesMultipleProblem TargetSelector
targetSelector [AvailableTarget ()]
targetsExeLikesBuildable')

    -- If there are executables but none are buildable then we report those
  | Bool -> Bool
not ([AvailableTarget ()] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AvailableTarget ()]
targetsExeLikes')
  = ListBinTargetProblem -> Either ListBinTargetProblem [k]
forall a b. a -> Either a b
Left (TargetSelector -> [AvailableTarget ()] -> ListBinTargetProblem
forall a. TargetSelector -> [AvailableTarget ()] -> TargetProblem a
TargetProblemNoneEnabled TargetSelector
targetSelector [AvailableTarget ()]
targetsExeLikes')

    -- If there are no executables but some other targets then we report that
  | Bool -> Bool
not ([AvailableTarget k] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AvailableTarget k]
targets)
  = ListBinTargetProblem -> Either ListBinTargetProblem [k]
forall a b. a -> Either a b
Left (TargetSelector -> ListBinTargetProblem
noComponentsProblem TargetSelector
targetSelector)

    -- If there are no targets at all then we report that
  | Bool
otherwise
  = ListBinTargetProblem -> Either ListBinTargetProblem [k]
forall a b. a -> Either a b
Left (TargetSelector -> ListBinTargetProblem
forall a. TargetSelector -> TargetProblem a
TargetProblemNoTargets TargetSelector
targetSelector)
  where
    -- Targets that are precisely executables
    targetsExes :: [AvailableTarget k]
targetsExes = ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
forall k.
ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind ComponentKind
ExeKind [AvailableTarget k]
targets
    targetsExesBuildable :: [k]
targetsExesBuildable = [AvailableTarget k] -> [k]
forall k. [AvailableTarget k] -> [k]
selectBuildableTargets [AvailableTarget k]
targetsExes

    -- Any target that could be executed
    targetsExeLikes :: [AvailableTarget k]
targetsExeLikes = [AvailableTarget k]
targetsExes
                   [AvailableTarget k] -> [AvailableTarget k] -> [AvailableTarget k]
forall a. [a] -> [a] -> [a]
++ ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
forall k.
ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind ComponentKind
TestKind [AvailableTarget k]
targets
                   [AvailableTarget k] -> [AvailableTarget k] -> [AvailableTarget k]
forall a. [a] -> [a] -> [a]
++ ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
forall k.
ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind ComponentKind
BenchKind [AvailableTarget k]
targets

    ([k]
targetsExeLikesBuildable,
     [AvailableTarget ()]
targetsExeLikesBuildable') = [AvailableTarget k] -> ([k], [AvailableTarget ()])
forall k. [AvailableTarget k] -> ([k], [AvailableTarget ()])
selectBuildableTargets' [AvailableTarget k]
targetsExeLikes

    targetsExeLikes' :: [AvailableTarget ()]
targetsExeLikes'             = [AvailableTarget k] -> [AvailableTarget ()]
forall k. [AvailableTarget k] -> [AvailableTarget ()]
forgetTargetsDetail [AvailableTarget k]
targetsExeLikes


-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
--
-- For the @run@ command we just need to check it is a executable-like
-- (an executable, a test, or a benchmark), in addition
-- to the basic checks on being buildable etc.
--
selectComponentTarget :: SubComponentTarget
                      -> AvailableTarget k -> Either ListBinTargetProblem  k
selectComponentTarget :: SubComponentTarget
-> AvailableTarget k -> Either ListBinTargetProblem k
selectComponentTarget subtarget :: SubComponentTarget
subtarget@SubComponentTarget
WholeComponent AvailableTarget k
t
  = case AvailableTarget k -> ComponentName
forall k. AvailableTarget k -> ComponentName
availableTargetComponentName AvailableTarget k
t
    of CExeName UnqualComponentName
_ -> Either ListBinTargetProblem k
forall a. Either (TargetProblem a) k
component
       CTestName UnqualComponentName
_ -> Either ListBinTargetProblem k
forall a. Either (TargetProblem a) k
component
       CBenchName UnqualComponentName
_ -> Either ListBinTargetProblem k
forall a. Either (TargetProblem a) k
component
       CFLibName UnqualComponentName
_ -> Either ListBinTargetProblem k
forall a. Either (TargetProblem a) k
component
       ComponentName
_ -> ListBinTargetProblem -> Either ListBinTargetProblem k
forall a b. a -> Either a b
Left (PackageId -> ComponentName -> ListBinTargetProblem
componentNotRightKindProblem PackageId
pkgid ComponentName
cname)
    where pkgid :: PackageId
pkgid = AvailableTarget k -> PackageId
forall k. AvailableTarget k -> PackageId
availableTargetPackageId AvailableTarget k
t
          cname :: ComponentName
cname = AvailableTarget k -> ComponentName
forall k. AvailableTarget k -> ComponentName
availableTargetComponentName AvailableTarget k
t
          component :: Either (TargetProblem a) k
component = SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem a) k
forall k a.
SubComponentTarget
-> AvailableTarget k -> Either (TargetProblem a) k
selectComponentTargetBasic SubComponentTarget
subtarget AvailableTarget k
t

selectComponentTarget SubComponentTarget
subtarget AvailableTarget k
t
  = ListBinTargetProblem -> Either ListBinTargetProblem k
forall a b. a -> Either a b
Left (PackageId
-> ComponentName -> SubComponentTarget -> ListBinTargetProblem
isSubComponentProblem (AvailableTarget k -> PackageId
forall k. AvailableTarget k -> PackageId
availableTargetPackageId AvailableTarget k
t)
           (AvailableTarget k -> ComponentName
forall k. AvailableTarget k -> ComponentName
availableTargetComponentName AvailableTarget k
t)
           SubComponentTarget
subtarget)

-- | The various error conditions that can occur when matching a
-- 'TargetSelector' against 'AvailableTarget's for the @run@ command.
--
data ListBinProblem =
     -- | The 'TargetSelector' matches targets but no executables
     TargetProblemNoRightComps      TargetSelector

     -- | A single 'TargetSelector' matches multiple targets
   | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]

     -- | Multiple 'TargetSelector's match multiple targets
   | TargetProblemMultipleTargets TargetsMap

     -- | The 'TargetSelector' refers to a component that is not an executable
   | TargetProblemComponentNotRightKind PackageId ComponentName

     -- | Asking to run an individual file or module is not supported
   | TargetProblemIsSubComponent  PackageId ComponentName SubComponentTarget
  deriving (ListBinProblem -> ListBinProblem -> Bool
(ListBinProblem -> ListBinProblem -> Bool)
-> (ListBinProblem -> ListBinProblem -> Bool) -> Eq ListBinProblem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ListBinProblem -> ListBinProblem -> Bool
$c/= :: ListBinProblem -> ListBinProblem -> Bool
== :: ListBinProblem -> ListBinProblem -> Bool
$c== :: ListBinProblem -> ListBinProblem -> Bool
Eq, Int -> ListBinProblem -> String -> String
[ListBinProblem] -> String -> String
ListBinProblem -> String
(Int -> ListBinProblem -> String -> String)
-> (ListBinProblem -> String)
-> ([ListBinProblem] -> String -> String)
-> Show ListBinProblem
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [ListBinProblem] -> String -> String
$cshowList :: [ListBinProblem] -> String -> String
show :: ListBinProblem -> String
$cshow :: ListBinProblem -> String
showsPrec :: Int -> ListBinProblem -> String -> String
$cshowsPrec :: Int -> ListBinProblem -> String -> String
Show)

type ListBinTargetProblem = TargetProblem ListBinProblem

noComponentsProblem :: TargetSelector -> ListBinTargetProblem
noComponentsProblem :: TargetSelector -> ListBinTargetProblem
noComponentsProblem = ListBinProblem -> ListBinTargetProblem
forall a. a -> TargetProblem a
CustomTargetProblem (ListBinProblem -> ListBinTargetProblem)
-> (TargetSelector -> ListBinProblem)
-> TargetSelector
-> ListBinTargetProblem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetSelector -> ListBinProblem
TargetProblemNoRightComps

matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> ListBinTargetProblem
matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> ListBinTargetProblem
matchesMultipleProblem TargetSelector
selector [AvailableTarget ()]
targets = ListBinProblem -> ListBinTargetProblem
forall a. a -> TargetProblem a
CustomTargetProblem (ListBinProblem -> ListBinTargetProblem)
-> ListBinProblem -> ListBinTargetProblem
forall a b. (a -> b) -> a -> b
$
    TargetSelector -> [AvailableTarget ()] -> ListBinProblem
TargetProblemMatchesMultiple TargetSelector
selector [AvailableTarget ()]
targets

multipleTargetsProblem :: TargetsMap -> TargetProblem ListBinProblem
multipleTargetsProblem :: TargetsMap -> ListBinTargetProblem
multipleTargetsProblem = ListBinProblem -> ListBinTargetProblem
forall a. a -> TargetProblem a
CustomTargetProblem (ListBinProblem -> ListBinTargetProblem)
-> (TargetsMap -> ListBinProblem)
-> TargetsMap
-> ListBinTargetProblem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TargetsMap -> ListBinProblem
TargetProblemMultipleTargets

componentNotRightKindProblem :: PackageId -> ComponentName -> TargetProblem ListBinProblem
componentNotRightKindProblem :: PackageId -> ComponentName -> ListBinTargetProblem
componentNotRightKindProblem PackageId
pkgid ComponentName
name = ListBinProblem -> ListBinTargetProblem
forall a. a -> TargetProblem a
CustomTargetProblem (ListBinProblem -> ListBinTargetProblem)
-> ListBinProblem -> ListBinTargetProblem
forall a b. (a -> b) -> a -> b
$
    PackageId -> ComponentName -> ListBinProblem
TargetProblemComponentNotRightKind PackageId
pkgid ComponentName
name

isSubComponentProblem
  :: PackageId
  -> ComponentName
  -> SubComponentTarget
  -> TargetProblem ListBinProblem
isSubComponentProblem :: PackageId
-> ComponentName -> SubComponentTarget -> ListBinTargetProblem
isSubComponentProblem PackageId
pkgid ComponentName
name SubComponentTarget
subcomponent = ListBinProblem -> ListBinTargetProblem
forall a. a -> TargetProblem a
CustomTargetProblem (ListBinProblem -> ListBinTargetProblem)
-> ListBinProblem -> ListBinTargetProblem
forall a b. (a -> b) -> a -> b
$
    PackageId -> ComponentName -> SubComponentTarget -> ListBinProblem
TargetProblemIsSubComponent PackageId
pkgid ComponentName
name SubComponentTarget
subcomponent

reportTargetProblems :: Verbosity -> [ListBinTargetProblem] -> IO a
reportTargetProblems :: Verbosity -> [ListBinTargetProblem] -> IO a
reportTargetProblems Verbosity
verbosity =
    Verbosity -> String -> IO a
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO a)
-> ([ListBinTargetProblem] -> String)
-> [ListBinTargetProblem]
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String)
-> ([ListBinTargetProblem] -> [String])
-> [ListBinTargetProblem]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ListBinTargetProblem -> String)
-> [ListBinTargetProblem] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ListBinTargetProblem -> String
renderListBinTargetProblem

renderListBinTargetProblem :: ListBinTargetProblem -> String
renderListBinTargetProblem :: ListBinTargetProblem -> String
renderListBinTargetProblem (TargetProblemNoTargets TargetSelector
targetSelector) =
    case TargetSelector -> Maybe ComponentKind
targetSelectorFilter TargetSelector
targetSelector of
      Just ComponentKind
kind | ComponentKind
kind ComponentKind -> ComponentKind -> Bool
forall a. Eq a => a -> a -> Bool
/= ComponentKind
ExeKind
        -> String
"The list-bin command is for finding binaries, but the target '"
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
showTargetSelector TargetSelector
targetSelector String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' refers to "
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
renderTargetSelector TargetSelector
targetSelector String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."

      Maybe ComponentKind
_ -> String -> TargetSelector -> String
renderTargetProblemNoTargets String
"list-bin" TargetSelector
targetSelector
renderListBinTargetProblem ListBinTargetProblem
problem =
    String
-> (ListBinProblem -> String) -> ListBinTargetProblem -> String
forall a. String -> (a -> String) -> TargetProblem a -> String
renderTargetProblem String
"list-bin" ListBinProblem -> String
renderListBinProblem ListBinTargetProblem
problem

renderListBinProblem :: ListBinProblem -> String
renderListBinProblem :: ListBinProblem -> String
renderListBinProblem (TargetProblemMatchesMultiple TargetSelector
targetSelector [AvailableTarget ()]
targets) =
    String
"The list-bin command is for finding a single binary at once. The target '"
 String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
showTargetSelector TargetSelector
targetSelector String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' refers to "
 String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
renderTargetSelector TargetSelector
targetSelector String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" which includes "
 String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
renderListCommaAnd ( (String
"the "String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (ComponentName -> String) -> ComponentName -> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                         ComponentName -> String
showComponentName (ComponentName -> String)
-> (AvailableTarget () -> ComponentName)
-> AvailableTarget ()
-> String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                         AvailableTarget () -> ComponentName
forall k. AvailableTarget k -> ComponentName
availableTargetComponentName (AvailableTarget () -> String) -> [AvailableTarget ()] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                         (ComponentKind -> [AvailableTarget ()])
-> [ComponentKind] -> [AvailableTarget ()]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
                           (\ComponentKind
kind -> ComponentKind -> [AvailableTarget ()] -> [AvailableTarget ()]
forall k.
ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind ComponentKind
kind [AvailableTarget ()]
targets)
                           [ComponentKind
ExeKind, ComponentKind
TestKind, ComponentKind
BenchKind] )
 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."

renderListBinProblem (TargetProblemMultipleTargets TargetsMap
selectorMap) =
    String
"The list-bin command is for finding a single binary at once. The targets "
 String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
renderListCommaAnd [ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
showTargetSelector TargetSelector
ts String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"
                       | TargetSelector
ts <- TargetsMap -> [TargetSelector]
uniqueTargetSelectors TargetsMap
selectorMap ]
 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" refer to different executables."

renderListBinProblem (TargetProblemComponentNotRightKind PackageId
pkgid ComponentName
cname) =
    String
"The list-bin command is for finding binaries, but the target '"
 String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
showTargetSelector TargetSelector
targetSelector String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' refers to "
 String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
renderTargetSelector TargetSelector
targetSelector String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" from the package "
 String -> String -> String
forall a. [a] -> [a] -> [a]
++ PackageId -> String
forall a. Pretty a => a -> String
prettyShow PackageId
pkgid String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
  where
    targetSelector :: TargetSelector
targetSelector = PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent PackageId
pkgid ComponentName
cname SubComponentTarget
WholeComponent

renderListBinProblem (TargetProblemIsSubComponent PackageId
pkgid ComponentName
cname SubComponentTarget
subtarget) =
    String
"The list-bin command can only find a binary as a whole, "
 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"not files or modules within them, but the target '"
 String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
showTargetSelector TargetSelector
targetSelector String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' refers to "
 String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
renderTargetSelector TargetSelector
targetSelector String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
  where
    targetSelector :: TargetSelector
targetSelector = PackageId -> ComponentName -> SubComponentTarget -> TargetSelector
TargetComponent PackageId
pkgid ComponentName
cname SubComponentTarget
subtarget

renderListBinProblem (TargetProblemNoRightComps TargetSelector
targetSelector) =
    String
"Cannot list-bin the target '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
showTargetSelector TargetSelector
targetSelector
 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' which refers to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ TargetSelector -> String
renderTargetSelector TargetSelector
targetSelector
 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" because "
 String -> String -> String
forall a. [a] -> [a] -> [a]
++ Plural -> String -> String -> String
forall a. Plural -> a -> a -> a
plural (TargetSelector -> Plural
targetSelectorPluralPkgs TargetSelector
targetSelector) String
"it does" String
"they do"
 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not contain any executables or foreign libraries."