Run.hs 6.33 KB
Newer Older
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
1
{-# LANGUAGE CPP #-}
refold's avatar
refold committed
2
3
4
5
6
7
8
9
10
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Client.Run
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- Implementation of the 'run' command.
-----------------------------------------------------------------------------

11
module Distribution.Client.Run ( run, splitRunArgs )
refold's avatar
refold committed
12
13
       where

14
15
16
import Distribution.Types.TargetInfo     (targetCLBI)
import Distribution.Types.LocalBuildInfo (componentNameTargets)

17
import Distribution.Client.Utils             (tryCanonicalizePath)
refold's avatar
refold committed
18
19

import Distribution.PackageDescription       (Executable (..),
20
21
22
23
                                              TestSuite(..),
                                              Benchmark(..),
                                              PackageDescription (..),
                                              BuildInfo(buildable))
24
import Distribution.Simple.Compiler          (compilerFlavor, CompilerFlavor(..))
refold's avatar
refold committed
25
26
import Distribution.Simple.Build.PathsModule (pkgPathEnvVar)
import Distribution.Simple.BuildPaths        (exeExtension)
27
28
import Distribution.Simple.LocalBuildInfo    (ComponentName (..),
                                              LocalBuildInfo (..),
29
                                              depLibraryPaths)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
30
31
import Distribution.Simple.Utils             (die, notice, warn,
                                              rawSystemExitWithEnv,
32
33
                                              addLibraryPath)
import Distribution.System                   (Platform (..))
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
34
import Distribution.Verbosity                (Verbosity)
refold's avatar
refold committed
35

36
37
import qualified Distribution.Simple.GHCJS as GHCJS

Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
38
#if !MIN_VERSION_base(4,8,0)
refold's avatar
refold committed
39
import Data.Functor                          ((<$>))
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
40
#endif
refold's avatar
refold committed
41
import Data.List                             (find)
42
import Data.Foldable                         (traverse_)
43
import System.Directory                      (getCurrentDirectory)
44
import Distribution.Compat.Environment       (getEnvironment)
refold's avatar
refold committed
45
46
47
import System.FilePath                       ((<.>), (</>))


48
-- | Return the executable to run and any extra arguments that should be
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
49
50
51
52
-- forwarded to it. Die in case of error.
splitRunArgs :: Verbosity -> LocalBuildInfo -> [String]
             -> IO (Executable, [String])
splitRunArgs verbosity lbi args =
53
  case whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
54
55
56
    Left err               -> do
      warn verbosity `traverse_` maybeWarning -- If there is a warning, print it.
      die err
57
    Right (True, exe, xs)  -> return (exe, xs)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
58
59
60
61
62
63
    Right (False, exe, xs) -> do
      let addition = " Interpreting all parameters to `run` as a parameter to"
                     ++ " the default executable."
      -- If there is a warning, print it together with the addition.
      warn verbosity `traverse_` fmap (++addition) maybeWarning
      return (exe, xs)
64
  where
65
    pkg_descr = localPkgDescr lbi
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
66
67
68
69
    whichExecutable :: Either String       -- Error string.
                              ( Bool       -- If it was manually chosen.
                              , Executable -- The executable.
                              , [String]   -- The remaining parameters.
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
                              )
    whichExecutable = case (enabledExes, args) of
      ([]   , _)           -> Left "Couldn't find any enabled executables."
      ([exe], [])          -> return (False, exe, [])
      ([exe], (x:xs))
        | x == exeName exe -> return (True, exe, xs)
        | otherwise        -> return (False, exe, args)
      (_    , [])          -> Left
        $ "This package contains multiple executables. "
        ++ "You must pass the executable name as the first argument "
        ++ "to 'cabal run'."
      (_    , (x:xs))      ->
        case find (\exe -> exeName exe == x) enabledExes of
          Nothing  -> Left $ "No executable named '" ++ x ++ "'."
          Just exe -> return (True, exe, xs)
85
      where
86
        enabledExes = filter (buildable . buildInfo) (executables pkg_descr)
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
87

88
89
90
91
    maybeWarning :: Maybe String
    maybeWarning = case args of
      []    -> Nothing
      (x:_) -> lookup x components
92
      where
Mikhail Glushenkov's avatar
Mikhail Glushenkov committed
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
        components :: [(String, String)] -- Component name, message.
        components =
          [ (name, "The executable '" ++ name ++ "' is disabled.")
          | e <- executables pkg_descr
          , not . buildable . buildInfo $ e, let name = exeName e]

          ++ [ (name, "There is a test-suite '" ++ name ++ "',"
                      ++ " but the `run` command is only for executables.")
             | t <- testSuites pkg_descr
             , let name = testName t]

          ++ [ (name, "There is a benchmark '" ++ name ++ "',"
                      ++ " but the `run` command is only for executables.")
             | b <- benchmarks pkg_descr
             , let name = benchmarkName b]
108
109
110
111
112
113
114
115
116
117

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

118
119
120
121
122
123
124
125
126
127
128
129
130
  (path, runArgs) <-
    case compilerFlavor (compiler lbi) of
      GHCJS -> do
        let (script, cmd, cmdArgs) =
              GHCJS.runCmd (withPrograms lbi)
                           (buildPref </> exeName exe </> exeName exe)
        script' <- tryCanonicalizePath script
        return (cmd, cmdArgs ++ [script'])
      _     -> do
         p <- tryCanonicalizePath $
            buildPref </> exeName exe </> (exeName exe <.> exeExtension)
         return (p, [])

131
  env  <- (dataDirEnvVar:) <$> getEnvironment
132
  -- Add (DY)LD_LIBRARY_PATH if needed
133
  env' <- if withDynExe lbi
134
             then do let (Platform _ os) = hostPlatform lbi
135
136
137
138
                     clbi <- case componentNameTargets lbi (CExeName (exeName exe)) of
                                [target] -> return (targetCLBI target)
                                [] -> die "run: Could not find executable in LocalBuildInfo"
                                _ -> die "run: Found multiple matching exes in LocalBuildInfo"
139
                     paths <- depLibraryPaths True False lbi clbi
140
                     return (addLibraryPath os paths env)
141
             else return env
142
  notice verbosity $ "Running " ++ exeName exe ++ "..."
143
  rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env'