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

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