Skip to content

Commit 1c12c57

Browse files
hvrhvr
committed
Proof-of-concept for #5916
This needs more refinement and is a first draft trying to address #5916
1 parent 03b7406 commit 1c12c57

File tree

6 files changed

+122
-54
lines changed

6 files changed

+122
-54
lines changed

‎cabal-testsuite/Setup.hs

Lines changed: 75 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,77 @@
1+
module Main (main) where
2+
3+
import Distribution.Backpack
14
import Distribution.Simple
5+
import Distribution.Simple.BuildPaths
6+
import Distribution.Simple.LocalBuildInfo
7+
import Distribution.Simple.Setup
8+
import Distribution.Simple.Utils
9+
import Distribution.Types.LocalBuildInfo
10+
import Distribution.Types.ModuleRenaming
11+
import Distribution.Types.UnqualComponentName
12+
13+
import System.Directory
14+
import System.FilePath
15+
216
main :: IO ()
3-
main = defaultMain
4-
5-
-- Although this looks like the Simple build type, it is in fact vital that
6-
-- we use this Setup.hs because we need to compile against the very same
7-
-- version of the Cabal library that the test suite will be compiled
8-
-- against. When this happens, it will mean that we'll be able to
9-
-- read the LocalBuildInfo of our build environment, which we will
10-
-- subsequently use to make decisions about PATHs etc. Important!
17+
main = defaultMainWithHooks simpleUserHooks
18+
{ buildHook = \pkg lbi hooks flags -> do
19+
generateScriptEnvModule lbi flags
20+
buildHook simpleUserHooks pkg lbi hooks flags
21+
}
22+
23+
generateScriptEnvModule :: LocalBuildInfo -> BuildFlags -> IO ()
24+
generateScriptEnvModule lbi flags = do
25+
lbiPackageDbStack <- mapM canonicalizePackageDB (withPackageDB lbi)
26+
27+
createDirectoryIfMissing True moduledir
28+
rewriteFileEx verbosity (moduledir </> "ScriptEnv0.hs") $ unlines
29+
[ "module Test.Cabal.ScriptEnv0 where"
30+
, ""
31+
, "import Distribution.Simple"
32+
, "import Distribution.System (Platform(..), Arch(..), OS(..))"
33+
, "import Distribution.Types.ModuleRenaming"
34+
, "import Distribution.Simple.Program.Db"
35+
, "import Distribution.Backpack (OpenUnitId)"
36+
, "import Data.Map (fromList)"
37+
, ""
38+
, "lbiPackageDbStack :: PackageDBStack"
39+
, "lbiPackageDbStack = " ++ show lbiPackageDbStack
40+
, ""
41+
, "lbiPlatform :: Platform"
42+
, "lbiPlatform = " ++ show (hostPlatform lbi)
43+
, ""
44+
, "lbiCompiler :: Compiler"
45+
, "lbiCompiler = " ++ show (compiler lbi)
46+
, ""
47+
, "lbiPackages :: [(OpenUnitId, ModuleRenaming)]"
48+
, "lbiPackages = read " ++ show (show (cabalTestsPackages lbi))
49+
, ""
50+
, "lbiProgramDb :: ProgramDb"
51+
, "lbiProgramDb = read " ++ show (show (withPrograms lbi))
52+
, ""
53+
, "lbiWithSharedLib :: Bool"
54+
, "lbiWithSharedLib = " ++ show (withSharedLib lbi)
55+
]
56+
where
57+
verbosity = fromFlagOrDefault minBound (buildVerbosity flags)
58+
moduledir = libAutogenDir </> "Test" </> "Cabal"
59+
-- fixme: use component-specific folder
60+
libAutogenDir = autogenPackageModulesDir lbi
61+
62+
-- | Convert package database into absolute path, so that
63+
-- if we change working directories in a subprocess we get the correct database.
64+
canonicalizePackageDB :: PackageDB -> IO PackageDB
65+
canonicalizePackageDB (SpecificPackageDB path)
66+
= SpecificPackageDB `fmap` canonicalizePath path
67+
canonicalizePackageDB x = return x
68+
69+
-- | Compute the set of @-package-id@ flags which would be passed when
70+
-- building the public library. Assumes that the public library is
71+
-- non-Backpack.
72+
cabalTestsPackages :: LocalBuildInfo -> [(OpenUnitId, ModuleRenaming)]
73+
cabalTestsPackages lbi =
74+
case componentNameCLBIs lbi (CExeName (mkUnqualComponentName "cabal-tests")) of
75+
[clbi] -> -- [ (unUnitId $ unDefUnitId duid,rn) | (DefiniteUnitId duid, rn) <- componentIncludes clbi ]
76+
componentIncludes clbi
77+
_ -> error "cabalTestsPackages"

‎cabal-testsuite/Setup.simple.hs

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
module Main (main) where
2+
3+
import Distribution.Simple
4+
5+
main :: IO ()
6+
main = defaultMain

‎cabal-testsuite/Test/Cabal/Monad.hs

