1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE NamedFieldPuns #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RecordWildCards #-}
5
6-- | cabal-install CLI command: run
7--
8module Distribution.Client.CmdRun (
9    -- * The @run@ CLI and action
10    runCommand,
11    runAction,
12    handleShebang, validScript,
13
14    -- * Internals exposed for testing
15    TargetProblem(..),
16    selectPackageTargets,
17    selectComponentTarget
18  ) where
19
20import Prelude ()
21import Distribution.Client.Compat.Prelude hiding (toList)
22
23import Distribution.Client.ProjectOrchestration
24import Distribution.Client.CmdErrorMessages
25
26import Distribution.Client.CmdRun.ClientRunFlags
27
28import Distribution.Client.Setup
29         ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..)
30         , configureExOptions, haddockOptions, installOptions, testOptions
31         , benchmarkOptions, configureOptions, liftOptions )
32import Distribution.Solver.Types.ConstraintSource
33         ( ConstraintSource(..) )
34import Distribution.Client.GlobalFlags
35         ( defaultGlobalFlags )
36import Distribution.Simple.Setup
37         ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault )
38import Distribution.Simple.Command
39         ( CommandUI(..), OptionField (..), usageAlternatives )
40import Distribution.Types.ComponentName
41         ( showComponentName )
42import Distribution.Deprecated.Text
43         ( display )
44import Distribution.Verbosity
45         ( Verbosity, normal )
46import Distribution.Simple.Utils
47         ( wrapText, warn, die', ordNub, info
48         , createTempDirectory, handleDoesNotExist )
49import Distribution.Client.CmdInstall
50         ( establishDummyProjectBaseContext )
51import Distribution.Client.ProjectConfig
52         ( ProjectConfig(..), ProjectConfigShared(..)
53         , withProjectOrGlobalConfigIgn )
54import Distribution.Client.ProjectPlanning
55         ( ElaboratedConfiguredPackage(..)
56         , ElaboratedInstallPlan, binDirectoryFor )
57import Distribution.Client.ProjectPlanning.Types
58         ( dataDirsEnvironmentForPlan )
59import Distribution.Client.TargetSelector
60         ( TargetSelectorProblem(..), TargetString(..) )
61import Distribution.Client.InstallPlan
62         ( toList, foldPlanPackage )
63import Distribution.Types.UnqualComponentName
64         ( UnqualComponentName, unUnqualComponentName )
65import Distribution.Simple.Program.Run
66         ( runProgramInvocation, ProgramInvocation(..),
67           emptyProgramInvocation )
68import Distribution.Types.UnitId
69         ( UnitId )
70
71import Distribution.CabalSpecVersion
72         ( cabalSpecLatest )
73import Distribution.Client.Types
74         ( PackageLocation(..), PackageSpecifier(..) )
75import Distribution.FieldGrammar
76         ( takeFields, parseFieldGrammar )
77import Distribution.PackageDescription.FieldGrammar
78         ( executableFieldGrammar )
79import Distribution.PackageDescription.PrettyPrint
80         ( writeGenericPackageDescription )
81import Distribution.Parsec
82         ( Position(..) )
83import Distribution.Fields
84         ( ParseResult, parseString, parseFatalFailure, readFields )
85import qualified Distribution.SPDX.License as SPDX
86import Distribution.Solver.Types.SourcePackage as SP
87         ( SourcePackage(..) )
88import Distribution.Types.BuildInfo
89         ( BuildInfo(..) )
90import Distribution.Types.CondTree
91         ( CondTree(..) )
92import Distribution.Types.Executable
93         ( Executable(..) )
94import Distribution.Types.GenericPackageDescription as GPD
95         ( GenericPackageDescription(..), emptyGenericPackageDescription )
96import Distribution.Types.PackageDescription
97         ( PackageDescription(..), emptyPackageDescription )
98import Distribution.Types.Version
99         ( mkVersion )
100import Distribution.Types.PackageName.Magic
101         ( fakePackageId )
102import Language.Haskell.Extension
103         ( Language(..) )
104
105import qualified Data.ByteString.Char8 as BS
106import qualified Data.Map as Map
107import qualified Data.Set as Set
108import qualified Text.Parsec as P
109import System.Directory
110         ( getTemporaryDirectory, removeDirectoryRecursive, doesFileExist )
111import System.FilePath
112         ( (</>), isValid, isPathSeparator, takeExtension )
113
114
115runCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags
116                        , HaddockFlags, TestFlags, BenchmarkFlags
117                        , ClientRunFlags
118                        )
119runCommand = CommandUI
120  { commandName         = "v2-run"
121  , commandSynopsis     = "Run an executable."
122  , commandUsage        = usageAlternatives "v2-run"
123                          [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ]
124  , commandDescription  = Just $ \pname -> wrapText $
125         "Runs the specified executable-like component (an executable, a test, "
126      ++ "or a benchmark), first ensuring it is up to date.\n\n"
127
128      ++ "Any executable-like component in any package in the project can be "
129      ++ "specified. A package can be specified if contains just one "
130      ++ "executable-like. The default is to use the package in the current "
131      ++ "directory if it contains just one executable-like.\n\n"
132
133      ++ "Extra arguments can be passed to the program, but use '--' to "
134      ++ "separate arguments for the program from arguments for " ++ pname
135      ++ ". The executable is run in an environment where it can find its "
136      ++ "data files inplace in the build tree.\n\n"
137
138      ++ "Dependencies are built or rebuilt as necessary. Additional "
139      ++ "configuration flags can be specified on the command line and these "
140      ++ "extend the project configuration from the 'cabal.project', "
141      ++ "'cabal.project.local' and other files."
142  , commandNotes        = Just $ \pname ->
143         "Examples:\n"
144      ++ "  " ++ pname ++ " v2-run\n"
145      ++ "    Run the executable-like in the package in the current directory\n"
146      ++ "  " ++ pname ++ " v2-run foo-tool\n"
147      ++ "    Run the named executable-like (in any package in the project)\n"
148      ++ "  " ++ pname ++ " v2-run pkgfoo:foo-tool\n"
149      ++ "    Run the executable-like 'foo-tool' in the package 'pkgfoo'\n"
150      ++ "  " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n"
151      ++ "    Build with '-O2' and run the program, passing it extra arguments.\n\n"
152
153      ++ cmdCommonHelpTextNewBuildBeta
154  , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty, mempty)
155  , commandOptions      = \showOrParseArgs ->
156          liftOptions get1 set1
157          -- Note: [Hidden Flags]
158          -- hide "constraint", "dependency", and
159          -- "exact-configuration" from the configure options.
160          (filter ((`notElem` ["constraint", "dependency"
161                              , "exact-configuration"])
162                   . optionName) $
163                                 configureOptions   showOrParseArgs)
164      ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
165      ++ liftOptions get3 set3
166          -- hide "target-package-db" flag from the
167          -- install options.
168          (filter ((`notElem` ["target-package-db"])
169                   . optionName) $
170                                 installOptions     showOrParseArgs)
171      ++ liftOptions get4 set4 (haddockOptions     showOrParseArgs)
172      ++ liftOptions get5 set5 (testOptions        showOrParseArgs)
173      ++ liftOptions get6 set6 (benchmarkOptions   showOrParseArgs)
174      ++ liftOptions get7 set7 (clientRunOptions showOrParseArgs)
175  }
176  where
177    get1 (a,_,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f,g) = (a,b,c,d,e,f,g)
178    get2 (_,b,_,_,_,_,_) = b; set2 b (a,_,c,d,e,f,g) = (a,b,c,d,e,f,g)
179    get3 (_,_,c,_,_,_,_) = c; set3 c (a,b,_,d,e,f,g) = (a,b,c,d,e,f,g)
180    get4 (_,_,_,d,_,_,_) = d; set4 d (a,b,c,_,e,f,g) = (a,b,c,d,e,f,g)
181    get5 (_,_,_,_,e,_,_) = e; set5 e (a,b,c,d,_,f,g) = (a,b,c,d,e,f,g)
182    get6 (_,_,_,_,_,f,_) = f; set6 f (a,b,c,d,e,_,g) = (a,b,c,d,e,f,g)
183    get7 (_,_,_,_,_,_,g) = g; set7 g (a,b,c,d,e,f,_) = (a,b,c,d,e,f,g)
184
185
186-- | The @run@ command runs a specified executable-like component, building it
187-- first if necessary. The component can be either an executable, a test,
188-- or a benchmark. This is particularly useful for passing arguments to
189-- exes/tests/benchs by simply appending them after a @--@.
190--
191-- For more details on how this works, see the module
192-- "Distribution.Client.ProjectOrchestration"
193--
194runAction :: ( ConfigFlags, ConfigExFlags, InstallFlags
195             , HaddockFlags, TestFlags, BenchmarkFlags
196             , ClientRunFlags )
197          -> [String] -> GlobalFlags -> IO ()
198runAction ( configFlags, configExFlags, installFlags
199          , haddockFlags, testFlags, benchmarkFlags
200          , clientRunFlags )
201            targetStrings globalFlags = do
202    globalTmp <- getTemporaryDirectory
203    tempDir <- createTempDirectory globalTmp "cabal-repl."
204
205    let
206      with =
207        establishProjectBaseContext verbosity cliConfig OtherCommand
208      without config =
209        establishDummyProjectBaseContext verbosity (config <> cliConfig) tempDir [] OtherCommand
210
211    let
212      ignoreProject = fromFlagOrDefault False (crunIgnoreProject clientRunFlags)
213
214    baseCtx <- withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag with without
215
216    let
217      scriptOrError script err = do
218        exists <- doesFileExist script
219        let pol | takeExtension script == ".lhs" = LiterateHaskell
220                | otherwise                      = PlainHaskell
221        if exists
222          then BS.readFile script >>= handleScriptCase verbosity pol baseCtx tempDir
223          else reportTargetSelectorProblems verbosity err
224
225    (baseCtx', targetSelectors) <-
226      readTargetSelectors (localPackages baseCtx) (Just ExeKind) (take 1 targetStrings)
227        >>= \case
228          Left err@(TargetSelectorNoTargetsInProject:_)
229            | (script:_) <- targetStrings -> scriptOrError script err
230          Left err@(TargetSelectorNoSuch t _:_)
231            | TargetString1 script <- t   -> scriptOrError script err
232          Left err@(TargetSelectorExpected t _ _:_)
233            | TargetString1 script <- t   -> scriptOrError script err
234          Left err   -> reportTargetSelectorProblems verbosity err
235          Right sels -> return (baseCtx, sels)
236
237    buildCtx <-
238      runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do
239
240            when (buildSettingOnlyDeps (buildSettings baseCtx')) $
241              die' verbosity $
242                  "The run command does not support '--only-dependencies'. "
243               ++ "You may wish to use 'build --only-dependencies' and then "
244               ++ "use 'run'."
245
246            -- Interpret the targets on the command line as build targets
247            -- (as opposed to say repl or haddock targets).
248            targets <- either (reportTargetProblems verbosity) return
249                     $ resolveTargets
250                         selectPackageTargets
251                         selectComponentTarget
252                         TargetProblemCommon
253                         elaboratedPlan
254                         Nothing
255                         targetSelectors
256
257            -- Reject multiple targets, or at least targets in different
258            -- components. It is ok to have two module/file targets in the
259            -- same component, but not two that live in different components.
260            --
261            -- Note that we discard the target and return the whole 'TargetsMap',
262            -- so this check will be repeated (and must succeed) after
263            -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this.
264            _ <- singleExeOrElse
265                   (reportTargetProblems
266                      verbosity
267                      [TargetProblemMultipleTargets targets])
268                   targets
269
270            let elaboratedPlan' = pruneInstallPlanToTargets
271                                    TargetActionBuild
272                                    targets
273                                    elaboratedPlan
274            return (elaboratedPlan', targets)
275
276    (selectedUnitId, selectedComponent) <-
277      -- Slight duplication with 'runProjectPreBuildPhase'.
278      singleExeOrElse
279        (die' verbosity $ "No or multiple targets given, but the run "
280                       ++ "phase has been reached. This is a bug.")
281        $ targetsMap buildCtx
282
283    printPlan verbosity baseCtx' buildCtx
284
285    buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx
286    runProjectPostBuildPhase verbosity baseCtx' buildCtx buildOutcomes
287
288
289    let elaboratedPlan = elaboratedPlanToExecute buildCtx
290        matchingElaboratedConfiguredPackages =
291          matchingPackagesByUnitId
292            selectedUnitId
293            elaboratedPlan
294
295    let exeName = unUnqualComponentName selectedComponent
296
297    -- In the common case, we expect @matchingElaboratedConfiguredPackages@
298    -- to consist of a single element that provides a single way of building
299    -- an appropriately-named executable. In that case we take that
300    -- package and continue.
301    --
302    -- However, multiple packages/components could provide that
303    -- executable, or it's possible we don't find the executable anywhere
304    -- in the build plan. I suppose in principle it's also possible that
305    -- a single package provides an executable in two different ways,
306    -- though that's probably a bug if. Anyway it's a good lint to report
307    -- an error in all of these cases, even if some seem like they
308    -- shouldn't happen.
309    pkg <- case matchingElaboratedConfiguredPackages of
310      [] -> die' verbosity $ "Unknown executable "
311                          ++ exeName
312                          ++ " in package "
313                          ++ display selectedUnitId
314      [elabPkg] -> do
315        info verbosity $ "Selecting "
316                       ++ display selectedUnitId
317                       ++ " to supply " ++ exeName
318        return elabPkg
319      elabPkgs -> die' verbosity
320        $ "Multiple matching executables found matching "
321        ++ exeName
322        ++ ":\n"
323        ++ unlines (fmap (\p -> " - in package " ++ display (elabUnitId p)) elabPkgs)
324    let exePath = binDirectoryFor (distDirLayout baseCtx)
325                                  (elaboratedShared buildCtx)
326                                  pkg
327                                  exeName
328               </> exeName
329    let args = drop 1 targetStrings
330    runProgramInvocation
331      verbosity
332      emptyProgramInvocation {
333        progInvokePath  = exePath,
334        progInvokeArgs  = args,
335        progInvokeEnv   = dataDirsEnvironmentForPlan
336                            (distDirLayout baseCtx)
337                            elaboratedPlan
338      }
339
340    handleDoesNotExist () (removeDirectoryRecursive tempDir)
341  where
342    verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
343    cliConfig = commandLineFlagsToProjectConfig
344                  globalFlags configFlags configExFlags
345                  installFlags
346                  mempty -- ClientInstallFlags, not needed here
347                  haddockFlags testFlags benchmarkFlags
348    globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
349
350-- | Used by the main CLI parser as heuristic to decide whether @cabal@ was
351-- invoked as a script interpreter, i.e. via
352--
353-- > #! /usr/bin/env cabal
354--
355-- or
356--
357-- > #! /usr/bin/cabal
358--
359-- As the first argument passed to `cabal` will be a filepath to the
360-- script to be interpreted.
361--
362-- See also 'handleShebang'
363validScript :: String -> IO Bool
364validScript script
365  | isValid script && any isPathSeparator script = doesFileExist script
366  | otherwise = return False
367
368-- | Handle @cabal@ invoked as script interpreter, see also 'validScript'
369--
370-- First argument is the 'FilePath' to the script to be executed; second
371-- argument is a list of arguments to be passed to the script.
372handleShebang :: FilePath -> [String] -> IO ()
373handleShebang script args =
374  runAction (commandDefaultFlags runCommand) (script:args) defaultGlobalFlags
375
376parseScriptBlock :: BS.ByteString -> ParseResult Executable
377parseScriptBlock str =
378    case readFields str of
379        Right fs -> do
380            let (fields, _) = takeFields fs
381            parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script")
382        Left perr -> parseFatalFailure pos (show perr) where
383            ppos = P.errorPos perr
384            pos  = Position (P.sourceLine ppos) (P.sourceColumn ppos)
385
386readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable
387readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block"
388
389readScriptBlockFromScript :: Verbosity -> PlainOrLiterate -> BS.ByteString -> IO (Executable, BS.ByteString)
390readScriptBlockFromScript verbosity pol str = do
391    str' <- case extractScriptBlock pol str of
392              Left e -> die' verbosity $ "Failed extracting script block: " ++ e
393              Right x -> return x
394    when (BS.all isSpace str') $ warn verbosity "Empty script block"
395    (\x -> (x, noShebang)) <$> readScriptBlock verbosity str'
396  where
397    noShebang = BS.unlines . filter (not . BS.isPrefixOf "#!") . BS.lines $ str
398
399-- | Extract the first encountered script metadata block started end
400-- terminated by the tokens
401--
402-- * @{- cabal:@
403--
404-- * @-}@
405--
406-- appearing alone on lines (while tolerating trailing whitespace).
407-- These tokens are not part of the 'Right' result.
408--
409-- In case of missing or unterminated blocks a 'Left'-error is
410-- returned.
411extractScriptBlock :: PlainOrLiterate -> BS.ByteString -> Either String BS.ByteString
412extractScriptBlock _pol str = goPre (BS.lines str)
413  where
414    isStartMarker = (== startMarker) . stripTrailSpace
415    isEndMarker   = (== endMarker) . stripTrailSpace
416
417    stripTrailSpace = fst . BS.spanEnd isSpace
418
419    -- before start marker
420    goPre ls = case dropWhile (not . isStartMarker) ls of
421                 [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found"
422                 (_:ls') -> goBody [] ls'
423
424    goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found"
425    goBody acc (l:ls)
426      | isEndMarker l = Right $! BS.unlines $ reverse acc
427      | otherwise     = goBody (l:acc) ls
428
429    startMarker, endMarker :: BS.ByteString
430    startMarker = fromString "{- cabal:"
431    endMarker   = fromString "-}"
432
433data PlainOrLiterate
434    = PlainHaskell
435    | LiterateHaskell
436
437handleScriptCase
438  :: Verbosity
439  -> PlainOrLiterate
440  -> ProjectBaseContext
441  -> FilePath
442  -> BS.ByteString
443  -> IO (ProjectBaseContext, [TargetSelector])
444handleScriptCase verbosity pol baseCtx tempDir scriptContents = do
445  (executable, contents') <- readScriptBlockFromScript verbosity pol scriptContents
446
447  -- We need to create a dummy package that lives in our dummy project.
448  let
449    mainName = case pol of
450      PlainHaskell    -> "Main.hs"
451      LiterateHaskell -> "Main.lhs"
452
453    sourcePackage = SourcePackage
454      { packageInfoId         = pkgId
455      , SP.packageDescription = genericPackageDescription
456      , packageSource         = LocalUnpackedPackage tempDir
457      , packageDescrOverride  = Nothing
458      }
459    genericPackageDescription  = emptyGenericPackageDescription
460      { GPD.packageDescription = packageDescription
461      , condExecutables        = [("script", CondNode executable' targetBuildDepends [])]
462      }
463    executable' = executable
464      { modulePath = mainName
465      , buildInfo = binfo
466        { defaultLanguage =
467          case defaultLanguage of
468            just@(Just _) -> just
469            Nothing       -> Just Haskell2010
470        }
471      }
472    binfo@BuildInfo{..} = buildInfo executable
473    packageDescription = emptyPackageDescription
474      { package = pkgId
475      , specVersionRaw = Left (mkVersion [2, 2])
476      , licenseRaw = Left SPDX.NONE
477      }
478    pkgId = fakePackageId
479
480  writeGenericPackageDescription (tempDir </> "fake-package.cabal") genericPackageDescription
481  BS.writeFile (tempDir </> mainName) contents'
482
483  let
484    baseCtx' = baseCtx
485      { localPackages = localPackages baseCtx ++ [SpecificSourcePackage sourcePackage] }
486    targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing]
487
488  return (baseCtx', targetSelectors)
489
490singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName)
491singleExeOrElse action targetsMap =
492  case Set.toList . distinctTargetComponents $ targetsMap
493  of [(unitId, CExeName component)] -> return (unitId, component)
494     [(unitId, CTestName component)] -> return (unitId, component)
495     [(unitId, CBenchName component)] -> return (unitId, component)
496     _   -> action
497
498-- | Filter the 'ElaboratedInstallPlan' keeping only the
499-- 'ElaboratedConfiguredPackage's that match the specified
500-- 'UnitId'.
501matchingPackagesByUnitId :: UnitId
502                         -> ElaboratedInstallPlan
503                         -> [ElaboratedConfiguredPackage]
504matchingPackagesByUnitId uid =
505          catMaybes
506          . fmap (foldPlanPackage
507                    (const Nothing)
508                    (\x -> if elabUnitId x == uid
509                           then Just x
510                           else Nothing))
511          . toList
512
513-- | This defines what a 'TargetSelector' means for the @run@ command.
514-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
515-- or otherwise classifies the problem.
516--
517-- For the @run@ command we select the exe if there is only one and it's
518-- buildable. Fail if there are no or multiple buildable exe components.
519--
520selectPackageTargets :: TargetSelector
521                     -> [AvailableTarget k] -> Either TargetProblem [k]
522selectPackageTargets targetSelector targets
523
524    -- If there is exactly one buildable executable then we select that
525  | [target] <- targetsExesBuildable
526  = Right [target]
527
528    -- but fail if there are multiple buildable executables.
529  | not (null targetsExesBuildable)
530  = Left (TargetProblemMatchesMultiple targetSelector targetsExesBuildable')
531
532    -- If there are executables but none are buildable then we report those
533  | not (null targetsExes)
534  = Left (TargetProblemNoneEnabled targetSelector targetsExes)
535
536    -- If there are no executables but some other targets then we report that
537  | not (null targets)
538  = Left (TargetProblemNoExes targetSelector)
539
540    -- If there are no targets at all then we report that
541  | otherwise
542  = Left (TargetProblemNoTargets targetSelector)
543  where
544    -- Targets that can be executed
545    targetsExecutableLike =
546      concatMap (\kind -> filterTargetsKind kind targets)
547                [ExeKind, TestKind, BenchKind]
548    (targetsExesBuildable,
549     targetsExesBuildable') = selectBuildableTargets' targetsExecutableLike
550
551    targetsExes             = forgetTargetsDetail targetsExecutableLike
552
553
554-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
555-- selected.
556--
557-- For the @run@ command we just need to check it is a executable-like
558-- (an executable, a test, or a benchmark), in addition
559-- to the basic checks on being buildable etc.
560--
561selectComponentTarget :: SubComponentTarget
562                      -> AvailableTarget k -> Either TargetProblem  k
563selectComponentTarget subtarget@WholeComponent t
564  = case availableTargetComponentName t
565    of CExeName _ -> component
566       CTestName _ -> component
567       CBenchName _ -> component
568       _ -> Left (TargetProblemComponentNotExe pkgid cname)
569    where pkgid = availableTargetPackageId t
570          cname = availableTargetComponentName t
571          component = either (Left . TargetProblemCommon) return $
572                        selectComponentTargetBasic subtarget t
573
574selectComponentTarget subtarget t
575  = Left (TargetProblemIsSubComponent (availableTargetPackageId t)
576                                      (availableTargetComponentName t)
577                                       subtarget)
578
579-- | The various error conditions that can occur when matching a
580-- 'TargetSelector' against 'AvailableTarget's for the @run@ command.
581--
582data TargetProblem =
583     TargetProblemCommon       TargetProblemCommon
584     -- | The 'TargetSelector' matches targets but none are buildable
585   | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]
586
587     -- | There are no targets at all
588   | TargetProblemNoTargets   TargetSelector
589
590     -- | The 'TargetSelector' matches targets but no executables
591   | TargetProblemNoExes      TargetSelector
592
593     -- | A single 'TargetSelector' matches multiple targets
594   | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]
595
596     -- | Multiple 'TargetSelector's match multiple targets
597   | TargetProblemMultipleTargets TargetsMap
598
599     -- | The 'TargetSelector' refers to a component that is not an executable
600   | TargetProblemComponentNotExe PackageId ComponentName
601
602     -- | Asking to run an individual file or module is not supported
603   | TargetProblemIsSubComponent  PackageId ComponentName SubComponentTarget
604  deriving (Eq, Show)
605
606reportTargetProblems :: Verbosity -> [TargetProblem] -> IO a
607reportTargetProblems verbosity =
608    die' verbosity . unlines . map renderTargetProblem
609
610renderTargetProblem :: TargetProblem -> String
611renderTargetProblem (TargetProblemCommon problem) =
612    renderTargetProblemCommon "run" problem
613
614renderTargetProblem (TargetProblemNoneEnabled targetSelector targets) =
615    renderTargetProblemNoneEnabled "run" targetSelector targets
616
617renderTargetProblem (TargetProblemNoExes targetSelector) =
618    "Cannot run the target '" ++ showTargetSelector targetSelector
619 ++ "' which refers to " ++ renderTargetSelector targetSelector
620 ++ " because "
621 ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"
622 ++ " not contain any executables."
623
624renderTargetProblem (TargetProblemNoTargets targetSelector) =
625    case targetSelectorFilter targetSelector of
626      Just kind | kind /= ExeKind
627        -> "The run command is for running executables, but the target '"
628           ++ showTargetSelector targetSelector ++ "' refers to "
629           ++ renderTargetSelector targetSelector ++ "."
630
631      _ -> renderTargetProblemNoTargets "run" targetSelector
632
633renderTargetProblem (TargetProblemMatchesMultiple targetSelector targets) =
634    "The run command is for running a single executable at once. The target '"
635 ++ showTargetSelector targetSelector ++ "' refers to "
636 ++ renderTargetSelector targetSelector ++ " which includes "
637 ++ renderListCommaAnd ( ("the "++) <$>
638                         showComponentName <$>
639                         availableTargetComponentName <$>
640                         foldMap
641                           (\kind -> filterTargetsKind kind targets)
642                           [ExeKind, TestKind, BenchKind] )
643 ++ "."
644
645renderTargetProblem (TargetProblemMultipleTargets selectorMap) =
646    "The run command is for running a single executable at once. The targets "
647 ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'"
648                       | ts <- ordNub (concatMap snd (concat (Map.elems selectorMap))) ]
649 ++ " refer to different executables."
650
651renderTargetProblem (TargetProblemComponentNotExe pkgid cname) =
652    "The run command is for running executables, but the target '"
653 ++ showTargetSelector targetSelector ++ "' refers to "
654 ++ renderTargetSelector targetSelector ++ " from the package "
655 ++ display pkgid ++ "."
656  where
657    targetSelector = TargetComponent pkgid cname WholeComponent
658
659renderTargetProblem (TargetProblemIsSubComponent pkgid cname subtarget) =
660    "The run command can only run an executable as a whole, "
661 ++ "not files or modules within them, but the target '"
662 ++ showTargetSelector targetSelector ++ "' refers to "
663 ++ renderTargetSelector targetSelector ++ "."
664  where
665    targetSelector = TargetComponent pkgid cname subtarget
666