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