Commit 18459e7b authored by Oleg Grenrus's avatar Oleg Grenrus
Browse files

Add SymbolicPath, use for hs-source-dirs

parent f4e87303
......@@ -24,6 +24,7 @@ import Distribution.ModuleName (ModuleName)
import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
import Distribution.SPDX (License, LicenseExceptionId, LicenseExpression, LicenseId, LicenseRef, SimpleLicenseExpression)
import Distribution.System (Arch, OS)
import Distribution.Utils.Path (SymbolicPath)
import Distribution.Utils.ShortText (ShortText)
import Distribution.Version (Version, VersionRange)
import Language.Haskell.Extension (Extension, KnownExtension, Language)
......@@ -120,6 +121,8 @@ instance NoThunks ShortText where
instance NoThunks a => NoThunks (PerCompilerFlavor a)
instance (Typeable a, Typeable b) => NoThunks (SymbolicPath a b)
deriving via (OnlyCheckWhnf LicenseId) instance NoThunks LicenseId
deriving via (OnlyCheckWhnf LicenseExceptionId) instance NoThunks LicenseExceptionId
deriving via (CheckFoldableNamed NonEmptySet a) instance NoThunks a => NoThunks (NonEmptySet a)
......
......@@ -443,7 +443,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["src"],
hsSourceDirs = [SymbolicPath "src"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......@@ -566,7 +566,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["test"],
hsSourceDirs = [SymbolicPath "test"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......@@ -653,7 +653,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["test"],
hsSourceDirs = [SymbolicPath "test"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......
......@@ -47,7 +47,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["exe"],
hsSourceDirs = [SymbolicPath "exe"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......@@ -143,7 +143,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["exe"],
hsSourceDirs = [SymbolicPath "exe"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......@@ -235,7 +235,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["exe"],
hsSourceDirs = [SymbolicPath "exe"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......@@ -323,7 +323,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["exe"],
hsSourceDirs = [SymbolicPath "exe"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......@@ -994,7 +994,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["utils"],
hsSourceDirs = [SymbolicPath "utils"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......@@ -3613,7 +3613,9 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["utils", "src"],
hsSourceDirs = [SymbolicPath
"utils",
SymbolicPath "src"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......@@ -6679,7 +6681,9 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["utils", "src"],
hsSourceDirs = [SymbolicPath
"utils",
SymbolicPath "src"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......@@ -9558,7 +9562,8 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["tests"],
hsSourceDirs = [SymbolicPath
"tests"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......@@ -66,7 +66,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["exe"],
hsSourceDirs = [SymbolicPath "exe"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......@@ -216,7 +216,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["library"],
hsSourceDirs = [SymbolicPath "library"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......@@ -332,7 +332,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["test"],
hsSourceDirs = [SymbolicPath "test"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......
......@@ -569,7 +569,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["src"],
hsSourceDirs = [SymbolicPath "src"],
hsc2hsOptions = [],
includeDirs = ["cbits"],
includes = [],
......
......@@ -569,7 +569,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["src"],
hsSourceDirs = [SymbolicPath "src"],
hsc2hsOptions = [],
includeDirs = ["cbits"],
includes = [],
......
......@@ -43,7 +43,8 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["str-example"],
hsSourceDirs = [SymbolicPath
"str-example"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......
......@@ -43,7 +43,8 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["str-example"],
hsSourceDirs = [SymbolicPath
"str-example"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......
......@@ -43,7 +43,8 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["str-example"],
hsSourceDirs = [SymbolicPath
"str-example"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......
......@@ -45,7 +45,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["src"],
hsSourceDirs = [SymbolicPath "src"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......
......@@ -520,7 +520,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["src"],
hsSourceDirs = [SymbolicPath "src"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......@@ -1250,7 +1250,8 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = [".", "src"],
hsSourceDirs = [SymbolicPath ".",
SymbolicPath "src"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......@@ -2075,7 +2076,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["src"],
hsSourceDirs = [SymbolicPath "src"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......
......@@ -71,7 +71,7 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["src"],
hsSourceDirs = [SymbolicPath "src"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......@@ -241,7 +241,8 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["tests"],
hsSourceDirs = [SymbolicPath
"tests"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......@@ -466,7 +467,8 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["tests"],
hsSourceDirs = [SymbolicPath
"tests"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......
......@@ -43,7 +43,8 @@ GenericPackageDescription
extraLibFlavours = [],
extraLibs = [],
frameworks = [],
hsSourceDirs = ["example-string"],
hsSourceDirs = [SymbolicPath
"example-string"],
hsc2hsOptions = [],
includeDirs = [],
includes = [],
......
......@@ -3,7 +3,6 @@ module UnitTests.Distribution.System
( tests
) where
import Control.Monad (liftM2)
import Distribution.Parsec
import Distribution.Pretty
import Distribution.System
......
......@@ -24,7 +24,7 @@ tests = testGroup "Distribution.Utils.Structured"
, testCase "SPDX.License" $ structureHash (Proxy :: Proxy License) @?= md5FromInteger 0xd3d4a09f517f9f75bc3d16370d5a853a
-- The difference is in encoding of newtypes
#if MIN_VERSION_base(4,7,0)
, testCase "GenericPackageDescription" $ structureHash (Proxy :: Proxy GenericPackageDescription) @?= md5FromInteger 0x355a3ad7e0e2ccbe0b1059d2eed4679c
, testCase "LocalBuildInfo" $ structureHash (Proxy :: Proxy LocalBuildInfo) @?= md5FromInteger 0x0d31007031ec48e0f6f0fd01f372ce62
, testCase "GenericPackageDescription" $ structureHash (Proxy :: Proxy GenericPackageDescription) @?= md5FromInteger 0x7c423920f9ef69d0bb662ced46d6c764
, testCase "LocalBuildInfo" $ structureHash (Proxy :: Proxy LocalBuildInfo) @?= md5FromInteger 0x2903e5b827c9fc28ac8353e22867939b
#endif
]
......@@ -84,54 +84,70 @@ module CabalDoctestSetup (
import Control.Monad
(when)
import Data.IORef
(modifyIORef, newIORef, readIORef)
import Data.List
(nub)
import Data.Maybe
(maybeToList, mapMaybe)
(mapMaybe, maybeToList)
import Data.String
(fromString)
import qualified Data.Foldable as F
(for_)
import qualified Data.Traversable as T
(traverse)
import Distribution.Package
(InstalledPackageId)
import Distribution.Package
(Package (..), PackageId, packageVersion)
(InstalledPackageId, Package (..))
import Distribution.PackageDescription
(BuildInfo (..), Executable (..), Library (..),
PackageDescription (), TestSuite (..))
(BuildInfo (..), Executable (..), GenericPackageDescription,
Library (..), PackageDescription, TestSuite (..))
import Distribution.Simple
(UserHooks (..), autoconfUserHooks, defaultMainWithHooks, simpleUserHooks)
#if !MIN_VERSION_Cabal(1,25,0)
import Distribution.Simple.BuildPaths
(autogenModulesDir)
#endif
(UserHooks (..), autoconfUserHooks, defaultMainWithHooks,
simpleUserHooks)
import Distribution.Simple.Compiler
(PackageDB (..), showCompilerId)
(CompilerFlavor (GHC), CompilerId (..), PackageDB (..), compilerId)
import Distribution.Simple.LocalBuildInfo
(ComponentLocalBuildInfo (componentPackageDeps), LocalBuildInfo (),
(ComponentLocalBuildInfo (componentPackageDeps), LocalBuildInfo,
compiler, withExeLBI, withLibLBI, withPackageDB, withTestLBI)
import Distribution.Simple.Setup
(BuildFlags (buildDistPref, buildVerbosity), fromFlag)
(BuildFlags (buildDistPref, buildVerbosity),
HaddockFlags (haddockDistPref, haddockVerbosity), emptyBuildFlags,
fromFlag)
import Distribution.Simple.Utils
(createDirectoryIfMissingVerbose)
(createDirectoryIfMissingVerbose, info)
import Distribution.Text
(display, simpleParse)
(display)
import System.FilePath
((</>))
import Data.IORef (newIORef, modifyIORef, readIORef)
import qualified Data.Foldable as F
(for_)
import qualified Data.Traversable as T
(traverse)
#if MIN_VERSION_Cabal(1,25,0)
import Distribution.Simple.BuildPaths
(autogenComponentModulesDir)
#else
import Distribution.Simple.BuildPaths
(autogenModulesDir)
#endif
#if MIN_VERSION_Cabal(2,0,0)
import Distribution.Types.MungedPackageId
(MungedPackageId)
import Distribution.Types.UnqualComponentName
(unUnqualComponentName)
-- For amendGPD
import Distribution.PackageDescription
(CondTree (..))
import Distribution.Types.GenericPackageDescription
(GenericPackageDescription (condTestSuites))
import Distribution.Version
(mkVersion)
#else
import Data.Version
(Version (..))
import Distribution.Package
(PackageId)
#endif
#if MIN_VERSION_Cabal(3,0,0)
......@@ -142,11 +158,16 @@ import Distribution.Simple.Utils
(findFile)
#endif
#if MIN_VERSION_Cabal(2,5,0)
#if MIN_VERSION_Cabal(3,0,0)
import Distribution.Types.LibraryName
(libraryNameString)
#endif
#if MIN_VERSION_Cabal(3,5,0)
import Distribution.Utils.Path
(getSymbolicPath)
#endif
#if MIN_VERSION_directory(1,2,2)
import System.Directory
(makeAbsolute)
......@@ -164,13 +185,23 @@ makeAbsolute p | isAbsolute p = return p
#endif
#if !MIN_VERSION_Cabal(3,0,0)
findFileEx :: Verbosity
-> [FilePath] -- ^search locations
-> FilePath -- ^File Name
-> IO FilePath
findFileEx _verbosity = findFile
findFileEx :: verbosity -> [FilePath] -> FilePath -> IO FilePath
findFileEx _ = findFile
#endif
#if !MIN_VERSION_Cabal(2,0,0)
mkVersion :: [Int] -> Version
mkVersion ds = Version ds []
#endif
#if !MIN_VERSION_Cabal(3,5,0)
getSymbolicPath :: FilePath -> FilePath
getSymbolicPath = id
#endif
-------------------------------------------------------------------------------
-- Mains
-------------------------------------------------------------------------------
-- | A default main with doctests:
--
......@@ -208,8 +239,23 @@ doctestsUserHooks testsuiteName =
addDoctestsUserHook :: String -> UserHooks -> UserHooks
addDoctestsUserHook testsuiteName uh = uh
{ buildHook = \pkg lbi hooks flags -> do
generateBuildModule testsuiteName flags pkg lbi
buildHook uh pkg lbi hooks flags
generateBuildModule testsuiteName flags pkg lbi
buildHook uh pkg lbi hooks flags
-- We use confHook to add "Build_Doctests" to otherModules and autogenModules.
--
-- We cannot use HookedBuildInfo as it let's alter only the library and executables.
, confHook = \(gpd, hbi) flags ->
confHook uh (amendGPD testsuiteName gpd, hbi) flags
, haddockHook = \pkg lbi hooks flags -> do
generateBuildModule testsuiteName (haddockToBuildFlags flags) pkg lbi
haddockHook uh pkg lbi hooks flags
}
-- | Convert only flags used by 'generateBuildModule'.
haddockToBuildFlags :: HaddockFlags -> BuildFlags
haddockToBuildFlags f = emptyBuildFlags
{ buildVerbosity = haddockVerbosity f
, buildDistPref = haddockDistPref f
}
data Name = NameLib (Maybe String) | NameExe String deriving (Eq, Show)
......@@ -253,9 +299,12 @@ generateBuildModule testSuiteName flags pkg lbi = do
let verbosity = fromFlag (buildVerbosity flags)
let distPref = fromFlag (buildDistPref flags)
-- Package DBs
-- Package DBs & environments
let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref </> "package.conf.inplace" ]
let dbFlags = "-hide-all-packages" : packageDbArgs dbStack
let envFlags
| ghcCanBeToldToIgnorePkgEnvs = [ "-package-env=-" ]
| otherwise = []
withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == fromString testSuiteName) $ do
#if MIN_VERSION_Cabal(1,25,0)
......@@ -270,6 +319,7 @@ generateBuildModule testSuiteName flags pkg lbi = do
-- First, we create the autogen'd module Build_doctests.
-- Initially populate Build_doctests with a simple preamble.
info verbosity $ "cabal-doctest: writing Build_doctests to " ++ buildDoctestsFile
writeFile buildDoctestsFile $ unlines
[ "module Build_doctests where"
, ""
......@@ -324,7 +374,7 @@ generateBuildModule testSuiteName flags pkg lbi = do
<- mapM makeAbsolute
$ compAutogenDir -- autogenerated files
: (distPref ++ "/build") -- preprocessed files (.hsc -> .hs); "build" is hardcoded in Cabal.
: hsSourceDirs compBI
: map getSymbolicPath (hsSourceDirs compBI)
includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs compBI
-- We clear all includes, so the CWD isn't used.
let iArgs' = map ("-i"++) iArgsNoPrefix
......@@ -356,6 +406,7 @@ generateBuildModule testSuiteName flags pkg lbi = do
[ iArgs
, additionalDirs
, includeArgs
, envFlags
, dbFlags
, cppFlags
, extensionArgs
......@@ -371,8 +422,8 @@ generateBuildModule testSuiteName flags pkg lbi = do
getBuildDoctests withExeLBI (NameExe . executableName) (const []) (Just . modulePath) buildInfo
components <- readIORef componentsRef
F.for_ components $ \(Component name pkgs flags' sources) -> do
let compSuffix = nameToString name
F.for_ components $ \(Component cmpName cmpPkgs cmpFlags cmpSources) -> do
let compSuffix = nameToString cmpName
pkgs_comp = "pkgs" ++ compSuffix
flags_comp = "flags" ++ compSuffix
module_sources_comp = "module_sources" ++ compSuffix
......@@ -381,13 +432,13 @@ generateBuildModule testSuiteName flags pkg lbi = do
appendFile buildDoctestsFile $ unlines
[ -- -package-id etc. flags
pkgs_comp ++ " :: [String]"
, pkgs_comp ++ " = " ++ show pkgs
, pkgs_comp ++ " = " ++ show cmpPkgs
, ""
, flags_comp ++ " :: [String]"
, flags_comp ++ " = " ++ show flags'
, flags_comp ++ " = " ++ show cmpFlags
, ""
, module_sources_comp ++ " :: [String]"
, module_sources_comp ++ " = " ++ show sources
, module_sources_comp ++ " = " ++ show cmpSources
, ""
]
......@@ -413,10 +464,14 @@ generateBuildModule testSuiteName flags pkg lbi = do
parseComponentName _ = Nothing
-- we do this check in Setup, as then doctests don't need to depend on Cabal
isOldCompiler = maybe False id $ do
a <- simpleParse $ showCompilerId $ compiler lbi
b <- simpleParse "7.5"
return $ packageVersion (a :: PackageId) < b
isNewCompiler = case compilerId $ compiler lbi of
CompilerId GHC v -> v >= mkVersion [7,6]
_ -> False
ghcCanBeToldToIgnorePkgEnvs :: Bool
ghcCanBeToldToIgnorePkgEnvs = case compilerId $ compiler lbi of
CompilerId GHC v -> v >= mkVersion [8,4,4]
_ -> False
formatDeps = map formatOne
formatOne (installedPkgId, pkgId)
......@@ -433,8 +488,8 @@ generateBuildModule testSuiteName flags pkg lbi = do
-- From Distribution.Simple.Program.GHC
packageDbArgs :: [PackageDB] -> [String]
packageDbArgs | isOldCompiler = packageDbArgsConf
| otherwise = packageDbArgsDb
packageDbArgs | isNewCompiler = packageDbArgsDb
| otherwise = packageDbArgsConf
-- GHC <7.6 uses '-package-conf' instead of '-package-db'.
packageDbArgsConf :: [PackageDB] -> [String]
......@@ -450,7 +505,7 @@ generateBuildModule testSuiteName flags pkg lbi = do
++ show dbstack
-- GHC >= 7.6 uses the '-package-db' flag. See
-- https://gitlab.haskell.org/ghc/ghc/-/issues/5977
-- https://ghc.haskell.org/trac/ghc/ticket/5977.
packageDbArgsDb :: [PackageDB] -> [String]
-- special cases to make arguments prettier in common scenarios
packageDbArgsDb dbstack = case dbstack of
......@@ -469,12 +524,11 @@ generateBuildModule testSuiteName flags pkg lbi = do
isSpecific _ = False
mbLibraryName :: Library -> Name
#if MIN_VERSION_Cabal(2,5,0)
-- Cabal-2.5 library's name is LibraryName
mbLibraryName = NameLib . fmap display . libraryNameString . libName
#if MIN_VERSION_Cabal(3,0,0)
mbLibraryName = NameLib . fmap unUnqualComponentName . libraryNameString . libName
#elif MIN_VERSION_Cabal(2,0,0)
-- Cabal-2.0 introduced internal libraries, which are named.
mbLibraryName = NameLib . fmap display . libName
mbLibraryName = NameLib . fmap unUnqualComponentName . libName
#else
-- Before that, there was only ever at most one library per
-- .cabal file, which has no name.
......@@ -496,3 +550,41 @@ testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo
-> [(InstalledPackageId, PackageId)]
#endif
testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys
amendGPD
:: String -- ^ doctests test-suite name
-> GenericPackageDescription
-> GenericPackageDescription
#if !(MIN_VERSION_Cabal(2,0,0))
amendGPD _ gpd = gpd
#else
amendGPD testSuiteName gpd = gpd
{ condTestSuites = map f (condTestSuites gpd)
}
where
f (name, condTree)
| name == fromString testSuiteName = (name, condTree')
| otherwise = (name, condTree)
where
-- I miss 'lens'