cabal-install-3.18.1.0: parser-tests/Tests/ParserTests.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- | Tests for the project file parser
module Tests.ParserTests (parserTests) where
import Control.Monad.IO.Class
( MonadIO (liftIO)
)
import Data.Either (fromRight)
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import qualified Data.Set as Set
import Distribution.Client.BuildReports.Types (ReportLevel (..))
import Distribution.Client.CmdInstall.ClientInstallFlags (ClientInstallFlags (..))
import Distribution.Client.Dependency.Types (PreSolver (..))
import Distribution.Client.DistDirLayout
import Distribution.Client.HttpUtils
import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..))
import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), headTotalIndexState, insertIndexState)
import Distribution.Client.ProjectConfig
import Distribution.Client.RebuildMonad (runRebuild)
import Distribution.Client.Targets (readUserConstraint)
import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..), RelaxDepMod (..), RelaxDepScope (..), RelaxDepSubject (..), RelaxDeps (..), RelaxedDep (..))
import Distribution.Client.Types.InstallMethod (InstallMethod (..))
import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..))
import Distribution.Client.Types.Repo (LocalRepo (..), RemoteRepo (..), asPosixPath)
import Distribution.Client.Types.RepoName (RepoName (..))
import Distribution.Client.Types.SourceRepo
import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (WriteGhcEnvironmentFilesPolicy (..))
import Distribution.Compat.Prelude
import Distribution.Compiler (CompilerFlavor (..))
import Distribution.Parsec (simpleParsec)
import Distribution.Simple.Compiler (DebugInfoLevel (..), OptimisationLevel (..), PackageDBX (..), ProfDetailLevel (..))
import Distribution.Simple.Flag
import Distribution.Simple.InstallDirs (InstallDirs (..), toPathTemplate)
import Distribution.Simple.Setup (DumpBuildInfo (..), HaddockTarget (..), TestShowDetails (..))
import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..))
import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath (..))
import Distribution.Solver.Types.Settings
( AllowBootLibInstalls (..)
, CountConflicts (..)
, FineGrainedConflicts (..)
, IndependentGoals (..)
, MinimizeConflictSet (..)
, OnlyConstrained (..)
, PreferOldest (..)
, ReorderGoals (..)
, StrongFlags (..)
)
import Distribution.System (OS (..), buildOS)
import Distribution.Types.CondTree (CondTree (..))
import Distribution.Types.Flag (mkFlagAssignment)
import Distribution.Types.PackageId (PackageIdentifier (..))
import Distribution.Types.PackageName
import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..))
import Distribution.Types.SourceRepo (KnownRepoType (..), RepoType (..))
import Distribution.Types.Version (mkVersion)
import Distribution.Types.VersionRange.Internal (VersionRange (..))
import Distribution.Utils.NubList
import Distribution.Verbosity
import Network.URI (parseURI)
import System.Directory (canonicalizePath, doesFileExist)
import System.FilePath ((</>))
import Prelude ()
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, testCase)
parserTests :: TestTree
parserTests =
testGroup
"project files parsec tests"
[ testCase "read packages" testPackages
, testCase "read optional-packages" testOptionalPackages
, testCase "read extra-packages" testExtraPackages
, testCase "read source-repository-package" testSourceRepoList
, testCase "read project-config-build-only" testProjectConfigBuildOnly
, testCase "read project-config-shared" testProjectConfigShared
, testCase "read install-dirs" testInstallDirs
, testCase "read remote-repos" testRemoteRepos
, testCase "read local-no-index-repos" testLocalNoIndexRepos
, testCase "set explicit provenance" testProjectConfigProvenance
, testCase "read project-config-local-packages" testProjectConfigLocalPackages
, testCase "read project-config-all-packages" testProjectConfigAllPackages
, testCase "read project-config-specific-packages" testProjectConfigSpecificPackages
, testCase "test projectConfigAllPackages concatenation" testAllPackagesConcat
, testCase "test projectConfigSpecificPackages concatenation" testSpecificPackagesConcat
, testCase "test program-locations concatenation" testProgramLocationsConcat
, testCase "test program-options concatenation" testProgramOptionsConcat
, testCase "test allow-newer and allow-older concatenation" testRelaxDepsConcat
, testCase "test library-coverage overwrites coverage" testLibraryCoverage
, testCase "test haddock-all flag" testHaddockAll
, testCase "test override haddock-all: True" testHaddockAllOverwriteTrue
, testCase "test override haddock-all: False" testHaddockAllOverwriteFalse
]
testPackages :: Assertion
testPackages = do
let expected = [".", "packages/packages.cabal"]
(config, legacy) <- readConfigDefault "packages"
assertConfigEquals expected config legacy (projectPackages . snd . condTreeData)
testOptionalPackages :: Assertion
testOptionalPackages = do
let expected = [".", "packages/packages.cabal"]
(config, legacy) <- readConfigDefault "optional-packages"
assertConfigEquals expected config legacy (projectPackagesOptional . snd . condTreeData)
testSourceRepoList :: Assertion
testSourceRepoList = do
(config, legacy) <- readConfigDefault "source-repository-packages"
assertConfigEquals expected config legacy (projectPackagesRepo . snd . condTreeData)
where
expected =
[ SourceRepositoryPackage
{ srpType = KnownRepoType Git
, srpLocation = "https://example.com/Project.git"
, srpTag = Just "1234"
, srpBranch = Nothing
, srpSubdir = []
, srpCommand = []
}
, SourceRepositoryPackage
{ srpType = KnownRepoType Git
, srpLocation = "https://example.com/example-dir/"
, srpTag = Just "12345"
, srpBranch = Nothing
, srpSubdir = ["subproject"]
, srpCommand = []
}
]
testExtraPackages :: Assertion
testExtraPackages = do
(config, legacy) <- readConfigDefault "extra-packages"
assertConfigEquals expected config legacy (projectPackagesNamed . snd . condTreeData)
where
expected =
[ PackageVersionConstraint (mkPackageName "a") (OrLaterVersion (mkVersion [0]))
, PackageVersionConstraint (mkPackageName "b") (IntersectVersionRanges (OrLaterVersion (mkVersion [0, 7, 3])) (EarlierVersion (mkVersion [0, 9])))
]
testProjectConfigBuildOnly :: Assertion
testProjectConfigBuildOnly = do
(config, legacy) <- readConfigDefault "project-config-build-only"
assertConfigEquals expected config legacy (projectConfigBuildOnly . snd . condTreeData)
where
expected = ProjectConfigBuildOnly{..}
projectConfigVerbosity = toFlag (mkVerbosityFlags Verbose)
projectConfigDryRun = mempty -- cli only
projectConfigOnlyDeps = mempty -- cli only
projectConfigOnlyDownload = mempty -- cli only
projectConfigSummaryFile = toNubList [toPathTemplate "summaryFile", toPathTemplate "summaryFile2"]
projectConfigLogFile = toFlag $ toPathTemplate "myLog.log"
projectConfigBuildReports = toFlag DetailedReports
projectConfigReportPlanningFailure = toFlag True
projectConfigSymlinkBinDir = toFlag "some-bindir"
projectConfigNumJobs = toFlag $ Just 4
projectConfigUseSemaphore = toFlag True
projectConfigKeepGoing = toFlag True
projectConfigOfflineMode = toFlag True
projectConfigKeepTempFiles = toFlag True
projectConfigHttpTransport = toFlag "wget"
projectConfigIgnoreExpiry = toFlag True
projectConfigCacheDir = toFlag "some-cache-dir"
projectConfigLogsDir = toFlag "logs-directory"
projectConfigClientInstallFlags =
ClientInstallFlags
{ cinstInstallLibs = Flag True
, cinstEnvironmentPath = Flag "path/to/env"
, cinstOverwritePolicy = Flag AlwaysOverwrite
, cinstInstallMethod = Flag InstallMethodSymlink
, cinstInstalldir = Flag "path/to/installdir"
}
testProjectConfigShared :: Assertion
testProjectConfigShared = do
(config, legacy) <- readConfigDefault "project-config-shared"
assertConfigEquals expected config legacy (projectConfigShared . snd . condTreeData)
where
expected = ProjectConfigShared{..}
projectConfigDistDir = toFlag "something"
projectConfigConfigFile = mempty -- cli only
projectConfigProjectFileParser = mempty -- cli only
projectConfigProjectDir = toFlag "my-project-dir"
projectConfigProjectFile = toFlag "my-project"
projectConfigIgnoreProject = toFlag False
projectConfigHcFlavor = toFlag GHCJS
projectConfigHcPath = toFlag "/some/path/to/compiler"
projectConfigHcPkg = toFlag "/some/path/to/ghc-pkg"
projectConfigHaddockIndex = toFlag $ toPathTemplate "/path/to/haddock-index"
projectConfigInstallDirs = mempty -- tested below in testInstallDirs
projectConfigPackageDBs = [Nothing, Just (SpecificPackageDB "foo"), Nothing, Just (SpecificPackageDB "bar"), Just (SpecificPackageDB "baz")]
projectConfigRemoteRepos = mempty -- tested below in testRemoteRepos
projectConfigLocalNoIndexRepos = mempty -- tested below in testLocalNoIndexRepos
projectConfigActiveRepos = Flag (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge, ActiveRepo (RepoName "my-repository") CombineStrategyOverride])
projectConfigIndexState =
let
hackageState = IndexStateTime $ fromJust $ simpleParsec "2020-05-06T22:33:27Z"
indexState' = insertIndexState (RepoName "hackage.haskell.org") hackageState headTotalIndexState
headHackageState = IndexStateTime $ fromJust $ simpleParsec "2020-04-29T04:11:05Z"
indexState'' = insertIndexState (RepoName "head.hackage") headHackageState indexState'
in
toFlag indexState''
projectConfigStoreDir = toFlag "a/store/dir/path" -- cli only
projectConfigConstraints =
let
bar = fromRight (error "error parsing bar") $ readUserConstraint "bar == 2.1"
barFlags = fromRight (error "error parsing bar flags") $ readUserConstraint "bar +foo -baz"
source = ConstraintSourceProjectConfig $ ProjectConfigPath $ "cabal.project" :| []
in
[(bar, source), (barFlags, source)]
projectConfigPreferences = [PackageVersionConstraint (mkPackageName "foo") (ThisVersion (mkVersion [0, 9])), PackageVersionConstraint (mkPackageName "baz") (LaterVersion (mkVersion [2, 0]))]
projectConfigCabalVersion = Flag (mkVersion [1, 24, 0, 1])
projectConfigSolver = Flag AlwaysModular
projectConfigAllowOlder = Just (AllowOlder $ RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "dep")), RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "pkga") (mkVersion [1, 1, 2]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "dep-pkg"))])
projectConfigAllowNewer = Just (AllowNewer $ RelaxDepsSome [RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "pkgb") (mkVersion [1, 2, 3]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "dep-pkgb")), RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "importantlib"))])
projectConfigWriteGhcEnvironmentFilesPolicy = Flag AlwaysWriteGhcEnvironmentFiles
projectConfigMaxBackjumps = toFlag 42
projectConfigReorderGoals = Flag (ReorderGoals True)
projectConfigCountConflicts = Flag (CountConflicts False)
projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts False)
projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet True)
projectConfigStrongFlags = Flag (StrongFlags True)
projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls True)
projectConfigOnlyConstrained = Flag OnlyConstrainedAll
projectConfigPerComponent = Flag True
projectConfigIndependentGoals = Flag (IndependentGoals True)
projectConfigPreferOldest = Flag (PreferOldest True)
projectConfigProgPathExtra = toNubList ["/foo/bar", "/baz/quux"]
projectConfigMultiRepl = toFlag True
testInstallDirs :: Assertion
testInstallDirs = do
(config, legacy) <- readConfigDefault "install-dirs"
assertConfigEquals expected config legacy (projectConfigInstallDirs . projectConfigShared . snd . condTreeData)
where
expected =
InstallDirs
{ prefix = Flag $ toPathTemplate "my/prefix-path"
, bindir = Flag $ toPathTemplate "bin/dir/"
, libdir = Flag $ toPathTemplate "lib/dir/path"
, libsubdir = Flag $ toPathTemplate "/lib/sub/dir"
, dynlibdir = Flag $ toPathTemplate "dyn/lib/dir/path"
, bytecodelibdir = Flag $ toPathTemplate "bytecode/lib/dir/path"
, flibdir = mempty
, libexecdir = Flag $ toPathTemplate "lib/exec/dir/"
, libexecsubdir = Flag $ toPathTemplate "libexec/subdir"
, includedir = mempty
, datadir = Flag $ toPathTemplate "path/to/datadir/"
, datasubdir = Flag $ toPathTemplate "a/datadir/subdir"
, docdir = Flag $ toPathTemplate "path/to/docs"
, mandir = mempty
, htmldir = Flag $ toPathTemplate "dir/html/"
, haddockdir = Flag $ toPathTemplate "haddock/dir"
, sysconfdir = Flag $ toPathTemplate "sys/conf/dir"
}
testRemoteRepos :: Assertion
testRemoteRepos = do
(config, legacy) <- readConfigDefault "remote-repos"
let actualRemoteRepos = (fromNubList . projectConfigRemoteRepos . projectConfigShared . snd . condTreeData) config
assertBool "Expected RemoteRepos do not match parsed values" $ compareLists expected actualRemoteRepos compareRemoteRepos
assertConfigEquals mempty config legacy (projectConfigLocalNoIndexRepos . projectConfigShared . snd . condTreeData)
where
expected = [packagesRepository, morePackagesRepository, secureLocalRepository]
packagesRepository =
RemoteRepo
{ remoteRepoName = RepoName "packages.example.org"
, remoteRepoURI = fromJust $ parseURI "http://packages.example.org/"
, remoteRepoSecure = pure True
, remoteRepoRootKeys = ["21", "42"]
, remoteRepoKeyThreshold = 2
, remoteRepoShouldTryHttps = False
}
morePackagesRepository =
RemoteRepo
{ remoteRepoName = RepoName "more-packages.example.org"
, remoteRepoURI = fromJust $ parseURI "https://more-packages.example.org/"
, remoteRepoSecure = pure True
, remoteRepoRootKeys = ["foo", "bar"]
, remoteRepoKeyThreshold = 1
, remoteRepoShouldTryHttps = False
}
secureLocalRepository =
RemoteRepo
{ remoteRepoName = RepoName "my-secure-local-repository"
, remoteRepoURI = fromJust $ parseURI "file:/path/to/secure/repo"
, remoteRepoSecure = pure True
, remoteRepoRootKeys = ["123"]
, remoteRepoKeyThreshold = 1
, remoteRepoShouldTryHttps = False
}
testLocalNoIndexRepos :: Assertion
testLocalNoIndexRepos = do
(config, legacy) <- readConfigDefault "local-no-index-repos"
let actualLocalRepos = (fromNubList . projectConfigLocalNoIndexRepos . projectConfigShared . snd . condTreeData) config
assertBool "Expected LocalNoIndexRepos do not match parsed values" $ compareLists expected actualLocalRepos compareLocalRepos
assertConfigEquals mempty config legacy (projectConfigRemoteRepos . projectConfigShared . snd . condTreeData)
where
expected = [myRepository, mySecureRepository]
myRepository =
LocalRepo
{ localRepoName = RepoName "my-repository"
, localRepoPath = normalisePath "/absolute/path/to/directory"
, localRepoSharedCache = False
}
mySecureRepository =
LocalRepo
{ localRepoName = RepoName "my-other-repository"
, localRepoPath = normalisePath "/another/path/to/repository"
, localRepoSharedCache = False
}
normalisePath path = case buildOS of
Windows -> asPosixPath path
_ -> path
testProjectConfigProvenance :: Assertion
testProjectConfigProvenance = do
let expected = Set.singleton (Explicit (ProjectConfigPath $ "cabal.project" :| []))
(config, legacy) <- readConfigDefault "empty"
assertConfigEquals expected config legacy (projectConfigProvenance . snd . condTreeData)
testProjectConfigLocalPackages :: Assertion
testProjectConfigLocalPackages = do
(config, legacy) <- readConfigDefault "project-config-local-packages"
assertConfigEquals expected config legacy (projectConfigLocalPackages . snd . condTreeData)
where
expected = PackageConfig{..}
packageConfigProgramPaths = MapLast $ Map.fromList [("ghc", "/tmp/bin/ghc"), ("gcc", "/tmp/bin/gcc")]
packageConfigProgramArgs = MapMappend $ Map.fromList [("ghc", ["-fno-state-hack", "-foo"]), ("gcc", ["-baz", "-quux"])]
packageConfigProgramPathExtra = toNubList ["/tmp/bin/extra", "/usr/local/bin"]
packageConfigFlagAssignment = mkFlagAssignment [("foo", True), ("bar", False)]
packageConfigVanillaLib = Flag False
packageConfigSharedLib = Flag True
packageConfigStaticLib = Flag True
packageConfigDynExe = Flag True
packageConfigFullyStaticExe = Flag True
packageConfigProf = Flag True
packageConfigProfLib = Flag True
packageConfigProfShared = Flag False
packageConfigProfExe = Flag True
packageConfigProfDetail = Flag ProfDetailAllFunctions
packageConfigProfLibDetail = Flag ProfDetailExportedFunctions
packageConfigConfigureArgs = ["-some-arg", "/some/path"]
packageConfigOptimization = Flag MaximumOptimisation
packageConfigProgPrefix = Flag $ toPathTemplate "another/path"
packageConfigProgSuffix = Flag $ toPathTemplate "and/another/path"
packageConfigExtraLibDirs = ["so", "many", "lib/dirs"]
packageConfigExtraLibDirsStatic = ["a/few", "static/lib/dirs"]
packageConfigExtraFrameworkDirs = ["osx/framework", "dirs"]
packageConfigExtraIncludeDirs = ["incredible/amount", "of", "include", "directories"]
packageConfigGHCiLib = Flag False
packageConfigBytecodeLib = Flag False
packageConfigSplitSections = Flag True
packageConfigSplitObjs = Flag True
packageConfigStripExes = Flag False
packageConfigStripLibs = Flag False
packageConfigTests = Flag True
packageConfigBenchmarks = Flag True
packageConfigCoverage = Flag True
packageConfigRelocatable = Flag True
packageConfigDebugInfo = Flag MaximalDebugInfo
packageConfigDumpBuildInfo = Flag DumpBuildInfo
packageConfigRunTests = Flag True
packageConfigDocumentation = Flag True
-- Haddock options
packageConfigHaddockHoogle = Flag True
packageConfigHaddockHtml = Flag False
packageConfigHaddockHtmlLocation = Flag "http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html"
packageConfigHaddockForeignLibs = Flag True
packageConfigHaddockExecutables = Flag True
packageConfigHaddockTestSuites = Flag True
packageConfigHaddockBenchmarks = Flag True
packageConfigHaddockInternal = Flag True
packageConfigHaddockCss = Flag "some/path/to/file.css"
packageConfigHaddockLinkedSource = Flag True
packageConfigHaddockQuickJump = Flag True
packageConfigHaddockHscolourCss = Flag "another/path/to/hscolour.css"
packageConfigHaddockContents = Flag $ toPathTemplate "https://example.com/$pkg/contents"
packageConfigHaddockIndex = Flag $ toPathTemplate "separately-generated/HTML/index"
packageConfigHaddockBaseUrl = Flag "https://example.com/haddock-base-url"
packageConfigHaddockResourcesDir = Flag "/haddock/static"
packageConfigHaddockOutputDir = Flag "/haddock/output"
packageConfigHaddockUseUnicode = Flag False
packageConfigHaddockForHackage = Flag ForHackage
packageConfigTestHumanLog = Flag $ toPathTemplate "human-log.log"
packageConfigTestMachineLog = Flag $ toPathTemplate "machine.log"
packageConfigTestShowDetails = Flag Streaming
packageConfigTestKeepTix = Flag True
packageConfigTestWrapper = Flag "/test-wrapper-path/"
packageConfigTestFailWhenNoTestSuites = Flag True
packageConfigTestTestOptions = [toPathTemplate "--some-option", toPathTemplate "42"]
packageConfigBenchmarkOptions = [toPathTemplate "--some-benchmark-option", toPathTemplate "--another-option"]
testProjectConfigAllPackages :: Assertion
testProjectConfigAllPackages = do
(config, legacy) <- readConfigDefault "project-config-all-packages"
assertConfigEquals expected config legacy (projectConfigAllPackages . snd . condTreeData)
where
expected :: PackageConfig
expected =
mempty
{ packageConfigProfDetail = Flag ProfDetailAllFunctions
, packageConfigProfLibDetail = Flag ProfDetailExportedFunctions
}
testProjectConfigSpecificPackages :: Assertion
testProjectConfigSpecificPackages = do
(config, legacy) <- readConfigDefault "project-config-specific-packages"
assertConfigEquals expected config legacy (projectConfigSpecificPackage . snd . condTreeData)
where
expected = MapMappend $ Map.fromList [("foo", expectedFoo), ("bar", expectedBar), ("baz", expectedBaz)]
expectedFoo :: PackageConfig
expectedFoo =
mempty
{ packageConfigProfDetail = Flag ProfDetailAllFunctions
, packageConfigProfLibDetail = Flag ProfDetailExportedFunctions
, packageConfigVanillaLib = Flag True
}
expectedBar :: PackageConfig
expectedBar =
mempty
{ packageConfigProfDetail = Flag ProfDetailTopLate
, packageConfigProfLibDetail = Flag ProfDetailNone
, packageConfigProgPrefix = Flag $ toPathTemplate "prefix/path"
}
expectedBaz :: PackageConfig
expectedBaz =
mempty
{ packageConfigSharedLib = Flag True
}
testAllPackagesConcat :: Assertion
testAllPackagesConcat = do
(config, legacy) <- readConfigDefault "all-packages-concat"
assertConfigEquals expected config legacy (projectConfigAllPackages . snd . condTreeData)
where
expected :: PackageConfig
expected =
mempty
{ packageConfigSharedLib = Flag True
, packageConfigStaticLib = Flag True
, packageConfigProgramArgs =
MapMappend $
Map.fromList
[ ("ghc", ["-fwarn-tabs", "-optc-fno-builtin-malloc", "-Wall", "-optc-fno-builtin-realloc", "-fwrite-ide-info"])
]
}
testSpecificPackagesConcat :: Assertion
testSpecificPackagesConcat = do
(config, legacy) <- readConfigDefault "specific-packages-concat"
assertConfigEquals expected config legacy (projectConfigSpecificPackage . snd . condTreeData)
where
expected = MapMappend $ Map.fromList [("foo", expectedFoo)]
expectedFoo :: PackageConfig
expectedFoo =
mempty
{ packageConfigSharedLib = Flag True
, packageConfigStaticLib = Flag True
, packageConfigProgramArgs = MapMappend $ Map.fromList [("ghc", ["-fno-state-hack", "-threaded"])]
}
testProgramLocationsConcat :: Assertion
testProgramLocationsConcat = do
(config, legacy) <- readConfigDefault "program-locations-concat"
assertConfigEquals expected config legacy (projectConfigLocalPackages . snd . condTreeData)
where
expected :: PackageConfig
expected =
mempty
{ packageConfigProgramPaths = MapLast $ Map.fromList [("gcc", "/tmp/bin/gcc"), ("ghc", "/tmp/bin/ghc")]
}
testProgramOptionsConcat :: Assertion
testProgramOptionsConcat = do
(config, legacy) <- readConfigDefault "program-options-concat"
assertConfigEquals expected config legacy (projectConfigLocalPackages . snd . condTreeData)
where
expected :: PackageConfig
expected =
mempty
{ packageConfigProgramArgs =
MapMappend $
Map.fromList
[ ("ghc", ["-threaded", "-Wall", "-fno-state-hack"])
, ("gcc", ["-baz", "-foo", "-bar"])
, ("haddock", ["--optghc=-optP -P"])
, ("ld", ["-Wl,--gc-sections"])
]
}
testRelaxDepsConcat :: Assertion
testRelaxDepsConcat = do
(config, legacy) <- readConfigDefault "relax-deps-concat"
assertConfigEquals expectedAllowNewer config legacy (projectConfigAllowNewer . projectConfigShared . snd . condTreeData)
assertConfigEquals expectedAllowOlder config legacy (projectConfigAllowOlder . projectConfigShared . snd . condTreeData)
where
expectedAllowNewer :: Maybe AllowNewer
expectedAllowNewer =
pure $
AllowNewer $
RelaxDepsSome
[ RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "cassava") (mkVersion [0, 5, 2, 0]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "base"))
, RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "vector-th-unbox") (mkVersion [0, 2, 1, 7]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "base"))
, RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "vector-th-unbox") (mkVersion [0, 2, 1, 7]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "template-haskell"))
]
expectedAllowOlder :: Maybe AllowOlder
expectedAllowOlder =
pure $
AllowOlder $
RelaxDepsSome
[ RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "mtl") (mkVersion [2, 3, 1]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "base"))
, RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "aeson") (mkVersion [2, 2, 3, 0]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "bytestring"))
, RelaxedDep (RelaxDepScopePackageId (PackageIdentifier (mkPackageName "containers") (mkVersion [0, 7]))) RelaxDepModNone (RelaxDepSubjectPkg (mkPackageName "array"))
]
-- | Tests that if both library-coverage and coverage flags are specified, library-coverage is used.
testLibraryCoverage :: Assertion
testLibraryCoverage = do
(config, legacy) <- readConfigDefault "library-coverage"
assertConfigEquals (Flag False) config legacy (packageConfigCoverage . projectConfigLocalPackages . snd . condTreeData)
testHaddockAll :: Assertion
testHaddockAll = do
(config, legacy) <- readConfigDefault "haddock-all"
assertConfigEquals (Flag True) config legacy (packageConfigHaddockExecutables . projectConfigLocalPackages . snd . condTreeData)
assertConfigEquals (Flag True) config legacy (packageConfigHaddockTestSuites . projectConfigLocalPackages . snd . condTreeData)
assertConfigEquals (Flag True) config legacy (packageConfigHaddockBenchmarks . projectConfigLocalPackages . snd . condTreeData)
assertConfigEquals (Flag True) config legacy (packageConfigHaddockForeignLibs . projectConfigLocalPackages . snd . condTreeData)
-- | Tests that an explicitly set field can override a value inherited from haddock-all.
testHaddockAllOverwriteTrue :: Assertion
testHaddockAllOverwriteTrue = do
(config, legacy) <- readConfigDefault "haddock-all-overwrite-true"
assertConfigEquals (Flag True) config legacy (packageConfigHaddockExecutables . projectConfigLocalPackages . snd . condTreeData)
assertConfigEquals (Flag True) config legacy (packageConfigHaddockTestSuites . projectConfigLocalPackages . snd . condTreeData)
assertConfigEquals (Flag True) config legacy (packageConfigHaddockBenchmarks . projectConfigLocalPackages . snd . condTreeData)
assertConfigEquals (Flag False) config legacy (packageConfigHaddockForeignLibs . projectConfigLocalPackages . snd . condTreeData)
testHaddockAllOverwriteFalse :: Assertion
testHaddockAllOverwriteFalse = do
(config, legacy) <- readConfigDefault "haddock-all-overwrite-false"
assertConfigEquals (Flag True) config legacy (packageConfigHaddockExecutables . projectConfigLocalPackages . snd . condTreeData)
assertConfigEquals (Flag False) config legacy (packageConfigHaddockTestSuites . projectConfigLocalPackages . snd . condTreeData)
assertConfigEquals (Flag False) config legacy (packageConfigHaddockBenchmarks . projectConfigLocalPackages . snd . condTreeData)
assertConfigEquals (Flag False) config legacy (packageConfigHaddockForeignLibs . projectConfigLocalPackages . snd . condTreeData)
-------------------------------------------------------------------------------
-- Test Utilities
-------------------------------------------------------------------------------
baseDir :: FilePath
baseDir = "parser-tests" </> "Tests" </> "files"
verbosity :: Verbosity
verbosity = mkVerbosity defaultVerbosityHandles normal
readConfigDefault :: FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton)
readConfigDefault testSubDir = readConfig testSubDir "cabal.project"
readConfig :: FilePath -> FilePath -> IO (ProjectConfigSkeleton, ProjectConfigSkeleton)
readConfig testSubDir projectFileName = do
(TestDir testRootFp projectConfigFp distDirLayout) <- testDirInfo testSubDir projectFileName
exists <- liftIO $ doesFileExist projectConfigFp
assertBool ("projectConfig does not exist: " <> projectConfigFp) exists
httpTransport <- liftIO $ configureTransport verbosity [] Nothing
parsec <-
liftIO $
runRebuild testRootFp $
readProjectFileSkeletonParsec verbosity httpTransport distDirLayout ProjectFileKeyMain
legacy <-
liftIO $
runRebuild testRootFp $
readProjectFileSkeletonLegacy verbosity httpTransport distDirLayout ProjectFileKeyMain
return (parsec, legacy)
assertConfigEquals :: (Eq a, Show a) => a -> ProjectConfigSkeleton -> ProjectConfigSkeleton -> (ProjectConfigSkeleton -> a) -> Assertion
assertConfigEquals expected config configLegacy access = do
assertEqual "Expectation does not match result of Legacy parser" expected actualLegacy
assertEqual "Parsed Config does not match expected" expected actual
where
actual = access config
actualLegacy = access configLegacy
-- | Represents the directory structure and associated file paths for a test
data TestDir = TestDir
{ _testDirTestRootFp :: FilePath
-- ^ Every test has a root directory in ./files/<test-title>
, _testDirProjectConfigFp :: FilePath
-- ^ Every test has a project config in testDirTestRootFp/cabal.project
, _testDirDistDirLayout :: DistDirLayout
}
testDirInfo :: FilePath -> FilePath -> IO TestDir
testDirInfo testSubDir projectFileName = do
projectRootDir <- canonicalizePath (baseDir </> testSubDir)
let
projectRoot = ProjectRootExplicit projectRootDir projectFileName
distDirLayout = defaultDistDirLayout projectRoot Nothing Nothing
projectConfigFp = distProjectFile distDirLayout ProjectFileKeyMain
return $ TestDir projectRootDir projectConfigFp distDirLayout
-- | Compares two lists element-wise using a comparison function.
compareLists :: [a] -> [a] -> (a -> a -> Bool) -> Bool
compareLists xs ys compare' = length xs == length ys && all (uncurry compare') (zip xs ys)
-- | Compares LocalRepos ignoring field 'localRepoSharedCache' because we do not parse it.
compareLocalRepos :: LocalRepo -> LocalRepo -> Bool
compareLocalRepos repo1 repo2 =
localRepoName repo1 == localRepoName repo2
&& localRepoPath repo1 == localRepoPath repo2
-- | Compares RemoteRepos ignoring field 'remoteRepoShouldTryHttps' because we do not parse it.
compareRemoteRepos :: RemoteRepo -> RemoteRepo -> Bool
compareRemoteRepos repo1 repo2 =
remoteRepoName repo1 == remoteRepoName repo2
&& remoteRepoURI repo1 == remoteRepoURI repo2
&& remoteRepoSecure repo1 == remoteRepoSecure repo2
&& remoteRepoRootKeys repo1 == remoteRepoRootKeys repo2
&& remoteRepoKeyThreshold repo1 == remoteRepoKeyThreshold repo2