-----------------------------------------------------------------------------
{-# LANGUAGE DataKinds #-}

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

-- |
-- 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 (PackageDBX (..))
import Distribution.Simple.Build (addInternalBuildToolsFixed)
import Distribution.Simple.BuildPaths (exeExtension)
import Distribution.Simple.Compiler (CompilerFlavor (..), compilerFlavor)
import Distribution.Simple.Flag (fromFlag)
import Distribution.Simple.LocalBuildInfo
  ( ComponentName (..)
  , LocalBuildInfo (..)
  , absoluteWorkingDirLBI
  , buildDir
  , depLibraryPaths
  , interpretSymbolicPathLBI
  , mbWorkDirLBI
  )
import Distribution.Simple.Program.Db
import Distribution.Simple.Program.Find
import Distribution.Simple.Program.Run
import Distribution.Simple.Register (internalPackageDBPath)

import Distribution.Simple.Setup (ConfigFlags (..))
import Distribution.Simple.Utils
  ( addLibraryPath
  , dieWithException
  , notice
  , rawSystemExitWithEnvCwd
  , warn
  )
import Distribution.System (Platform (..))
import Distribution.Types.UnqualComponentName

import qualified Distribution.Simple.GHCJS as GHCJS

import Distribution.Client.Errors
import Distribution.Utils.Path

-- | 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 -> [FilePath] -> IO (Executable, [FilePath])
splitRunArgs Verbosity
verbosity LocalBuildInfo
lbi [FilePath]
args =
  case Either FilePath (Bool, Executable, [FilePath])
whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest)
    Left FilePath
err -> do
      Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> Maybe FilePath -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
`traverse_` Maybe FilePath
maybeWarning -- If there is a warning, print it.
      Verbosity -> CabalInstallException -> IO (Executable, [FilePath])
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalInstallException -> IO (Executable, [FilePath]))
-> CabalInstallException -> IO (Executable, [FilePath])
forall a b. (a -> b) -> a -> b
$ FilePath -> CabalInstallException
SplitRunArgs FilePath
err
    Right (Bool
True, Executable
exe, [FilePath]
xs) -> (Executable, [FilePath]) -> IO (Executable, [FilePath])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Executable
exe, [FilePath]
xs)
    Right (Bool
False, Executable
exe, [FilePath]
xs) -> do
      let addition :: FilePath
addition =
            FilePath
" Interpreting all parameters to `run` as a parameter to"
              FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" the default executable."
      -- If there is a warning, print it together with the addition.
      Verbosity -> FilePath -> IO ()
warn Verbosity
verbosity (FilePath -> IO ()) -> Maybe FilePath -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
`traverse_` (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
addition) Maybe FilePath
maybeWarning
      (Executable, [FilePath]) -> IO (Executable, [FilePath])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Executable
exe, [FilePath]
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 FilePath (Bool, Executable, [FilePath])
whichExecutable = case ([Executable]
enabledExes, [FilePath]
args) of
      ([], [FilePath]
_) -> FilePath -> Either FilePath (Bool, Executable, [FilePath])
forall a b. a -> Either a b
Left FilePath
"Couldn't find any enabled executables."
      ([Executable
exe], []) -> (Bool, Executable, [FilePath])
-> Either FilePath (Bool, Executable, [FilePath])
forall a. a -> Either FilePath a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Executable
exe, [])
      ([Executable
exe], (FilePath
x : [FilePath]
xs))
        | FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== UnqualComponentName -> FilePath
unUnqualComponentName (Executable -> UnqualComponentName
exeName Executable
exe) -> (Bool, Executable, [FilePath])
-> Either FilePath (Bool, Executable, [FilePath])
forall a. a -> Either FilePath a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Executable
exe, [FilePath]
xs)
        | Bool
otherwise -> (Bool, Executable, [FilePath])
-> Either FilePath (Bool, Executable, [FilePath])
forall a. a -> Either FilePath a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Executable
exe, [FilePath]
args)
      ([Executable]
_, []) ->
        FilePath -> Either FilePath (Bool, Executable, [FilePath])
forall a b. a -> Either a b
Left (FilePath -> Either FilePath (Bool, Executable, [FilePath]))
-> FilePath -> Either FilePath (Bool, Executable, [FilePath])
forall a b. (a -> b) -> a -> b
$
          FilePath