Lines changed: 8 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -66,8 +66,7 @@ import Distribution.System
6666
import Distribution.Simple.Program.Db
6767
import Distribution.Simple.Program
6868
import Distribution.Simple.Configure
69-
( getPersistBuildConfig, configCompilerEx )
70-
import Distribution.Types.LocalBuildInfo
69+
( configCompilerEx )
7170
import Distribution.Version
7271
import Distribution.Text
7372
import Distribution.Package
@@ -240,20 +239,19 @@ runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do
240239
script_base = dropExtensions script_filename
241240
-- Canonicalize this so that it is stable across working directory changes
242241
script_dir <- canonicalizePath script_dir0
243-
lbi <- getPersistBuildConfig dist_dir
244242
let verbosity = normal -- TODO: configurable
245-
senv <- mkScriptEnv verbosity lbi
243+
senv <- mkScriptEnv verbosity
246244
-- Add test suite specific programs
247245
let program_db0 =
248246
addKnownPrograms
249247
([gitProgram, hackageRepoToolProgram, cabalProgram, diffProgram] ++ builtinPrograms)
250-
(withPrograms lbi)
248+
(runnerProgramDb senv)
251249
-- Reconfigure according to user flags
252250
let cargs = testCommonArgs args
253251

254252
-- Reconfigure GHC
255253
(comp, platform, program_db2) <- case argGhcPath cargs of
256-
Nothing -> return (compiler lbi, hostPlatform lbi, program_db0)
254+
Nothing -> return (runnerCompiler senv, runnerPlatform senv, program_db0)
257255
Just ghc_path -> do
258256
-- All the things that get updated paths from
259257
-- configCompilerEx. The point is to make sure
@@ -274,7 +272,7 @@ runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do
274272
-- we don't pay for things we don't need. A bit difficult
275273
-- to do in the current design.
276274
configCompilerEx
277-
(Just (compilerFlavor (compiler lbi)))
275+
(Just (compilerFlavor (runnerCompiler senv)))
278276
(Just ghc_path)
279277
Nothing
280278
program_db1
@@ -294,7 +292,7 @@ runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do
294292

295293
let db_stack =
296294
case argGhcPath (testCommonArgs args) of
297-
Nothing -> withPackageDB lbi
295+
Nothing -> runnerPackageDbStack senv -- NB: canonicalized
298296
-- Can't use the build package db stack since they
299297
-- are all for the wrong versions! TODO: Make
300298
-- this configurable
@@ -311,9 +309,9 @@ runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do
311309
testVerbosity = verbosity,
312310
testMtimeChangeDelay = Nothing,
313311
testScriptEnv = senv,
314-
testSetupPath = dist_dir </> "setup" </> "setup",
312+
testSetupPath = dist_dir </> "build" </> "setup" </> "setup",
315313
testSkipSetupTests = argSkipSetupTests (testCommonArgs args),
316-
testHaveCabalShared = withSharedLib lbi,
314+
testHaveCabalShared = runnerWithSharedLib senv,
317315
testEnvironment =
318316
-- Try to avoid Unicode output
319317
[ ("LC_ALL", Just "C")

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

Lines changed: 15 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -9,13 +9,10 @@ module Test.Cabal.Script (
99
) where
1010

1111
import Test.Cabal.Run
12+
import Test.Cabal.ScriptEnv0
1213

1314
import Distribution.Backpack
1415
import Distribution.Types.ModuleRenaming
15-
import Distribution.Types.LocalBuildInfo
16-
import Distribution.Types.ComponentLocalBuildInfo
17-
import Distribution.Types.ComponentName
18-
import Distribution.Types.UnqualComponentName
1916
import Distribution.Utils.NubList
2017
import Distribution.Simple.Program.Db
2118
import Distribution.Simple.Program.Builtin
@@ -26,9 +23,9 @@ import Distribution.Verbosity
2623
import Distribution.System
2724
import Distribution.Simple.Setup (Flag(..))
2825

29-
import System.Directory
3026
import qualified Data.Monoid as M
3127

28+
3229
-- | The runner environment, which contains all of the important
3330
-- parameters for invoking GHC. Mostly subset of 'LocalBuildInfo'.
3431
data ScriptEnv = ScriptEnv
@@ -38,40 +35,36 @@ data ScriptEnv = ScriptEnv
3835
, runnerPlatform :: Platform
3936
, runnerCompiler :: Compiler
4037
, runnerPackages :: [(OpenUnitId, ModuleRenaming)]
38+
, runnerWithSharedLib :: Bool
4139
}
4240

