Proof-of-concept for haskell#5916

This needs more refinement and is a first draft trying to address haskell#5916

cabal-testsuite/Setup.hs

@@ -1,10 +1,77 @@
+module Main (main) where
+
+import Distribution.Backpack
 import Distribution.Simple
+import Distribution.Simple.BuildPaths
+import Distribution.Simple.LocalBuildInfo
+import Distribution.Simple.Setup
+import Distribution.Simple.Utils
+import Distribution.Types.LocalBuildInfo
+import Distribution.Types.ModuleRenaming
+import Distribution.Types.UnqualComponentName
+
+import System.Directory
+import System.FilePath
+
 main :: IO ()
-main = defaultMain
-
--- Although this looks like the Simple build type, it is in fact vital that
--- we use this Setup.hs because we need to compile against the very same
--- version of the Cabal library that the test suite will be compiled
--- against.  When this happens, it will mean that we'll be able to
--- read the LocalBuildInfo of our build environment, which we will
--- subsequently use to make decisions about PATHs etc.  Important!
+main = defaultMainWithHooks simpleUserHooks
+    { buildHook = \pkg lbi hooks flags -> do
+        generateScriptEnvModule lbi flags
+        buildHook simpleUserHooks pkg lbi hooks flags
+    }
+
+generateScriptEnvModule :: LocalBuildInfo -> BuildFlags -> IO ()
+generateScriptEnvModule lbi flags = do
+    lbiPackageDbStack <- mapM canonicalizePackageDB (withPackageDB lbi)
+
+    createDirectoryIfMissing True moduledir
+    rewriteFileEx verbosity (moduledir </> "ScriptEnv0.hs") $ unlines
+      [ "module Test.Cabal.ScriptEnv0 where"
+      , ""
+      , "import Distribution.Simple"
+      , "import Distribution.System (Platform(..), Arch(..), OS(..))"
+      , "import Distribution.Types.ModuleRenaming"
+      , "import Distribution.Simple.Program.Db"
+      , "import Distribution.Backpack (OpenUnitId)"
+      , "import Data.Map (fromList)"
+      , ""
+      , "lbiPackageDbStack :: PackageDBStack"
+      , "lbiPackageDbStack = " ++ show lbiPackageDbStack
+      , ""
+      , "lbiPlatform :: Platform"
+      , "lbiPlatform = " ++ show (hostPlatform lbi)
+      , ""
+      , "lbiCompiler :: Compiler"
+      , "lbiCompiler = " ++ show (compiler lbi)
+      , ""
+      , "lbiPackages :: [(OpenUnitId, ModuleRenaming)]"
+      , "lbiPackages = read " ++ show (show (cabalTestsPackages lbi))
+      , ""
+      , "lbiProgramDb :: ProgramDb"
+      , "lbiProgramDb = read " ++ show (show (withPrograms lbi))
+      , ""
+      , "lbiWithSharedLib :: Bool"
+      , "lbiWithSharedLib = " ++ show (withSharedLib lbi)
+      ]
+  where
+    verbosity = fromFlagOrDefault minBound (buildVerbosity flags)
+    moduledir = libAutogenDir </> "Test" </> "Cabal"
+    -- fixme: use component-specific folder
+    libAutogenDir = autogenPackageModulesDir lbi
+
+-- | Convert package database into absolute path, so that
+-- if we change working directories in a subprocess we get the correct database.
+canonicalizePackageDB :: PackageDB -> IO PackageDB
+canonicalizePackageDB (SpecificPackageDB path)
+    = SpecificPackageDB `fmap` canonicalizePath path
+canonicalizePackageDB x = return x
+
+-- | Compute the set of @-package-id@ flags which would be passed when
+-- building the public library.  Assumes that the public library is
+-- non-Backpack.
+cabalTestsPackages :: LocalBuildInfo -> [(OpenUnitId, ModuleRenaming)]
+cabalTestsPackages lbi =
+    case componentNameCLBIs lbi (CExeName (mkUnqualComponentName "cabal-tests")) of
+        [clbi] -> -- [ (unUnitId $ unDefUnitId duid,rn) | (DefiniteUnitId duid, rn) <- componentIncludes clbi ]
+                  componentIncludes clbi
+        _ -> error "cabalTestsPackages"

cabal-testsuite/Setup.simple.hs

@@ -0,0 +1,6 @@
+module Main (main) where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain

cabal-testsuite/Test/Cabal/Monad.hs

@@ -66,8 +66,7 @@ import Distribution.System
 import Distribution.Simple.Program.Db
 import Distribution.Simple.Program
 import Distribution.Simple.Configure
