-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Client.Run
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Implementation of the 'run' command.
module Distribution.Client.Run (run, splitRunArgs)
where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Distribution.Types.LocalBuildInfo (componentNameTargets')
import Distribution.Types.TargetInfo (targetCLBI)

import Distribution.Client.Utils (tryCanonicalizePath)

import Distribution.PackageDescription
  ( Benchmark (..)
  , BuildInfo (buildable)
  , Executable (..)
  , PackageDescription (..)
  , TestSuite (..)
  )
import Distribution.Simple.Build.PathsModule (pkgPathEnvVar)
import Distribution.Simple.BuildPaths (exeExtension)
import Distribution.Simple.Compiler (CompilerFlavor (..), compilerFlavor)
import Distribution.Simple.LocalBuildInfo
  ( ComponentName (..)
  , LocalBuildInfo (..)
  , buildDir
  , depLibraryPaths
  )
import Distribution.Simple.Utils
  ( addLibraryPath
  , dieWithException
  , notice
  , rawSystemExitWithEnv
  , warn
  )
import Distribution.System (Platform (..))
import Distribution.Types.UnqualComponentName

import qualified Distribution.Simple.GHCJS as GHCJS

import Distribution.Client.Errors
import Distribution.Compat.Environment (getEnvironment)
import System.Directory (getCurrentDirectory)
import System.FilePath ((<.>), (</>))

-- | Return the executable to run and any extra arguments that should be
-- forwarded to it. Die in case of error.
splitRunArgs
  :: Verbosity
  -> LocalBuildInfo
  -> [String]
  -> IO (Executable, [String])
splitRunArgs :: Verbosity
-> LocalBuildInfo -> [String] -> IO (Executable, [String])
splitRunArgs Verbosity
verbosity LocalBuildInfo
lbi [String]
args =
  case Either String (Bool, Executable, [String])
whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest)
    Left String
err -> do
      Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> Maybe String -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
`traverse_` Maybe String
maybeWarning -- If there is a warning, print it.
      Verbosity -> CabalInstallException -> IO (Executable, [String])
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO (Executable, [String]))
-> CabalInstallException -> IO (Executable, [String])
forall a b. (a -> b) -> a -> b
$ String -> CabalInstallException
SplitRunArgs String
err
    Right (Bool
True, Executable
exe, [String]
xs) -> (Executable, [String]) -> IO (Executable, [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Executable
exe, [String]
xs)
    Right (Bool
False, Executable
exe, [String]
xs) -> do
      let addition :: String
addition =
            String
" Interpreting all parameters to `run` as a parameter to"
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" the default executable."
      -- If there is a warning, print it together with the addition.
      Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> Maybe String -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
`traverse_` (String -> String) -> Maybe String -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
addition) Maybe String
maybeWarning
      (Executable, [String]) -> IO (Executable, [String])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Executable
exe, [String]
xs)
  where
    pkg_descr :: PackageDescription
pkg_descr = LocalBuildInfo -> PackageDescription
localPkgDescr LocalBuildInfo
lbi
    whichExecutable
      :: Either
          String -- Error string.
          ( Bool -- If it was manually chosen.
          , Executable -- The executable.
          , [String] -- The remaining parameters.
          )
    whichExecutable :: Either String (Bool, Executable, [String])
whichExecutable = case ([Executable]
enabledExes, [String]
args) of
      ([], [String]
_) -> String -> Either String (Bool, Executable, [String])
forall a b. a -> Either a b
Left String
"Couldn't find any enabled executables."
      ([Executable
exe], []) -> (Bool, Executable, [String])
-> Either String (Bool, Executable, [String])
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Executable
exe, [])
      ([Executable
exe], (String
x : [String]
xs))
        | String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== UnqualComponentName -> String
unUnqualComponentName (Executable -> UnqualComponentName
exeName Executable
exe) -> (Bool, Executable, [String])
-> Either String (Bool, Executable, [String])
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Executable
exe, [String]
xs)
        | Bool
otherwise -> (Bool, Executable, [String])
-> Either String (Bool, Executable, [String])
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Executable
exe, [String]
args)
      ([Executable]
_, []) ->
        String -> Either String (Bool, Executable, [String])
forall a b. a -> Either a b
Left (String -> Either String (Bool, Executable, [String]))
-> String -> Either String (Bool, Executable, [String])
forall a b. (a -> b) -> a -> b
$
          String
"This package contains multiple executables. "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"You must pass the executable name as the first argument "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"to 'cabal run'."
      ([Executable]
_, (String
x : [String]
xs)) ->
        case (Executable -> Bool) -> [Executable] -> Maybe Executable
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Executable
exe -> UnqualComponentName -> String
unUnqualComponentName (Executable -> UnqualComponentName
exeName Executable
exe) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
x) [Executable]
enabledExes of
          Maybe Executable
Nothing -> String -> Either String (Bool, Executable, [String])
forall a b. a -> Either a b
Left (String -> Either String (Bool, Executable, [String]))
-> String -> Either String (Bool, Executable, [String])
forall a b. (a -> b) -> a -> b
$ String
"No executable named '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'."
          Just Executable
exe -> (Bool, Executable, [String])
-> Either String (Bool, Executable, [String])
forall a. a -> Either String a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Executable
exe, [String]
xs)
      where
        enabledExes :: [Executable]
enabledExes = (Executable -> Bool) -> [Executable] -> [Executable]
forall a. (a -> Bool) -> [a] -> [a]
filter (BuildInfo -> Bool
buildable (BuildInfo -> Bool)
-> (Executable -> BuildInfo) -> Executable -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Executable -> BuildInfo
buildInfo) (PackageDescription -> [Executable]
executables PackageDescription
pkg_descr)

    maybeWarning :: Maybe String
    maybeWarning :: Maybe String