41+
{-
42+
4343
-- | Convert package database into absolute path, so that
4444
-- if we change working directories in a subprocess we get the correct database.
4545
canonicalizePackageDB :: PackageDB -> IO PackageDB
4646
canonicalizePackageDB (SpecificPackageDB path)
4747
= SpecificPackageDB `fmap` canonicalizePath path
4848
canonicalizePackageDB x = return x
4949
50+
-}
51+
5052
-- | Create a 'ScriptEnv' from a 'LocalBuildInfo' configured with
5153
-- the GHC that we want to use.
52-
mkScriptEnv :: Verbosity -> LocalBuildInfo -> IO ScriptEnv
53-
mkScriptEnv verbosity lbi = do
54-
package_db <- mapM canonicalizePackageDB (withPackageDB lbi)
54+
mkScriptEnv :: Verbosity -> IO ScriptEnv
55+
mkScriptEnv verbosity =
5556
return $ ScriptEnv
5657
{ runnerVerbosity = verbosity
57-
, runnerProgramDb = withPrograms lbi
58-
, runnerPackageDbStack = package_db
59-
, runnerPlatform = hostPlatform lbi
60-
, runnerCompiler = compiler lbi
58+
, runnerProgramDb = lbiProgramDb
59+
, runnerPackageDbStack = lbiPackageDbStack
60+
, runnerPlatform = lbiPlatform
61+
, runnerCompiler = lbiCompiler
6162
-- NB: the set of packages available to test.hs scripts will COINCIDE
6263
-- with the dependencies on the cabal-testsuite library
63-
, runnerPackages = cabalTestsPackages lbi
64+
, runnerPackages = lbiPackages
65+
, runnerWithSharedLib = lbiWithSharedLib
6466
}
6567

66-
-- | Compute the set of @-package-id@ flags which would be passed when
67-
-- building the public library. Assumes that the public library is
68-
-- non-Backpack.
69-
cabalTestsPackages :: LocalBuildInfo -> [(OpenUnitId, ModuleRenaming)]
70-
cabalTestsPackages lbi =
71-
case componentNameCLBIs lbi (CExeName (mkUnqualComponentName "cabal-tests")) of
72-
[clbi] -> componentIncludes clbi
73-
_ -> error "cabalTestsPackages"
74-
7568
-- | Run a script with 'runghc', under the 'ScriptEnv'.
7669
runghc :: ScriptEnv -> Maybe FilePath -> [(String, Maybe String)]
7770
-> FilePath -> [String] -> IO Result

‎cabal-testsuite/cabal-testsuite.cabal

Lines changed: 17 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,8 @@
1+
cabal-version: 2.4
12
name: cabal-testsuite
23
version: 3.0.0.0
34
copyright: 2003-2019, Cabal Development Team (see AUTHORS file)
4-
license: BSD3
5+
license: BSD-3-Clause
56
license-file: LICENSE
67
author: Cabal Development Team <[email protected]>
78
maintainer: [email protected]
@@ -11,7 +12,6 @@ synopsis: Test suite for Cabal and cabal-install
1112
description:
1213
This package defines a shared test suite for Cabal and cabal-install.
1314
category: Distribution
14-
cabal-version: >=1.10
1515
build-type: Custom
1616

1717
extra-source-files:
@@ -32,8 +32,15 @@ library
3232
Test.Cabal.Server
3333
Test.Cabal.Monad
3434
Test.Cabal.CheckArMetadata
35+
36+
other-modules:
37+
Test.Cabal.ScriptEnv0
38+
autogen-modules:
39+
Test.Cabal.ScriptEnv0
40+
3541
build-depends:
3642
aeson ==1.4.*,
43+
containers,
3744
attoparsec,
3845
async,
3946
base,
@@ -73,13 +80,13 @@ executable cabal-tests
7380
transformers,
7481
exceptions
7582
default-language: Haskell2010
83+
build-tool-depends: cabal-testsuite:setup
84+
85+
executable setup
86+
main-is: Setup.simple.hs
87+
build-depends: base, Cabal == 3.0.0.0
88+
default-language: Haskell2010
7689

7790
custom-setup
78-
-- It's important that we pick the exact same version of lib:Cabal
79-
-- both here and for cabal-tests itself. Without this constraint,
80-
-- the solver would pick the in-tree Cabal for cabal-tests's
81-
-- lib:Cabal dependency, and some stable lib:Cabal version for its
82-
-- custom-setup's one (due to 'setupMaxCabalVersionConstraint' in
83-
-- 'D.C.ProjectPlanning').
84-
setup-depends: Cabal == 3.0.0.0,
85-
base
91+
setup-depends: Cabal == 2.4.*,
92+
base, filepath, directory

‎cabal-testsuite/main/cabal-tests.hs

Lines changed: 1 addition & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,6 @@ import Test.Cabal.Server
99
import Test.Cabal.Monad
1010

1111
import Distribution.Verbosity (normal, verbose, Verbosity)
12-
import Distribution.Simple.Configure (getPersistBuildConfig)
1312
import Distribution.Simple.Utils (getDirectoryContentsRecursive)
1413

1514
import Options.Applicative
@@ -110,10 +109,8 @@ main = do
110109
Nothing -> guessDistDir
111110
when (verbosity >= verbose) $
112111
hPutStrLn stderr $ "Using dist dir: " ++ dist_dir
113-
lbi <- getPersistBuildConfig dist_dir
114-
115112
-- Get ready to go!
116-
senv <- mkScriptEnv verbosity lbi
113+
senv <- mkScriptEnv verbosity
117114
let runTest runner path
118115
= runner Nothing [] path $
119116
["--builddir", dist_dir, path] ++ renderCommonArgs (mainCommonArgs args)

0 commit comments

Comments
 (0)