-    ( getPersistBuildConfig, configCompilerEx )
-import Distribution.Types.LocalBuildInfo
+    ( configCompilerEx )
 import Distribution.Version
 import Distribution.Text
 import Distribution.Package
@@ -240,20 +239,19 @@ runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do
         script_base = dropExtensions script_filename
     -- Canonicalize this so that it is stable across working directory changes
     script_dir <- canonicalizePath script_dir0
-    lbi <- getPersistBuildConfig dist_dir
     let verbosity = normal -- TODO: configurable
-    senv <- mkScriptEnv verbosity lbi
+    senv <- mkScriptEnv verbosity
     -- Add test suite specific programs
     let program_db0 =
             addKnownPrograms
                 ([gitProgram, hackageRepoToolProgram, cabalProgram, diffProgram] ++ builtinPrograms)
-                (withPrograms lbi)
+                (runnerProgramDb senv)
     -- Reconfigure according to user flags
     let cargs = testCommonArgs args
 
     -- Reconfigure GHC
     (comp, platform, program_db2) <- case argGhcPath cargs of
-        Nothing -> return (compiler lbi, hostPlatform lbi, program_db0)
+        Nothing -> return (runnerCompiler senv, runnerPlatform senv, program_db0)
         Just ghc_path -> do
             -- All the things that get updated paths from
             -- configCompilerEx.  The point is to make sure
@@ -274,7 +272,7 @@ runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do
             -- we don't pay for things we don't need.  A bit difficult
             -- to do in the current design.
             configCompilerEx
-                (Just (compilerFlavor (compiler lbi)))
+                (Just (compilerFlavor (runnerCompiler senv)))
                 (Just ghc_path)
                 Nothing
                 program_db1
@@ -294,7 +292,7 @@ runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do
 
     let db_stack =
             case argGhcPath (testCommonArgs args) of
-                Nothing -> withPackageDB lbi
+                Nothing -> runnerPackageDbStack senv -- NB: canonicalized
                 -- Can't use the build package db stack since they
                 -- are all for the wrong versions!  TODO: Make
                 -- this configurable
@@ -311,9 +309,9 @@ runTestM mode m = withSystemTempDirectory "cabal-testsuite" $ \tmp_dir -> do
                     testVerbosity = verbosity,
                     testMtimeChangeDelay = Nothing,
                     testScriptEnv = senv,
-                    testSetupPath = dist_dir </> "setup" </> "setup",
+                    testSetupPath = dist_dir </> "build" </> "setup" </> "setup",
                     testSkipSetupTests =  argSkipSetupTests (testCommonArgs args),
-                    testHaveCabalShared = withSharedLib lbi,
+                    testHaveCabalShared = runnerWithSharedLib senv,
                     testEnvironment =
                         -- Try to avoid Unicode output
                         [ ("LC_ALL", Just "C")

cabal-testsuite/Test/Cabal/Script.hs

@@ -9,13 +9,10 @@ module Test.Cabal.Script (
 ) where
 
 import Test.Cabal.Run
+import Test.Cabal.ScriptEnv0
 
 import Distribution.Backpack
 import Distribution.Types.ModuleRenaming
-import Distribution.Types.LocalBuildInfo
-import Distribution.Types.ComponentLocalBuildInfo
-import Distribution.Types.ComponentName
-import Distribution.Types.UnqualComponentName
 import Distribution.Utils.NubList
 import Distribution.Simple.Program.Db
 import Distribution.Simple.Program.Builtin
@@ -26,9 +23,9 @@ import Distribution.Verbosity
 import Distribution.System
 import Distribution.Simple.Setup (Flag(..))
 
-import System.Directory
 import qualified Data.Monoid as M
 
+
 -- | The runner environment, which contains all of the important
 -- parameters for invoking GHC.  Mostly subset of 'LocalBuildInfo'.
 data ScriptEnv = ScriptEnv
@@ -38,40 +35,36 @@ data ScriptEnv = ScriptEnv
         , runnerPlatform        :: Platform
         , runnerCompiler        :: Compiler
         , runnerPackages        :: [(OpenUnitId, ModuleRenaming)]
+        , runnerWithSharedLib   :: Bool
         }
 
+{-
+
 -- | Convert package database into absolute path, so that
 -- if we change working directories in a subprocess we get the correct database.
 canonicalizePackageDB :: PackageDB -> IO PackageDB
 canonicalizePackageDB (SpecificPackageDB path)
     = SpecificPackageDB `fmap` canonicalizePath path
 canonicalizePackageDB x = return x
 
+-}
+
 -- | Create a 'ScriptEnv' from a 'LocalBuildInfo' configured with
 -- the GHC that we want to use.
