cabal-testsuite/src/Test/Cabal/Script.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE RankNTypes #-}
   3 {-# LANGUAGE TypeApplications #-}
   4
   5 -- | Functionality for invoking Haskell scripts with the correct
   6 -- package database setup.
   7 module Test.Cabal.Script (
   8     ScriptEnv(..),
   9     mkScriptEnv,
  10     runnerGhcArgs,
  11     runnerCommand,
  12     runghc,
  13 ) where
  14
  15 import Test.Cabal.Run
  16 import Test.Cabal.ScriptEnv0
  17
  18 import Distribution.Backpack
  19 import Distribution.Types.ModuleRenaming
  20 import Distribution.Utils.NubList
  21 import Distribution.Utils.Path
  22 import Distribution.Simple.Program.Db
  23 import Distribution.Simple.Program.Builtin
  24 import Distribution.Simple.Program.GHC
  25 import Distribution.Simple.Program
  26 import Distribution.Simple.Compiler
  27 import Distribution.Verbosity
  28 import Distribution.System
  29 import Distribution.Simple.Setup (Flag(..))
  30
  31 import qualified Data.Monoid as M
  32
  33
  34 -- | The runner environment, which contains all of the important
  35 -- parameters for invoking GHC.  Mostly subset of 'LocalBuildInfo'.
  36 data ScriptEnv = ScriptEnv
  37         { runnerProgramDb       :: ProgramDb
  38         , runnerPackageDbStack  :: PackageDBStack
  39         , runnerVerbosity       :: Verbosity
  40         , runnerPlatform        :: Platform
  41         , runnerCompiler        :: Compiler
  42         , runnerPackages        :: [(OpenUnitId, ModuleRenaming)]
  43         , runnerWithSharedLib   :: Bool
  44         }
  45     deriving Show
  46
  47 {-
  48
  49 -- | Convert package database into absolute path, so that
  50 -- if we change working directories in a subprocess we get the correct database.
  51 canonicalizePackageDB :: PackageDB -> IO PackageDB
  52 canonicalizePackageDB (SpecificPackageDB path)
  53     = SpecificPackageDB `fmap` canonicalizePath path
  54 canonicalizePackageDB x = return x
  55
  56 -}
  57
  58 -- | Create a 'ScriptEnv' from a 'LocalBuildInfo' configured with
  59 -- the GHC that we want to use.
  60 mkScriptEnv :: Verbosity -> IO ScriptEnv
  61 mkScriptEnv verbosity =
  62   return $ ScriptEnv
  63     { runnerVerbosity       = verbosity
  64     , runnerProgramDb       = lbiProgramDb
  65     , runnerPackageDbStack  = lbiPackageDbStack
  66     , runnerPlatform        = lbiPlatform
  67     , runnerCompiler        = lbiCompiler
  68     -- NB: the set of packages available to test.hs scripts will COINCIDE
  69     -- with the dependencies on the cabal-testsuite library
  70     , runnerPackages        = lbiPackages
  71     , runnerWithSharedLib   = lbiWithSharedLib
  72     }
  73
  74 -- | Run a script with 'runghc', under the 'ScriptEnv'.
  75 runghc :: ScriptEnv -> Maybe FilePath -> [(String, Maybe String)]
  76        -> FilePath -> [String] -> IO Result
  77 runghc senv mb_cwd env_overrides script_path args = do
  78     (real_path, real_args) <- runnerCommand senv mb_cwd env_overrides script_path args
  79     run (runnerVerbosity senv) mb_cwd env_overrides real_path real_args Nothing
  80
  81 -- | Compute the command line which should be used to run a Haskell
  82 -- script with 'runghc'.
  83 runnerCommand :: ScriptEnv -> Maybe FilePath -> [(String, Maybe String)]
  84               -> FilePath -> [String] -> IO (FilePath, [String])
  85 runnerCommand senv mb_cwd _env_overrides script_path args = do
  86     (prog, _) <- requireProgram verbosity runghcProgram (runnerProgramDb senv)
  87     return $
  88       (programPath prog,
  89         runghc_args ++ ["--"] ++ map ("--ghc-arg="++) ghc_args ++ [script_path] ++ args)
  90   where
  91     verbosity = runnerVerbosity senv
  92     runghc_args = []
  93     ghc_args = runnerGhcArgs senv mb_cwd
  94
  95 -- | Compute the GHC flags to invoke 'runghc' with under a 'ScriptEnv'.
  96 runnerGhcArgs :: ScriptEnv -> Maybe FilePath -> [String]
  97 runnerGhcArgs senv mb_cwd =
  98   renderGhcOptions (runnerCompiler senv) (runnerPlatform senv) ghc_options
  99   where
 100     ghc_options = M.mempty { ghcOptPackageDBs = runnerPackageDbStack senv
 101                            , ghcOptPackages   = toNubListR (runnerPackages senv)
 102                            , ghcOptHideAllPackages = Flag True
 103                            -- Avoid picking stray module files that look
 104                            -- like our imports...
 105                            , ghcOptSourcePathClear = Flag True
 106                            -- ... yet retain the current directory as an included
 107                            -- directory, e.g. so that we can compile a Setup.hs
 108                            -- script which imports a locally defined module.
 109                            -- See the PackageTests/SetupDep test.
 110                            , ghcOptSourcePath = toNubListR $
 111                               case mb_cwd of
 112                                 Nothing -> []
 113                                 Just {} -> [sameDirectory]
 114                             }