From b2b9c2f6a081cc2493e870f3ad0d4a88f1ba3e9d Mon Sep 17 00:00:00 2001
From: sheaf <sam.derbyshire@gmail.com>
Date: Mon, 4 Mar 2024 15:08:25 +0100
Subject: [PATCH] Testsuite: pass -i argument to runghc invocations
This commit modifies the generation of runghc commands to pass an
additional -i argument to account for the change in working directory.
This ensures that, in the testsuite, runghc is able to see other modules.
For example, an invocation of runghc to run a Custom Setup script will
now properly see the modules imported, e.g. if one has a directory
structure like
test.cabal
Setup.hs
SetupDep.hs
and Setup.hs imports SetupDep.hs.
---
.../PackageTests/SetupDep/Setup.hs | 6 ++++++
.../PackageTests/SetupDep/SetupDep.hs | 6 ++++++
.../PackageTests/SetupDep/cabal.project | 1 +
.../PackageTests/SetupDep/setup-dep.cabal | 16 ++++++++++++++
.../PackageTests/SetupDep/setup.out | 5 +++++
.../PackageTests/SetupDep/setup.test.hs | 4 ++++
cabal-testsuite/src/Test/Cabal/Script.hs | 21 +++++++++++++------
cabal-testsuite/src/Test/Cabal/Server.hs | 2 +-
8 files changed, 54 insertions(+), 7 deletions(-)
create mode 100644 cabal-testsuite/PackageTests/SetupDep/Setup.hs
create mode 100644 cabal-testsuite/PackageTests/SetupDep/SetupDep.hs
create mode 100644 cabal-testsuite/PackageTests/SetupDep/cabal.project
create mode 100644 cabal-testsuite/PackageTests/SetupDep/setup-dep.cabal
create mode 100644 cabal-testsuite/PackageTests/SetupDep/setup.out
create mode 100644 cabal-testsuite/PackageTests/SetupDep/setup.test.hs
diff --git a/cabal-testsuite/PackageTests/SetupDep/Setup.hs b/cabal-testsuite/PackageTests/SetupDep/Setup.hs
new file mode 100644
index 0000000000..89d816ae6d
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupDep/Setup.hs
@@ -0,0 +1,6 @@
+module Main where
+
+import SetupDep ( depMain )
+
+main :: IO ()
+main = depMain
diff --git a/cabal-testsuite/PackageTests/SetupDep/SetupDep.hs b/cabal-testsuite/PackageTests/SetupDep/SetupDep.hs
new file mode 100644
index 0000000000..55220d8ba4
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupDep/SetupDep.hs
@@ -0,0 +1,6 @@
+module SetupDep where
+
+import Distribution.Simple
+
+depMain :: IO ()
+depMain = defaultMain
diff --git a/cabal-testsuite/PackageTests/SetupDep/cabal.project b/cabal-testsuite/PackageTests/SetupDep/cabal.project
new file mode 100644
index 0000000000..e6fdbadb43
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupDep/cabal.project
@@ -0,0 +1 @@
+packages: .
diff --git a/cabal-testsuite/PackageTests/SetupDep/setup-dep.cabal b/cabal-testsuite/PackageTests/SetupDep/setup-dep.cabal
new file mode 100644
index 0000000000..78d47d16da
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupDep/setup-dep.cabal
@@ -0,0 +1,16 @@
+cabal-version: 2.2
+name: setup-dep
+version: 0.1.0.0
+synopsis: Test for a Setup.hs with a dependency
+license: BSD-3-Clause
+author: NA
+maintainer: NA
+category: Testing
+build-type: Custom
+
+custom-setup
+ setup-depends: Cabal, base
+
+library
+ build-depends: base
+ default-language: Haskell2010
diff --git a/cabal-testsuite/PackageTests/SetupDep/setup.out b/cabal-testsuite/PackageTests/SetupDep/setup.out
new file mode 100644
index 0000000000..1e49680dc0
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupDep/setup.out
@@ -0,0 +1,5 @@
+# Setup configure
+Configuring setup-dep-0.1.0.0...
+# Setup build
+Preprocessing library for setup-dep-0.1.0.0...
+Building library for setup-dep-0.1.0.0...
diff --git a/cabal-testsuite/PackageTests/SetupDep/setup.test.hs b/cabal-testsuite/PackageTests/SetupDep/setup.test.hs
new file mode 100644
index 0000000000..2df426a5db
--- /dev/null
+++ b/cabal-testsuite/PackageTests/SetupDep/setup.test.hs
@@ -0,0 +1,4 @@
+import Test.Cabal.Prelude
+main = setupTest $ do
+ setup "configure" []
+ setup "build" []
diff --git a/cabal-testsuite/src/Test/Cabal/Script.hs b/cabal-testsuite/src/Test/Cabal/Script.hs
index 943ea784c8..308c390140 100644
--- a/cabal-testsuite/src/Test/Cabal/Script.hs
+++ b/cabal-testsuite/src/Test/Cabal/Script.hs
@@ -77,23 +77,32 @@ runghc senv mb_cwd env_overrides script_path args = do
-- script with 'runghc'.
runnerCommand :: ScriptEnv -> Maybe FilePath -> [(String, Maybe String)]
-> FilePath -> [String] -> IO (FilePath, [String])
-runnerCommand senv _mb_cwd _env_overrides script_path args = do
+runnerCommand senv mb_cwd _env_overrides script_path args = do
(prog, _) <- requireProgram verbosity runghcProgram (runnerProgramDb senv)
return (programPath prog,
runghc_args ++ ["--"] ++ map ("--ghc-arg="++) ghc_args ++ [script_path] ++ args)
where
verbosity = runnerVerbosity senv
runghc_args = []
- ghc_args = runnerGhcArgs senv
+ ghc_args = runnerGhcArgs senv mb_cwd
-- | Compute the GHC flags to invoke 'runghc' with under a 'ScriptEnv'.
-runnerGhcArgs :: ScriptEnv -> [String]
-runnerGhcArgs senv =
+runnerGhcArgs :: ScriptEnv -> Maybe FilePath -> [String]
+runnerGhcArgs senv mb_cwd =
renderGhcOptions (runnerCompiler senv) (runnerPlatform senv) ghc_options
where
ghc_options = M.mempty { ghcOptPackageDBs = runnerPackageDbStack senv
, ghcOptPackages = toNubListR (runnerPackages senv)
, ghcOptHideAllPackages = Flag True
-- Avoid picking stray module files that look
- -- like our imports
- , ghcOptSourcePathClear = Flag True }
+ -- like our imports...
+ , ghcOptSourcePathClear = Flag True
+ -- ... yet retain the current directory as an included
+ -- directory, e.g. so that we can compile a Setup.hs
+ -- script which imports a locally defined module.
+ -- See the PackageTests/SetupDep test.
+ , ghcOptSourcePath = toNubListR $
+ case mb_cwd of
+ Nothing -> []
+ Just wd -> [wd]
+ }
diff --git a/cabal-testsuite/src/Test/Cabal/Server.hs b/cabal-testsuite/src/Test/Cabal/Server.hs
index 450c6f660c..9d302237a2 100644
--- a/cabal-testsuite/src/Test/Cabal/Server.hs
+++ b/cabal-testsuite/src/Test/Cabal/Server.hs
@@ -215,7 +215,7 @@ runMain ref m = do
startServer :: Chan ServerLogMsg -> ScriptEnv -> IO Server
startServer chan senv = do
(prog, _) <- requireProgram verbosity ghcProgram (runnerProgramDb senv)
- let ghc_args = runnerGhcArgs senv ++ ["--interactive", "-v0", "-ignore-dot-ghci"]
+ let ghc_args = runnerGhcArgs senv Nothing ++ ["--interactive", "-v0", "-ignore-dot-ghci"]
proc_spec = (proc (programPath prog) ghc_args) {
create_group = True,
-- Closing fds is VERY important to avoid
--
GitLab