cabal-install/src/Distribution/Client/CmdListBin.hs

   1 {-# LANGUAGE MultiWayIf #-}
   2 {-# LANGUAGE NamedFieldPuns #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE TupleSections #-}
   6
   7 module Distribution.Client.CmdListBin
   8   ( listbinCommand
   9   , listbinAction
  10
  11     -- * Internals exposed for testing
  12   , selectPackageTargets
  13   , selectComponentTarget
  14   , noComponentsProblem
  15   , matchesMultipleProblem
  16   , multipleTargetsProblem
  17   , componentNotRightKindProblem
  18   ) where
  19
  20 import Distribution.Client.Compat.Prelude
  21 import Prelude ()
  22
  23 import Distribution.Client.CmdErrorMessages
  24   ( plural
  25   , renderListCommaAnd
  26   , renderTargetProblem
  27   , renderTargetProblemNoTargets
  28   , renderTargetSelector
  29   , showTargetSelector
  30   , targetSelectorFilter
  31   , targetSelectorPluralPkgs
  32   )
  33 import Distribution.Client.DistDirLayout (DistDirLayout (..))
  34 import Distribution.Client.NixStyleOptions
  35   ( NixStyleFlags (..)
  36   , defaultNixStyleFlags
  37   , nixStyleOptions
  38   )
  39 import Distribution.Client.ProjectOrchestration
  40 import Distribution.Client.ProjectPlanning.Types
  41 import Distribution.Client.ScriptUtils
  42   ( AcceptNoTargets (..)
  43   , TargetContext (..)
  44   , movedExePath
  45   , updateContextAndWriteProjectFile
  46   , withContextAndSelectors
  47   )
  48 import Distribution.Client.Setup (GlobalFlags (..))
  49 import Distribution.Client.TargetProblem (TargetProblem (..))
  50 import Distribution.Simple.BuildPaths (dllExtension, exeExtension)
  51 import Distribution.Simple.Command (CommandUI (..))
  52 import Distribution.Simple.Setup (configCommonFlags, fromFlagOrDefault, setupVerbosity)
  53 import Distribution.Simple.Utils (dieWithException, withOutputMarker, wrapText)
  54 import Distribution.System (Platform)
  55 import Distribution.Types.ComponentName (showComponentName)
  56 import Distribution.Types.UnitId (UnitId)
  57 import Distribution.Types.UnqualComponentName (UnqualComponentName)
  58 import Distribution.Verbosity (silent, verboseStderr)
  59 import System.FilePath ((<.>), (</>))
  60
  61 import qualified Data.Map as Map
  62 import qualified Data.Set as Set
  63 import Distribution.Client.Errors
  64 import qualified Distribution.Client.InstallPlan as IP
  65 import qualified Distribution.Simple.InstallDirs as InstallDirs
  66 import qualified Distribution.Solver.Types.ComponentDeps as CD
  67
  68 -------------------------------------------------------------------------------
  69 -- Command
  70 -------------------------------------------------------------------------------
  71
  72 listbinCommand :: CommandUI (NixStyleFlags ())
  73 listbinCommand =
  74   CommandUI
  75     { commandName = "list-bin"
  76     , commandSynopsis = "List the path to a single executable."
  77     , commandUsage = \pname ->
  78         "Usage: " ++ pname ++ " list-bin [FLAGS] TARGET\n"
  79     , commandDescription = Just $ \_ ->
  80         wrapText
  81           "List the path to a build product."
  82     , commandNotes = Nothing
  83     , commandDefaultFlags = defaultNixStyleFlags ()
  84     , commandOptions = nixStyleOptions (const [])
  85     }
  86
  87 -------------------------------------------------------------------------------
  88 -- Action
  89 -------------------------------------------------------------------------------
  90
  91 listbinAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
  92 listbinAction flags@NixStyleFlags{..} args globalFlags = do
  93   -- fail early if multiple target selectors specified
  94   target <- case args of
  95     [] -> dieWithException verbosity NoTargetProvided
  96     [x] -> return x
  97     _ -> dieWithException verbosity OneTargetRequired
  98
  99   -- configure and elaborate target selectors
 100   withContextAndSelectors RejectNoTargets (Just ExeKind) flags [target] globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do
 101     baseCtx <- case targetCtx of
 102       ProjectContext -> return ctx
 103       GlobalContext -> return ctx
 104       ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta
 105
 106     buildCtx <-
 107       runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
 108         -- Interpret the targets on the command line as build targets
 109         -- (as opposed to say repl or haddock targets).
 110         targets <-
 111           either (reportTargetProblems verbosity) return $
 112             resolveTargets
 113               selectPackageTargets
 114               selectComponentTarget
 115               elaboratedPlan
 116               Nothing
 117               targetSelectors
 118
 119         -- Reject multiple targets, or at least targets in different
 120         -- components. It is ok to have two module/file targets in the
 121         -- same component, but not two that live in different components.
 122         --
 123         -- Note that we discard the target and return the whole 'TargetsMap',
 124         -- so this check will be repeated (and must succeed) after
 125         -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this.
 126         _ <-
 127           singleComponentOrElse
 128             ( reportTargetProblems
 129                 verbosity
 130                 [multipleTargetsProblem targets]
 131             )
 132             targets
 133
 134         let elaboratedPlan' =
 135               pruneInstallPlanToTargets
 136                 TargetActionBuild
 137                 targets
 138                 elaboratedPlan
 139         return (elaboratedPlan', targets)
 140
 141     (selectedUnitId, selectedComponent) <-
 142       -- Slight duplication with 'runProjectPreBuildPhase'.
 143       singleComponentOrElse
 144         ( dieWithException verbosity ThisIsABug
 145         )
 146         $ targetsMap buildCtx
 147
 148     printPlan verbosity baseCtx buildCtx
 149
 150     binfiles <- case Map.lookup selectedUnitId $ IP.toMap (elaboratedPlanOriginal buildCtx) of
 151       Nothing -> dieWithException verbosity NoOrMultipleTargetsGiven
 152       Just gpp ->
 153         return $
 154           IP.foldPlanPackage
 155             (const []) -- IPI don't have executables
 156             (elaboratedPackage (distDirLayout baseCtx) (elaboratedShared buildCtx) selectedComponent)
 157             gpp
 158
 159     case binfiles of
 160       [] -> dieWithException verbosity NoTargetFound
 161       [exe] -> putStr $ withOutputMarker verbosity $ exe ++ "\n"
 162       -- Andreas, 2023-01-13, issue #8400:
 163       -- Regular output of `list-bin` should go to stdout unconditionally,
 164       -- but for the sake of the testsuite, we want to mark it so it goes
 165       -- into the golden value for the test.
 166       -- Note: 'withOutputMarker' only checks 'isVerboseMarkOutput',
 167       -- thus, we can reuse @verbosity@ here, even if other components
 168       -- of @verbosity@ may be wrong (like 'VStderr', verbosity level etc.).
 169       -- Andreas, 2023-01-20:
 170       -- Appending the newline character here rather than using 'putStrLn'
 171       -- because an active 'withOutputMarker' produces text that ends
 172       -- in newline characters.
 173       _ -> dieWithException verbosity MultipleTargetsFound
 174   where
 175     defaultVerbosity = verboseStderr silent
 176     verbosity = fromFlagOrDefault defaultVerbosity (setupVerbosity $ configCommonFlags configFlags)
 177
 178     -- this is copied from
 179     elaboratedPackage
 180       :: DistDirLayout
 181       -> ElaboratedSharedConfig
 182       -> UnqualComponentName
 183       -> ElaboratedConfiguredPackage
 184       -> [FilePath]
 185     elaboratedPackage distDirLayout elaboratedSharedConfig selectedComponent elab = case elabPkgOrComp elab of
 186       ElabPackage pkg ->
 187         [ bin
 188         | (c, _) <-
 189             CD.toList $
 190               CD.zip
 191                 (pkgLibDependencies pkg)
 192                 (pkgExeDependencies pkg)
 193         , bin <- bin_file c
 194         ]
 195       ElabComponent comp -> bin_file (compSolverName comp)
 196       where
 197         dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elaboratedSharedConfig elab)
 198
 199         bin_file c = case c of
 200           CD.ComponentExe s
 201             | s == selectedComponent -> [moved_bin_file s]
 202           CD.ComponentTest s
 203             | s == selectedComponent -> [bin_file' s]
 204           CD.ComponentBench s
 205             | s == selectedComponent -> [bin_file' s]
 206           CD.ComponentFLib s
 207             | s == selectedComponent -> [flib_file' s]
 208           _ -> []
 209
 210         plat :: Platform
 211         plat = pkgConfigPlatform elaboratedSharedConfig
 212
 213         -- here and in PlanOutput,
 214         -- use binDirectoryFor?
 215         bin_file' s =
 216           if isInplaceBuildStyle (elabBuildStyle elab)
 217             then dist_dir </> "build" </> prettyShow s </> prettyShow s <.> exeExtension plat
 218             else InstallDirs.bindir (elabInstallDirs elab) </> prettyShow s <.> exeExtension plat
 219
 220         flib_file' s =
 221           if isInplaceBuildStyle (elabBuildStyle elab)
 222             then dist_dir </> "build" </> prettyShow s </> ("lib" ++ prettyShow s) <.> dllExtension plat
 223             else InstallDirs.bindir (elabInstallDirs elab) </> ("lib" ++ prettyShow s) <.> dllExtension plat
 224
 225         moved_bin_file s = fromMaybe (bin_file' s) (movedExePath selectedComponent distDirLayout elaboratedSharedConfig elab)
 226
 227 -------------------------------------------------------------------------------
 228 -- Target Problem: the very similar to CmdRun
 229 -------------------------------------------------------------------------------
 230
 231 singleComponentOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName)
 232 singleComponentOrElse action targetsMap =
 233   case Set.toList . distinctTargetComponents $ targetsMap of
 234     [(unitId, CExeName component)] -> return (unitId, component)
 235     [(unitId, CTestName component)] -> return (unitId, component)
 236     [(unitId, CBenchName component)] -> return (unitId, component)
 237     [(unitId, CFLibName component)] -> return (unitId, component)
 238     _ -> action
 239
 240 -- | This defines what a 'TargetSelector' means for the @list-bin@ command.
 241 -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
 242 -- or otherwise classifies the problem.
 243 --
 244 -- For the @list-bin@ command we select the exe or flib if there is only one
 245 -- and it's buildable. Fail if there are no or multiple buildable exe components.
 246 selectPackageTargets
 247   :: TargetSelector
 248   -> [AvailableTarget k]
 249   -> Either ListBinTargetProblem [k]
 250 selectPackageTargets targetSelector targets
 251   -- If there is a single executable component, select that. See #7403
 252   | [target] <- targetsExesBuildable =
 253       Right [target]
 254   -- Otherwise, if there is a single executable-like component left, select that.
 255   | [target] <- targetsExeLikesBuildable =
 256       Right [target]
 257   -- but fail if there are multiple buildable executables.
 258   | not (null targetsExeLikesBuildable) =
 259       Left (matchesMultipleProblem targetSelector targetsExeLikesBuildable')
 260   -- If there are executables but none are buildable then we report those
 261   | not (null targetsExeLikes') =
 262       Left (TargetProblemNoneEnabled targetSelector targetsExeLikes')
 263   -- If there are no executables but some other targets then we report that
 264   | not (null targets) =
 265       Left (noComponentsProblem targetSelector)
 266   -- If there are no targets at all then we report that
 267   | otherwise =
 268       Left (TargetProblemNoTargets targetSelector)
 269   where
 270     -- Targets that are precisely executables
 271     targetsExes = filterTargetsKind ExeKind targets
 272     targetsExesBuildable = selectBuildableTargets targetsExes
 273
 274     -- Any target that could be executed
 275     targetsExeLikes =
 276       targetsExes
 277         ++ filterTargetsKind TestKind targets
 278         ++ filterTargetsKind BenchKind targets
 279
 280     ( targetsExeLikesBuildable
 281       , targetsExeLikesBuildable'
 282       ) = selectBuildableTargets' targetsExeLikes
 283
 284     targetsExeLikes' = forgetTargetsDetail targetsExeLikes
 285
 286 -- | For a 'TargetComponent' 'TargetSelector', check if the component can be
 287 -- selected.
 288 --
 289 -- For the @run@ command we just need to check it is a executable-like
 290 -- (an executable, a test, or a benchmark), in addition
 291 -- to the basic checks on being buildable etc.
 292 selectComponentTarget
 293   :: SubComponentTarget
 294   -> AvailableTarget k
 295   -> Either ListBinTargetProblem k
 296 selectComponentTarget subtarget@WholeComponent t =
 297   case availableTargetComponentName t of
 298     CExeName _ -> component
 299     CTestName _ -> component
 300     CBenchName _ -> component
 301     CFLibName _ -> component
 302     _ -> Left (componentNotRightKindProblem pkgid cname)
 303   where
 304     pkgid = availableTargetPackageId t
 305     cname = availableTargetComponentName t
 306     component = selectComponentTargetBasic subtarget t
 307 selectComponentTarget subtarget t =
 308   Left
 309     ( isSubComponentProblem
 310         (availableTargetPackageId t)
 311         (availableTargetComponentName t)
 312         subtarget
 313     )
 314
 315 -- | The various error conditions that can occur when matching a
 316 -- 'TargetSelector' against 'AvailableTarget's for the @run@ command.
 317 data ListBinProblem
 318   = -- | The 'TargetSelector' matches targets but no executables
 319     TargetProblemNoRightComps TargetSelector
 320   | -- | A single 'TargetSelector' matches multiple targets
 321     TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]
 322   | -- | Multiple 'TargetSelector's match multiple targets
 323     TargetProblemMultipleTargets TargetsMap
 324   | -- | The 'TargetSelector' refers to a component that is not an executable
 325     TargetProblemComponentNotRightKind PackageId ComponentName
 326   | -- | Asking to run an individual file or module is not supported
 327     TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget
 328   deriving (Eq, Show)
 329
 330 type ListBinTargetProblem = TargetProblem ListBinProblem
 331
 332 noComponentsProblem :: TargetSelector -> ListBinTargetProblem
 333 noComponentsProblem = CustomTargetProblem . TargetProblemNoRightComps
 334
 335 matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> ListBinTargetProblem
 336 matchesMultipleProblem selector targets =
 337   CustomTargetProblem $
 338     TargetProblemMatchesMultiple selector targets
 339
 340 multipleTargetsProblem :: TargetsMap -> TargetProblem ListBinProblem
 341 multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets
 342
 343 componentNotRightKindProblem :: PackageId -> ComponentName -> TargetProblem ListBinProblem
 344 componentNotRightKindProblem pkgid name =
 345   CustomTargetProblem $
 346     TargetProblemComponentNotRightKind pkgid name
 347
 348 isSubComponentProblem
 349   :: PackageId
 350   -> ComponentName
 351   -> SubComponentTarget
 352   -> TargetProblem ListBinProblem
 353 isSubComponentProblem pkgid name subcomponent =
 354   CustomTargetProblem $
 355     TargetProblemIsSubComponent pkgid name subcomponent
 356
 357 reportTargetProblems :: Verbosity -> [ListBinTargetProblem] -> IO a
 358 reportTargetProblems verbosity =
 359   dieWithException verbosity . ListBinTargetException . unlines . map renderListBinTargetProblem
 360
 361 renderListBinTargetProblem :: ListBinTargetProblem -> String
 362 renderListBinTargetProblem (TargetProblemNoTargets targetSelector) =
 363   case targetSelectorFilter targetSelector of
 364     Just kind
 365       | kind /= ExeKind ->
 366           "The list-bin command is for finding binaries, but the target '"
 367             ++ showTargetSelector targetSelector
 368             ++ "' refers to "
 369             ++ renderTargetSelector targetSelector
 370             ++ "."
 371     _ -> renderTargetProblemNoTargets "list-bin" targetSelector
 372 renderListBinTargetProblem problem =
 373   renderTargetProblem "list-bin" renderListBinProblem problem
 374
 375 renderListBinProblem :: ListBinProblem -> String
 376 renderListBinProblem (TargetProblemMatchesMultiple targetSelector targets) =
 377   "The list-bin command is for finding a single binary at once. The target '"
 378     ++ showTargetSelector targetSelector
 379     ++ "' refers to "
 380     ++ renderTargetSelector targetSelector
 381     ++ " which includes "
 382     ++ renderListCommaAnd
 383       ( ("the " ++)
 384           <$> showComponentName
 385           <$> availableTargetComponentName
 386           <$> foldMap
 387             (\kind -> filterTargetsKind kind targets)
 388             [ExeKind, TestKind, BenchKind]
 389       )
 390     ++ "."
 391 renderListBinProblem (TargetProblemMultipleTargets selectorMap) =
 392   "The list-bin command is for finding a single binary at once. The targets "
 393     ++ renderListCommaAnd
 394       [ "'" ++ showTargetSelector ts ++ "'"
 395       | ts <- uniqueTargetSelectors selectorMap
 396       ]
 397     ++ " refer to different executables."
 398 renderListBinProblem (TargetProblemComponentNotRightKind pkgid cname) =
 399   "The list-bin command is for finding binaries, but the target '"
 400     ++ showTargetSelector targetSelector
 401     ++ "' refers to "
 402     ++ renderTargetSelector targetSelector
 403     ++ " from the package "
 404     ++ prettyShow pkgid
 405     ++ "."
 406   where
 407     targetSelector = TargetComponent pkgid cname WholeComponent
 408 renderListBinProblem (TargetProblemIsSubComponent pkgid cname subtarget) =
 409   "The list-bin command can only find a binary as a whole, "
 410     ++ "not files or modules within them, but the target '"
 411     ++ showTargetSelector targetSelector
 412     ++ "' refers to "
 413     ++ renderTargetSelector targetSelector
 414     ++ "."
 415   where
 416     targetSelector = TargetComponent pkgid cname subtarget
 417 renderListBinProblem (TargetProblemNoRightComps targetSelector) =
 418   "Cannot list-bin the target '"
 419     ++ showTargetSelector targetSelector
 420     ++ "' which refers to "
 421     ++ renderTargetSelector targetSelector
 422     ++ " because "
 423     ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"
 424     ++ " not contain any executables or foreign libraries."