-mkScriptEnv :: Verbosity -> LocalBuildInfo -> IO ScriptEnv
-mkScriptEnv verbosity lbi = do
-  package_db <- mapM canonicalizePackageDB (withPackageDB lbi)
+mkScriptEnv :: Verbosity -> IO ScriptEnv
+mkScriptEnv verbosity =
   return $ ScriptEnv
     { runnerVerbosity       = verbosity
-    , runnerProgramDb       = withPrograms  lbi
-    , runnerPackageDbStack  = package_db
-    , runnerPlatform        = hostPlatform  lbi
-    , runnerCompiler        = compiler      lbi
+    , runnerProgramDb       = lbiProgramDb
+    , runnerPackageDbStack  = lbiPackageDbStack
+    , runnerPlatform        = lbiPlatform
+    , runnerCompiler        = lbiCompiler
     -- NB: the set of packages available to test.hs scripts will COINCIDE
     -- with the dependencies on the cabal-testsuite library
-    , runnerPackages        = cabalTestsPackages   lbi
+    , runnerPackages        = lbiPackages
+    , runnerWithSharedLib   = lbiWithSharedLib
     }
 
--- | Compute the set of @-package-id@ flags which would be passed when
--- building the public library.  Assumes that the public library is
--- non-Backpack.
-cabalTestsPackages :: LocalBuildInfo -> [(OpenUnitId, ModuleRenaming)]
-cabalTestsPackages lbi =
-    case componentNameCLBIs lbi (CExeName (mkUnqualComponentName "cabal-tests")) of
-        [clbi] -> componentIncludes clbi
-        _ -> error "cabalTestsPackages"
-
 -- | Run a script with 'runghc', under the 'ScriptEnv'.
 runghc :: ScriptEnv -> Maybe FilePath -> [(String, Maybe String)]
        -> FilePath -> [String] -> IO Result

cabal-testsuite/cabal-testsuite.cabal

@@ -1,7 +1,8 @@
+cabal-version: 2.4
 name:          cabal-testsuite
 version:       3.0.0.0
 copyright:     2003-2019, Cabal Development Team (see AUTHORS file)
-license:       BSD3
+license:       BSD-3-Clause
 license-file:  LICENSE
 author:        Cabal Development Team <[email protected]>
 maintainer:    [email protected]
@@ -11,7 +12,6 @@ synopsis:      Test suite for Cabal and cabal-install
 description:
   This package defines a shared test suite for Cabal and cabal-install.
 category:       Distribution
-cabal-version:  >=1.10
 build-type:     Custom
 
 extra-source-files:
@@ -32,8 +32,15 @@ library
     Test.Cabal.Server
     Test.Cabal.Monad
     Test.Cabal.CheckArMetadata
+
+  other-modules:
+    Test.Cabal.ScriptEnv0
+  autogen-modules:
+    Test.Cabal.ScriptEnv0
+
   build-depends:
     aeson ==1.4.*,
+    containers,
     attoparsec,
     async,
     base,
@@ -73,13 +80,13 @@ executable cabal-tests
     transformers,
     exceptions
   default-language: Haskell2010
+  build-tool-depends: cabal-testsuite:setup
+
+executable setup
+  main-is: Setup.simple.hs
+  build-depends: base, Cabal == 3.0.0.0
+  default-language: Haskell2010
 
 custom-setup
-  -- It's important that we pick the exact same version of lib:Cabal
-  -- both here and for cabal-tests itself. Without this constraint,
-  -- the solver would pick the in-tree Cabal for cabal-tests's
-  -- lib:Cabal dependency, and some stable lib:Cabal version for its
-  -- custom-setup's one (due to 'setupMaxCabalVersionConstraint' in
-  -- 'D.C.ProjectPlanning').
-  setup-depends: Cabal == 3.0.0.0,
-                 base
+  setup-depends: Cabal == 2.4.*,
+                 base, filepath, directory

cabal-testsuite/main/cabal-tests.hs

@@ -9,7 +9,6 @@ import Test.Cabal.Server
 import Test.Cabal.Monad
 
 import Distribution.Verbosity        (normal, verbose, Verbosity)
-import Distribution.Simple.Configure (getPersistBuildConfig)
 import Distribution.Simple.Utils     (getDirectoryContentsRecursive)
 
 import Options.Applicative
@@ -110,10 +109,8 @@ main = do
                   Nothing -> guessDistDir
     when (verbosity >= verbose) $
         hPutStrLn stderr $ "Using dist dir: " ++ dist_dir
-    lbi <- getPersistBuildConfig dist_dir
-
     -- Get ready to go!
-    senv <- mkScriptEnv verbosity lbi
+    senv <- mkScriptEnv verbosity
     let runTest runner path
             = runner Nothing [] path $
                 ["--builddir", dist_dir, path] ++ renderCommonArgs (mainCommonArgs args)