"This package contains multiple executables. "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"You must pass the executable name as the first argument "
            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"to 'cabal run'."
      ([Executable]
_, (FilePath
x : [FilePath]
xs)) ->
        case (Executable -> Bool) -> [Executable] -> Maybe Executable
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Executable
exe -> UnqualComponentName -> FilePath
unUnqualComponentName (Executable -> UnqualComponentName
exeName Executable
exe) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
x) [Executable]
enabledExes of
          Maybe Executable
Nothing -> FilePath -> Either FilePath (Bool, Executable, [FilePath])
forall a b. a -> Either a b
Left (FilePath -> Either FilePath (Bool, Executable, [FilePath]))
-> FilePath -> Either FilePath (Bool, Executable, [FilePath])
forall a b. (a -> b) -> a -> b
$ FilePath
"No executable named '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'."
          Just Executable
exe -> (Bool, Executable, [FilePath])
-> Either FilePath (Bool, Executable, [FilePath])
forall a. a -> Either FilePath a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Executable
exe, [FilePath]
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 FilePath
maybeWarning = case [FilePath]
args of
      [] -> Maybe FilePath
forall a. Maybe a
Nothing
      (FilePath
x : [FilePath]
_) -> UnqualComponentName
-> [(UnqualComponentName, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (FilePath -> UnqualComponentName
mkUnqualComponentName FilePath
x) [(UnqualComponentName, FilePath)]
components
      where
        components :: [(UnqualComponentName, String)] -- Component name, message.
        components :: [(UnqualComponentName, FilePath)]
components =
          [ (UnqualComponentName
name, FilePath
"The executable '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow UnqualComponentName
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' 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, FilePath)]
-> [(UnqualComponentName, FilePath)]
-> [(UnqualComponentName, FilePath)]
forall a. [a] -> [a] -> [a]
++ [ ( UnqualComponentName
name
                 , FilePath
"There is a test-suite '"
                    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow UnqualComponentName
name
                    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"',"
                    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" 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, FilePath)]
-> [(UnqualComponentName, FilePath)]
-> [(UnqualComponentName, FilePath)]
forall a. [a] -> [a] -> [a]
++ [ ( UnqualComponentName
name
                 , FilePath
"There is a benchmark '"
                    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow UnqualComponentName
name
                    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"',"
                    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" 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 -> [FilePath] -> IO ()
run Verbosity
verbosity LocalBuildInfo
lbi Executable
exe [FilePath]
exeArgs = do
  AbsolutePath ('Dir Pkg)
curDir <- LocalBuildInfo -> IO (AbsolutePath ('Dir Pkg))
absoluteWorkingDirLBI LocalBuildInfo
lbi
  let distPref :: SymbolicPath Pkg ('Dir Dist)
distPref = Flag (SymbolicPath Pkg ('Dir Dist)) -> SymbolicPath Pkg ('Dir Dist)
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag (SymbolicPath Pkg ('Dir Dist))
 -> SymbolicPath Pkg ('Dir Dist))
-> Flag (SymbolicPath Pkg ('Dir Dist))
-> SymbolicPath Pkg ('Dir Dist)
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
configDistPref (ConfigFlags -> Flag (SymbolicPath Pkg ('Dir Dist)))
-> ConfigFlags -> Flag (SymbolicPath Pkg ('Dir Dist))
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> ConfigFlags
configFlags LocalBuildInfo
lbi
      buildPref :: SymbolicPath Pkg ('Dir Build)
buildPref = LocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
buildDir LocalBuildInfo
lbi
      pkg_descr :: PackageDescription
pkg_descr = LocalBuildInfo -> PackageDescription
localPkgDescr LocalBuildInfo
lbi
      i :: SymbolicPathX allowAbsolute Pkg to -> FilePath
i = LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> FilePath
interpretSymbolicPathLBI LocalBuildInfo
lbi -- See Note [Symbolic paths] in Distribution.Utils.Path
      mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi
      internalPkgDb :: SymbolicPath Pkg ('Dir PkgDB)
internalPkgDb = LocalBuildInfo
-> SymbolicPath Pkg ('Dir Dist) -> SymbolicPath Pkg ('Dir PkgDB)
internalPackageDBPath LocalBuildInfo
lbi SymbolicPath Pkg ('Dir Dist)
distPref
      lbiForExe :: LocalBuildInfo
lbiForExe =
        LocalBuildInfo
lbi
          { withPackageDB = withPackageDB lbi ++ [SpecificPackageDB internalPkgDb]
          , -- Include any build-tool-depends on build tools internal to the current package.
            withPrograms =
              addInternalBuildToolsFixed
                (Just curDir)
                pkg_descr
                lbi
                (buildInfo exe)
                (withPrograms lbi)
          }

  (FilePath
path, [FilePath]
runArgs) <-
    let exeName' :: FilePath
exeName' = UnqualComponentName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (UnqualComponentName -> FilePath)
-> UnqualComponentName -> FilePath
forall a b. (a -> b) -> a -> b
$ Executable -> UnqualComponentName
exeName Executable
exe
     in case Compiler -> CompilerFlavor
compilerFlavor (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbiForExe) of
          CompilerFlavor
GHCJS -> do
            let (FilePath
script, FilePath
cmd, [FilePath]
cmdArgs) =
                  ProgramDb -> FilePath -> (FilePath, FilePath, [FilePath])
GHCJS.runCmd
                    (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbiForExe)
                    (SymbolicPath Pkg ('Dir Build) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPath Pkg ('Dir Build)
buildPref FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
exeName' FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
exeName')
            FilePath
script' <- FilePath -> IO FilePath
tryCanonicalizePath FilePath
script
            (FilePath, [FilePath]) -> IO (FilePath, [FilePath])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
cmd, [FilePath]
cmdArgs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
script'])
          CompilerFlavor
_ -> do
            FilePath
p <-
              FilePath -> IO FilePath
tryCanonicalizePath (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$
                SymbolicPath Pkg ('Dir Build) -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPath Pkg ('Dir Build)
buildPref FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> FilePath
exeName' FilePath -> FilePath -> FilePath
forall p q r. PathLike p q r => p -> q -> r
</> (FilePath
exeName' FilePath -> FilePath -> FilePath
forall p. FileLike p => p -> FilePath -> p
<.> Platform -> FilePath
exeExtension (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbiForExe))
            (FilePath, [FilePath]) -> IO (FilePath, [FilePath])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
p, [])

  -- Compute the appropriate environment for running the executable
  let progDb :: ProgramDb
progDb = LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbiForExe
      pathVar :: ProgramSearchPath
pathVar = ProgramDb -> ProgramSearchPath
progSearchPath ProgramDb
progDb
      envOverrides :: [(FilePath, Maybe FilePath)]
envOverrides = ProgramDb -> [(FilePath, Maybe FilePath)]
progOverrideEnv ProgramDb
progDb
  FilePath
newPath <- ProgramSearchPath -> IO FilePath
programSearchPathAsPATHVar ProgramSearchPath
pathVar
  [(FilePath, FilePath)]
env <- [(FilePath, Maybe FilePath)] -> IO [(FilePath, FilePath)]
getFullEnvironment ([(FilePath
"PATH", FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
newPath)] [(FilePath, Maybe FilePath)]
-> [(FilePath, Maybe FilePath)] -> [(FilePath, Maybe FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, Maybe FilePath)]
envOverrides)

  -- Add (DY)LD_LIBRARY_PATH if needed
  [(FilePath, FilePath)]
env' <-
    if LocalBuildInfo -> Bool
withDynExe LocalBuildInfo
lbiForExe
      then do
        let (Platform Arch
_ OS
os) = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbiForExe
        ComponentLocalBuildInfo
clbi <- case PackageDescription
-> LocalBuildInfo -> ComponentName -> [TargetInfo]
componentNameTargets' PackageDescription
pkg_descr LocalBuildInfo
lbiForExe (UnqualComponentName -> ComponentName
CExeName (Executable -> UnqualComponentName
exeName Executable
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
        [FilePath]
paths <- Bool
-> Bool
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> IO [FilePath]
depLibraryPaths Bool
True Bool
False LocalBuildInfo
lbiForExe ComponentLocalBuildInfo
clbi
        [(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (OS
-> [FilePath] -> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
addLibraryPath OS
os [FilePath]
paths [(FilePath, FilePath)]
env)
      else [(FilePath, FilePath)] -> IO [(FilePath, FilePath)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(FilePath, FilePath)]
env

  Verbosity -> FilePath -> IO ()
notice Verbosity
verbosity (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Running " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ UnqualComponentName -> FilePath
forall a. Pretty a => a -> FilePath
prettyShow (Executable -> UnqualComponentName
exeName Executable
exe) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"..."
  Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> FilePath
-> [FilePath]
-> [(FilePath, FilePath)]
-> IO ()
forall (to :: FileOrDir).
Verbosity
-> Maybe (SymbolicPath CWD to)
-> FilePath
-> [FilePath]
-> [(FilePath, FilePath)]
-> IO ()
rawSystemExitWithEnvCwd Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir FilePath
path ([FilePath]
runArgs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
exeArgs) [(FilePath, FilePath)]
env'