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

   1 -----------------------------------------------------------------------------
   2 {-# LANGUAGE DataKinds #-}
   3
   4 -----------------------------------------------------------------------------
   5
   6 -- |
   7 -- Module      :  Distribution.Client.Run
   8 -- Maintainer  :  cabal-devel@haskell.org
   9 -- Portability :  portable
  10 --
  11 -- Implementation of the 'run' command.
  12 module Distribution.Client.Run (run, splitRunArgs)
  13 where
  14
  15 import Distribution.Client.Compat.Prelude
  16 import Prelude ()
  17
  18 import Distribution.Types.LocalBuildInfo (componentNameTargets')
  19 import Distribution.Types.TargetInfo (targetCLBI)
  20
  21 import Distribution.Client.Utils (tryCanonicalizePath)
  22
  23 import Distribution.PackageDescription
  24   ( Benchmark (..)
  25   , BuildInfo (buildable)
  26   , Executable (..)
  27   , PackageDescription (..)
  28   , TestSuite (..)
  29   )
  30 import Distribution.Simple (PackageDBX (..))
  31 import Distribution.Simple.Build (addInternalBuildTools)
  32 import Distribution.Simple.BuildPaths (exeExtension)
  33 import Distribution.Simple.Compiler (CompilerFlavor (..), compilerFlavor)
  34 import Distribution.Simple.Flag (fromFlag)
  35 import Distribution.Simple.LocalBuildInfo
  36   ( ComponentName (..)
  37   , LocalBuildInfo (..)
  38   , buildDir
  39   , depLibraryPaths
  40   , interpretSymbolicPathLBI
  41   , mbWorkDirLBI
  42   )
  43 import Distribution.Simple.Program.Db
  44 import Distribution.Simple.Program.Find
  45 import Distribution.Simple.Program.Run
  46 import Distribution.Simple.Register (internalPackageDBPath)
  47
  48 import Distribution.Simple.Setup (ConfigFlags (..))
  49 import Distribution.Simple.Utils
  50   ( addLibraryPath
  51   , dieWithException
  52   , notice
  53   , rawSystemExitWithEnvCwd
  54   , warn
  55   )
  56 import Distribution.System (Platform (..))
  57 import Distribution.Types.UnqualComponentName
  58
  59 import qualified Distribution.Simple.GHCJS as GHCJS
  60
  61 import Distribution.Client.Errors
  62 import Distribution.Compat.Environment (getEnvironment)
  63 import Distribution.Utils.Path
  64
  65 -- | Return the executable to run and any extra arguments that should be
  66 -- forwarded to it. Die in case of error.
  67 splitRunArgs
  68   :: Verbosity
  69   -> LocalBuildInfo
  70   -> [String]
  71   -> IO (Executable, [String])
  72 splitRunArgs verbosity lbi args =
  73   case whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest)
  74     Left err -> do
  75       warn verbosity `traverse_` maybeWarning -- If there is a warning, print it.
  76       dieWithException verbosity $ SplitRunArgs err
  77     Right (True, exe, xs) -> return (exe, xs)
  78     Right (False, exe, xs) -> do
  79       let addition =
  80             " Interpreting all parameters to `run` as a parameter to"
  81               ++ " the default executable."
  82       -- If there is a warning, print it together with the addition.
  83       warn verbosity `traverse_` fmap (++ addition) maybeWarning
  84       return (exe, xs)
  85   where
  86     pkg_descr = localPkgDescr lbi
  87     whichExecutable
  88       :: Either
  89           String -- Error string.
  90           ( Bool -- If it was manually chosen.
  91           , Executable -- The executable.
  92           , [String] -- The remaining parameters.
  93           )
  94     whichExecutable = case (enabledExes, args) of
  95       ([], _) -> Left "Couldn't find any enabled executables."
  96       ([exe], []) -> return (False, exe, [])
  97       ([exe], (x : xs))
  98         | x == unUnqualComponentName (exeName exe) -> return (True, exe, xs)
  99         | otherwise -> return (False, exe, args)
 100       (_, []) ->
 101         Left $
 102           "This package contains multiple executables. "
 103             ++ "You must pass the executable name as the first argument "
 104             ++ "to 'cabal run'."
 105       (_, (x : xs)) ->
 106         case find (\exe -> unUnqualComponentName (exeName exe) == x) enabledExes of
 107           Nothing -> Left $ "No executable named '" ++ x ++ "'."
 108           Just exe -> return (True, exe, xs)
 109       where
 110         enabledExes = filter (buildable . buildInfo) (executables pkg_descr)
 111
 112     maybeWarning :: Maybe String
 113     maybeWarning = case args of
 114       [] -> Nothing
 115       (x : _) -> lookup (mkUnqualComponentName x) components
 116       where
 117         components :: [(UnqualComponentName, String)] -- Component name, message.
 118         components =
 119           [ (name, "The executable '" ++ prettyShow name ++ "' is disabled.")
 120           | e <- executables pkg_descr
 121           , not . buildable . buildInfo $ e
 122           , let name = exeName e
 123           ]
 124             ++ [ ( name
 125                  , "There is a test-suite '"
 126                     ++ prettyShow name
 127                     ++ "',"
 128                     ++ " but the `run` command is only for executables."
 129                  )
 130                | t <- testSuites pkg_descr
 131                , let name = testName t
 132                ]
 133             ++ [ ( name
 134                  , "There is a benchmark '"
 135                     ++ prettyShow name
 136                     ++ "',"
 137                     ++ " but the `run` command is only for executables."
 138                  )
 139                | b <- benchmarks pkg_descr
 140                , let name = benchmarkName b
 141                ]
 142
 143 -- | Run a given executable.
 144 run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO ()
 145 run verbosity lbi exe exeArgs = do
 146   let distPref = fromFlag $ configDistPref $ configFlags lbi
 147       buildPref = buildDir lbi
 148       pkg_descr = localPkgDescr lbi
 149       i = interpretSymbolicPathLBI lbi -- See Note [Symbolic paths] in Distribution.Utils.Path
 150       mbWorkDir = mbWorkDirLBI lbi
 151       internalPkgDb = internalPackageDBPath lbi distPref
 152       lbiForExe =
 153         lbi
 154           { withPackageDB = withPackageDB lbi ++ [SpecificPackageDB internalPkgDb]
 155           , -- Include any build-tool-depends on build tools internal to the current package.
 156             withPrograms =
 157               addInternalBuildTools
 158                 pkg_descr
 159                 lbi
 160                 (buildInfo exe)
 161                 (withPrograms lbi)
 162           }
 163
 164   (path, runArgs) <-
 165     let exeName' = prettyShow $ exeName exe
 166      in case compilerFlavor (compiler lbiForExe) of
 167           GHCJS -> do
 168             let (script, cmd, cmdArgs) =
 169                   GHCJS.runCmd
 170                     (withPrograms lbiForExe)
 171                     (i buildPref </> exeName' </> exeName')
 172             script' <- tryCanonicalizePath script
 173             return (cmd, cmdArgs ++ [script'])
 174           _ -> do
 175             p <-
 176               tryCanonicalizePath $
 177                 i buildPref </> exeName' </> (exeName' <.> exeExtension (hostPlatform lbiForExe))
 178             return (p, [])
 179
 180   -- Compute the appropriate environment for running the executable
 181   existingEnv <- getEnvironment
 182   let progDb = withPrograms lbiForExe
 183       pathVar = progSearchPath progDb
 184       envOverrides = progOverrideEnv progDb
 185   newPath <- programSearchPathAsPATHVar pathVar
 186   overrideEnv <- fromMaybe [] <$> getEffectiveEnvironment ([("PATH", Just newPath)] ++ envOverrides)
 187   let env = overrideEnv ++ existingEnv
 188
 189   -- Add (DY)LD_LIBRARY_PATH if needed
 190   env' <-
 191     if withDynExe lbiForExe
 192       then do
 193         let (Platform _ os) = hostPlatform lbiForExe
 194         clbi <- case componentNameTargets' pkg_descr lbiForExe (CExeName (exeName exe)) of
 195           [target] -> return (targetCLBI target)
 196           [] -> dieWithException verbosity CouldNotFindExecutable
 197           _ -> dieWithException verbosity FoundMultipleMatchingExes
 198         paths <- depLibraryPaths True False lbiForExe clbi
 199         return (addLibraryPath os paths env)
 200       else return env
 201
 202   notice verbosity $ "Running " ++ prettyShow (exeName exe) ++ "..."
 203   rawSystemExitWithEnvCwd verbosity mbWorkDir path (runArgs ++ exeArgs) env'