maybeWarning = case [String]
args of
      [] -> Maybe String
forall a. Maybe a
Nothing
      (String
x : [String]
_) -> UnqualComponentName
-> [(UnqualComponentName, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> UnqualComponentName
mkUnqualComponentName String
x) [(UnqualComponentName, String)]
components
      where
        components :: [(UnqualComponentName, String)] -- Component name, message.
        components :: [(UnqualComponentName, String)]
components =
          [ (UnqualComponentName
name, String
"The executable '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> String
forall a. Pretty a => a -> String
prettyShow UnqualComponentName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is disabled.")
          | Executable
e <- PackageDescription -> [Executable]
executables PackageDescription
pkg_descr
          , Bool -> Bool
not (Bool -> Bool) -> (Executable -> Bool) -> Executable -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildInfo -> Bool
buildable (BuildInfo -> Bool)
-> (Executable -> BuildInfo) -> Executable -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Executable -> BuildInfo
buildInfo (Executable -> Bool) -> Executable -> Bool
forall a b. (a -> b) -> a -> b
$ Executable
e
          , let name :: UnqualComponentName
name = Executable -> UnqualComponentName
exeName Executable
e
          ]
            [(UnqualComponentName, String)]
-> [(UnqualComponentName, String)]
-> [(UnqualComponentName, String)]
forall a. [a] -> [a] -> [a]
++ [ ( UnqualComponentName
name
                 , String
"There is a test-suite '"
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> String
forall a. Pretty a => a -> String
prettyShow UnqualComponentName
name
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"',"
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but the `run` command is only for executables."
                 )
               | TestSuite
t <- PackageDescription -> [TestSuite]
testSuites PackageDescription
pkg_descr
               , let name :: UnqualComponentName
name = TestSuite -> UnqualComponentName
testName TestSuite
t
               ]
            [(UnqualComponentName, String)]
-> [(UnqualComponentName, String)]
-> [(UnqualComponentName, String)]
forall a. [a] -> [a] -> [a]
++ [ ( UnqualComponentName
name
                 , String
"There is a benchmark '"
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> String
forall a. Pretty a => a -> String
prettyShow UnqualComponentName
name
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"',"
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" but the `run` command is only for executables."
                 )
               | Benchmark
b <- PackageDescription -> [Benchmark]
benchmarks PackageDescription
pkg_descr
               , let name :: UnqualComponentName
name = Benchmark -> UnqualComponentName
benchmarkName Benchmark
b
               ]

-- | Run a given executable.
run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO ()
run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO ()
run Verbosity
verbosity LocalBuildInfo
lbi Executable
exe [String]
exeArgs = do
  curDir <- IO String
getCurrentDirectory
  let buildPref = LocalBuildInfo -> String
buildDir LocalBuildInfo
lbi
      pkg_descr = LocalBuildInfo -> PackageDescription
localPkgDescr LocalBuildInfo
lbi
      dataDirEnvVar =
        ( PackageDescription -> String -> String
pkgPathEnvVar PackageDescription
pkg_descr String
"datadir"
        , String
curDir String -> String -> String
</> PackageDescription -> String
dataDir PackageDescription
pkg_descr
        )

  (path, runArgs) <-
    let exeName' = UnqualComponentName -> String
forall a. Pretty a => a -> String
prettyShow (UnqualComponentName -> String) -> UnqualComponentName -> String
forall a b. (a -> b) -> a -> b
$ Executable -> UnqualComponentName
exeName Executable
exe
     in case compilerFlavor (compiler lbi) of
          CompilerFlavor
GHCJS -> do
            let (String
script, String
cmd, [String]
cmdArgs) =
                  ProgramDb -> String -> (String, String, [String])
GHCJS.runCmd
                    (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
                    (String
buildPref String -> String -> String
</> String
exeName' String -> String -> String
</> String
exeName')
            script' <- String -> IO String
tryCanonicalizePath String
script
            return (cmd, cmdArgs ++ [script'])
          CompilerFlavor
_ -> do
            p <-
              String -> IO String
tryCanonicalizePath (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$
                String
buildPref String -> String -> String
</> String
exeName' String -> String -> String
</> (String
exeName' String -> String -> String
<.> Platform -> String
exeExtension (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi))
            return (p, [])

  env <- (dataDirEnvVar :) <$> getEnvironment
  -- Add (DY)LD_LIBRARY_PATH if needed
  env' <-
    if withDynExe lbi
      then do
        let (Platform _ os) = hostPlatform lbi
        clbi <- case componentNameTargets' pkg_descr lbi (CExeName (exeName exe)) of
          [TargetInfo
target] -> ComponentLocalBuildInfo -> IO ComponentLocalBuildInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetInfo -> ComponentLocalBuildInfo
targetCLBI TargetInfo
target)
          [] -> Verbosity -> CabalInstallException -> IO ComponentLocalBuildInfo
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
CouldNotFindExecutable
          [TargetInfo]
_ -> Verbosity -> CabalInstallException -> IO ComponentLocalBuildInfo
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalInstallException
FoundMultipleMatchingExes
        paths <- depLibraryPaths True False lbi clbi
        return (addLibraryPath os paths env)
      else return env
  notice verbosity $ "Running " ++ prettyShow (exeName exe) ++ "..."
  rawSystemExitWithEnv verbosity path (runArgs ++ exeArgs) env'