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