diff --git a/Distribution/Client/Check.hs b/Distribution/Client/Check.hs --- a/Distribution/Client/Check.hs +++ b/Distribution/Client/Check.hs @@ -25,7 +25,7 @@ import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, runParseResult) import Distribution.Parsec.Common (PWarning (..), showPError, showPWarning) -import Distribution.Simple.Utils (defaultPackageDesc, die', warn, wrapText) +import Distribution.Simple.Utils (defaultPackageDesc, die', notice, warn) import Distribution.Verbosity (Verbosity) import qualified Data.ByteString as BS @@ -45,6 +45,8 @@ die' verbosity $ "Failed parsing \"" ++ fpath ++ "\"." Right x -> return (warnings, x) +-- | Note: must be called with the CWD set to the directory containing +-- the '.cabal' file. check :: Verbosity -> IO Bool check verbosity = do pdfile <- defaultPackageDesc verbosity @@ -66,7 +68,7 @@ -- Hovever, this is the same way hackage does it, so we will yield -- the exact same errors as it will. let pkg_desc = flattenPackageDescription ppd - ioChecks <- checkPackageFiles pkg_desc "." + ioChecks <- checkPackageFiles verbosity pkg_desc "." let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) ++ ws' buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ] buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ] @@ -75,19 +77,19 @@ distInexusable = [ x | x@PackageDistInexcusable {} <- packageChecks ] unless (null buildImpossible) $ do - putStrLn "The package will not build sanely due to these errors:" + warn verbosity "The package will not build sanely due to these errors:" printCheckMessages buildImpossible unless (null buildWarning) $ do - putStrLn "The following warnings are likely to affect your build negatively:" + warn verbosity "The following warnings are likely to affect your build negatively:" printCheckMessages buildWarning unless (null distSuspicious) $ do - putStrLn "These warnings may cause trouble when distributing the package:" + warn verbosity "These warnings may cause trouble when distributing the package:" printCheckMessages distSuspicious unless (null distInexusable) $ do - putStrLn "The following errors will cause portability problems on other environments:" + warn verbosity "The following errors will cause portability problems on other environments:" printCheckMessages distInexusable let isDistError (PackageDistSuspicious {}) = False @@ -98,13 +100,12 @@ errors = filter isDistError packageChecks unless (null errors) $ - putStrLn "Hackage would reject this package." + warn verbosity "Hackage would reject this package." when (null packageChecks) $ - putStrLn "No errors or warnings could be found in the package." + notice verbosity "No errors or warnings could be found in the package." return (not . any isCheckError $ packageChecks) where - printCheckMessages = traverse_ (putStrLn . format . explanation) - format = wrapText . ("* "++) + printCheckMessages = traverse_ (warn verbosity . explanation) diff --git a/Distribution/Client/CmdBench.hs b/Distribution/Client/CmdBench.hs --- a/Distribution/Client/CmdBench.hs +++ b/Distribution/Client/CmdBench.hs @@ -81,7 +81,7 @@ baseCtx <- establishProjectBaseContext verbosity cliConfig targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) targetStrings + =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -100,6 +100,7 @@ selectComponentTarget TargetProblemCommon elaboratedPlan + Nothing targetSelectors let elaboratedPlan' = pruneInstallPlanToTargets diff --git a/Distribution/Client/CmdBuild.hs b/Distribution/Client/CmdBuild.hs --- a/Distribution/Client/CmdBuild.hs +++ b/Distribution/Client/CmdBuild.hs @@ -78,7 +78,7 @@ baseCtx <- establishProjectBaseContext verbosity cliConfig targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) targetStrings + =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -91,6 +91,7 @@ selectComponentTarget TargetProblemCommon elaboratedPlan + Nothing targetSelectors let elaboratedPlan' = pruneInstallPlanToTargets diff --git a/Distribution/Client/CmdClean.hs b/Distribution/Client/CmdClean.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/CmdClean.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE RecordWildCards #-} +module Distribution.Client.CmdClean (cleanCommand, cleanAction) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.DistDirLayout + ( DistDirLayout(..), defaultDistDirLayout ) +import Distribution.Client.ProjectConfig + ( findProjectRoot ) +import Distribution.Client.Setup + ( GlobalFlags ) +import Distribution.ReadE ( succeedReadE ) +import Distribution.Simple.Setup + ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe + , optionDistPref, optionVerbosity, falseArg + ) +import Distribution.Simple.Command + ( CommandUI(..), option, reqArg ) +import Distribution.Simple.Utils + ( info, die', wrapText, handleDoesNotExist ) +import Distribution.Verbosity + ( Verbosity, normal ) + +import Control.Exception + ( throwIO ) +import System.Directory + ( removeDirectoryRecursive, doesDirectoryExist ) + +data CleanFlags = CleanFlags + { cleanSaveConfig :: Flag Bool + , cleanVerbosity :: Flag Verbosity + , cleanDistDir :: Flag FilePath + , cleanProjectFile :: Flag FilePath + } deriving (Eq) + +defaultCleanFlags :: CleanFlags +defaultCleanFlags = CleanFlags + { cleanSaveConfig = toFlag False + , cleanVerbosity = toFlag normal + , cleanDistDir = NoFlag + , cleanProjectFile = mempty + } + +cleanCommand :: CommandUI CleanFlags +cleanCommand = CommandUI + { commandName = "new-clean" + , commandSynopsis = "Clean the package store and remove temporary files." + , commandUsage = \pname -> + "Usage: " ++ pname ++ " new-clean [FLAGS]\n" + , commandDescription = Just $ \_ -> wrapText $ + "Removes all temporary files created during the building process " + ++ "(.hi, .o, preprocessed sources, etc.) and also empties out the " + ++ "local caches (by default).\n\n" + , commandNotes = Nothing + , commandDefaultFlags = defaultCleanFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity + cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) + , optionDistPref + cleanDistDir (\dd flags -> flags { cleanDistDir = dd }) + showOrParseArgs + , option [] ["project-file"] + "Set the name of the cabal.project file to search for in parent directories" + cleanProjectFile (\pf flags -> flags {cleanProjectFile = pf}) + (reqArg "FILE" (succeedReadE Flag) flagToList) + , option ['s'] ["save-config"] + "Save configuration, only remove build artifacts" + cleanSaveConfig (\sc flags -> flags { cleanSaveConfig = sc }) + falseArg + ] + } + +cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO () +cleanAction CleanFlags{..} extraArgs _ = do + let verbosity = fromFlagOrDefault normal cleanVerbosity + saveConfig = fromFlagOrDefault False cleanSaveConfig + mdistDirectory = flagToMaybe cleanDistDir + mprojectFile = flagToMaybe cleanProjectFile + + unless (null extraArgs) $ + die' verbosity $ "'clean' doesn't take any extra arguments: " ++ unwords extraArgs + + projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile + + let distLayout = defaultDistDirLayout projectRoot mdistDirectory + + if saveConfig + then do + let buildRoot = distBuildRootDirectory distLayout + unpackedSrcRoot = distUnpackedSrcRootDirectory distLayout + + buildRootExists <- doesDirectoryExist buildRoot + unpackedSrcRootExists <- doesDirectoryExist unpackedSrcRoot + + when buildRootExists $ do + info verbosity ("Deleting build root (" ++ buildRoot ++ ")") + handleDoesNotExist () $ removeDirectoryRecursive buildRoot + + when unpackedSrcRootExists $ do + info verbosity ("Deleting unpacked source root (" ++ unpackedSrcRoot ++ ")") + handleDoesNotExist () $ removeDirectoryRecursive unpackedSrcRoot + else do + let distRoot = distDirectory distLayout + + info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")") + handleDoesNotExist () $ removeDirectoryRecursive distRoot diff --git a/Distribution/Client/CmdErrorMessages.hs b/Distribution/Client/CmdErrorMessages.hs --- a/Distribution/Client/CmdErrorMessages.hs +++ b/Distribution/Client/CmdErrorMessages.hs @@ -197,6 +197,12 @@ ++ "in this project (either directly or indirectly). If you want to add it " ++ "to the project then edit the cabal.project file." +renderTargetProblemCommon verb (TargetAvailableInIndex pkgname) = + "Cannot " ++ verb ++ " the package " ++ display pkgname ++ ", it is not " + ++ "in this project (either directly or indirectly), but it is in the current " + ++ "package index. If you want to add it to the project then edit the " + ++ "cabal.project file." + renderTargetProblemCommon verb (TargetComponentNotProjectLocal pkgid cname _) = "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the " ++ "package " ++ display pkgid ++ " is not local to the project, and cabal " diff --git a/Distribution/Client/CmdFreeze.hs b/Distribution/Client/CmdFreeze.hs --- a/Distribution/Client/CmdFreeze.hs +++ b/Distribution/Client/CmdFreeze.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} -- | cabal-install CLI command: freeze -- @@ -209,7 +209,6 @@ :: Map PackageName [(UserConstraint, ConstraintSource)] -> Map PackageName [(UserConstraint, ConstraintSource)] deleteLocalPackagesVersionConstraints = -#if MIN_VERSION_containers(0,5,0) Map.mergeWithKey (\_pkgname () constraints -> case filter (not . isVersionConstraint . fst) constraints of @@ -217,15 +216,6 @@ constraints' -> Just constraints') (const Map.empty) id localPackages -#else - Map.mapMaybeWithKey - (\pkgname constraints -> - if pkgname `Map.member` localPackages - then case filter (not . isVersionConstraint . fst) constraints of - [] -> Nothing - constraints' -> Just constraints' - else Just constraints) -#endif isVersionConstraint (UserConstraint _ (PackagePropertyVersion _)) = True isVersionConstraint _ = False diff --git a/Distribution/Client/CmdHaddock.hs b/Distribution/Client/CmdHaddock.hs --- a/Distribution/Client/CmdHaddock.hs +++ b/Distribution/Client/CmdHaddock.hs @@ -77,7 +77,7 @@ baseCtx <- establishProjectBaseContext verbosity cliConfig targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) targetStrings + =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -94,6 +94,7 @@ selectComponentTarget TargetProblemCommon elaboratedPlan + Nothing targetSelectors let elaboratedPlan' = pruneInstallPlanToTargets diff --git a/Distribution/Client/CmdInstall.hs b/Distribution/Client/CmdInstall.hs --- a/Distribution/Client/CmdInstall.hs +++ b/Distribution/Client/CmdInstall.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -- | cabal-install CLI command: build @@ -11,7 +14,8 @@ -- * Internals exposed for testing TargetProblem(..), selectPackageTargets, - selectComponentTarget + selectComponentTarget, + establishDummyProjectBaseContext ) where import Prelude () @@ -19,56 +23,135 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages +import Distribution.Client.CmdSdist import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags + , configureExOptions, installOptions, liftOptions ) +import Distribution.Solver.Types.ConstraintSource + ( ConstraintSource(..) ) import Distribution.Client.Types - ( PackageSpecifier(NamedPackage), UnresolvedSourcePackage ) -import Distribution.Client.ProjectPlanning.Types - ( pkgConfigCompiler ) + ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Package + ( Package(..), PackageName, mkPackageName ) +import Distribution.Types.PackageId + ( PackageIdentifier(..) ) import Distribution.Client.ProjectConfig.Types - ( ProjectConfig, ProjectConfigBuildOnly(..) - , projectConfigLogsDir, projectConfigStoreDir, projectConfigShared - , projectConfigBuildOnly, projectConfigDistDir - , projectConfigConfigFile ) + ( ProjectConfig(..), ProjectConfigShared(..) + , ProjectConfigBuildOnly(..), PackageConfig(..) + , getMapLast, getMapMappend, projectConfigLogsDir + , projectConfigStoreDir, projectConfigBuildOnly + , projectConfigDistDir, projectConfigConfigFile ) +import Distribution.Simple.Program.Db + ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb + , modifyProgramSearchPath ) +import Distribution.Simple.Program.Find + ( ProgramSearchPathEntry(..) ) import Distribution.Client.Config - ( defaultCabalDir ) + ( getCabalDir ) +import Distribution.Simple.PackageIndex + ( InstalledPackageIndex, lookupPackageName, lookupUnitId ) +import Distribution.Types.InstalledPackageInfo + ( InstalledPackageInfo(..) ) +import Distribution.Types.Version + ( nullVersion ) +import Distribution.Types.VersionRange + ( thisVersion ) +import Distribution.Solver.Types.PackageConstraint + ( PackageProperty(..) ) +import Distribution.Client.IndexUtils + ( getSourcePackages, getInstalledPackages ) import Distribution.Client.ProjectConfig - ( readGlobalConfig, resolveBuildTimeSettings ) + ( readGlobalConfig, projectConfigWithBuilderRepoContext + , resolveBuildTimeSettings, withProjectOrGlobalConfig ) import Distribution.Client.DistDirLayout - ( defaultDistDirLayout, distDirectory, mkCabalDirLayout - , ProjectRoot(ProjectRootImplicit), distProjectCacheDirectory - , storePackageDirectory, cabalStoreDirLayout ) + ( defaultDistDirLayout, DistDirLayout(..), mkCabalDirLayout + , ProjectRoot(ProjectRootImplicit) + , storePackageDirectory, cabalStoreDirLayout + , CabalDirLayout(..), StoreDirLayout(..) ) import Distribution.Client.RebuildMonad ( runRebuild ) import Distribution.Client.InstallSymlink ( symlinkBinary ) import Distribution.Simple.Setup - ( Flag(Flag), HaddockFlags, fromFlagOrDefault, flagToMaybe ) + ( Flag(Flag), HaddockFlags, fromFlagOrDefault, flagToMaybe, toFlag + , trueArg, configureOptions, haddockOptions, flagToList ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage(..) ) +import Distribution.ReadE + ( succeedReadE ) import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) + ( CommandUI(..), ShowOrParseArgs(..), OptionField(..) + , option, usageAlternatives, reqArg ) +import Distribution.Simple.Configure + ( configCompilerEx ) import Distribution.Simple.Compiler - ( compilerId ) -import Distribution.Types.PackageName - ( mkPackageName ) + ( Compiler(..), CompilerId(..), CompilerFlavor(..) ) +import Distribution.Simple.GHC + ( ghcPlatformAndVersionString + , GhcImplInfo(..), getImplInfo + , GhcEnvironmentFileEntry(..) + , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc ) import Distribution.Types.UnitId ( UnitId ) import Distribution.Types.UnqualComponentName ( UnqualComponentName, unUnqualComponentName ) import Distribution.Verbosity - ( Verbosity, normal ) + ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils - ( wrapText, die', notice - , withTempDirectory, createDirectoryIfMissingVerbose ) + ( wrapText, die', notice, warn + , withTempDirectory, createDirectoryIfMissingVerbose + , ordNub ) +import Distribution.Utils.Generic + ( writeFileAtomic ) +import Distribution.Text + ( simpleParse ) +import Control.Exception + ( catch ) +import Control.Monad + ( mapM, mapM_ ) +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.Either + ( partitionEithers ) +import Data.Ord + ( comparing, Down(..) ) import qualified Data.Map as Map -import System.Directory ( getTemporaryDirectory, makeAbsolute ) -import System.FilePath ( () ) +import Distribution.Utils.NubList + ( fromNubList ) +import System.Directory + ( getHomeDirectory, doesFileExist, createDirectoryIfMissing + , getTemporaryDirectory, makeAbsolute, doesDirectoryExist ) +import System.FilePath + ( (), takeDirectory, takeBaseName ) -import qualified Distribution.Client.CmdBuild as CmdBuild +data NewInstallFlags = NewInstallFlags + { ninstInstallLibs :: Flag Bool + , ninstEnvironmentPath :: Flag FilePath + } -installCommand :: CommandUI (ConfigFlags, ConfigExFlags - ,InstallFlags, HaddockFlags) +defaultNewInstallFlags :: NewInstallFlags +defaultNewInstallFlags = NewInstallFlags + { ninstInstallLibs = toFlag False + , ninstEnvironmentPath = mempty + } + +newInstallOptions :: ShowOrParseArgs -> [OptionField NewInstallFlags] +newInstallOptions _ = + [ option [] ["lib"] + "Install libraries rather than executables from the target package." + ninstInstallLibs (\v flags -> flags { ninstInstallLibs = v }) + trueArg + , option [] ["package-env", "env"] + "Set the environment file that may be modified." + ninstEnvironmentPath (\pf flags -> flags { ninstEnvironmentPath = pf }) + (reqArg "ENV" (succeedReadE Flag) flagToList) + ] + +installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags + , HaddockFlags, NewInstallFlags + ) installCommand = CommandUI { commandName = "new-install" , commandSynopsis = "Install packages." @@ -95,13 +178,40 @@ ++ " Install the package in the ./pkgfoo directory\n" ++ cmdCommonHelpTextNewBuildBeta - , commandOptions = commandOptions CmdBuild.buildCommand - , commandDefaultFlags = commandDefaultFlags CmdBuild.buildCommand + , commandOptions = \showOrParseArgs -> + liftOptions get1 set1 + -- Note: [Hidden Flags] + -- hide "constraint", "dependency", and + -- "exact-configuration" from the configure options. + (filter ((`notElem` ["constraint", "dependency" + , "exact-configuration"]) + . optionName) $ configureOptions showOrParseArgs) + ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag) + ++ liftOptions get3 set3 + -- hide "target-package-db" flag from the + -- install options. + (filter ((`notElem` ["target-package-db"]) + . optionName) $ + installOptions showOrParseArgs) + ++ liftOptions get4 set4 + -- hide "target-package-db" flag from the + -- install options. + (filter ((`notElem` ["v", "verbose"]) + . optionName) $ + haddockOptions showOrParseArgs) + ++ liftOptions get5 set5 (newInstallOptions showOrParseArgs) + , commandDefaultFlags = (mempty, mempty, mempty, mempty, defaultNewInstallFlags) } + where + get1 (a,_,_,_,_) = a; set1 a (_,b,c,d,e) = (a,b,c,d,e) + get2 (_,b,_,_,_) = b; set2 b (a,_,c,d,e) = (a,b,c,d,e) + get3 (_,_,c,_,_) = c; set3 c (a,b,_,d,e) = (a,b,c,d,e) + get4 (_,_,_,d,_) = d; set4 d (a,b,c,_,e) = (a,b,c,d,e) + get5 (_,_,_,_,e) = e; set5 e (a,b,c,d,_) = (a,b,c,d,e) -- | The @install@ command actually serves four different needs. It installs: --- * Nonlocal exes: +-- * exes: -- For example a program from hackage. The behavior is similar to the old -- install command, except that now conflicts between separate runs of the -- command are impossible thanks to the store. @@ -109,16 +219,17 @@ -- symlinked uin the directory specified by --symlink-bindir. -- To do this we need a dummy projectBaseContext containing the targets as -- estra packages and using a temporary dist directory. --- * Nonlocal libraries (TODO see #4558) --- * Local exes (TODO see #4558) --- * Local libraries (TODO see #4558) +-- * libraries +-- Libraries install through a similar process, but using GHC environment +-- files instead of symlinks. This means that 'new-install'ing libraries +-- only works on GHC >= 8.0. -- -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, NewInstallFlags) -> [String] -> GlobalFlags -> IO () -installAction (configFlags, configExFlags, installFlags, haddockFlags) +installAction (configFlags, configExFlags, installFlags, haddockFlags, newInstallFlags) targetStrings globalFlags = do -- We never try to build tests/benchmarks for remote packages. -- So we set them as disabled by default and error if they are explicitly @@ -130,26 +241,227 @@ die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't " ++ "be enabled in a remote package" - -- We need a place to put a temporary dist directory + let + withProject = do + let verbosity' = lessVerbose verbosity + + -- First, we need to learn about what's available to be installed. + localBaseCtx <- establishProjectBaseContext verbosity' cliConfig + let localDistDirLayout = distDirLayout localBaseCtx + pkgDb <- projectConfigWithBuilderRepoContext verbosity' (buildSettings localBaseCtx) (getSourcePackages verbosity) + + let + (targetStrings', packageIds) = partitionEithers . flip fmap targetStrings $ + \str -> case simpleParse str of + Just (pkgId :: PackageId) + | pkgVersion pkgId /= nullVersion -> Right pkgId + _ -> Left str + packageSpecifiers = flip fmap packageIds $ \case + PackageIdentifier{..} + | pkgVersion == nullVersion -> NamedPackage pkgName [] + | otherwise -> + NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)] + packageTargets = flip TargetPackageNamed Nothing . pkgName <$> packageIds + + if null targetStrings' + then return (packageSpecifiers, packageTargets, projectConfig localBaseCtx) + else do + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages localBaseCtx) Nothing targetStrings' + + (specs, selectors) <- withInstallPlan verbosity' localBaseCtx $ \elaboratedPlan _ -> do + -- Split into known targets and hackage packages. + (targets, hackageNames) <- case + resolveTargets + selectPackageTargets + selectComponentTarget + TargetProblemCommon + elaboratedPlan + (Just pkgDb) + targetSelectors of + Right targets -> do + -- Everything is a local dependency. + return (targets, []) + Left errs -> do + -- Not everything is local. + let + (errs', hackageNames) = partitionEithers . flip fmap errs $ \case + TargetProblemCommon (TargetAvailableInIndex name) -> Right name + err -> Left err + + when (not . null $ errs') $ reportTargetProblems verbosity errs' + + let + targetSelectors' = flip filter targetSelectors $ \case + TargetComponentUnknown name _ _ + | name `elem` hackageNames -> False + TargetPackageNamed name _ + | name `elem` hackageNames -> False + _ -> True + + -- This can't fail, because all of the errors are removed (or we've given up). + targets <- either (reportTargetProblems verbosity) return $ resolveTargets + selectPackageTargets + selectComponentTarget + TargetProblemCommon + elaboratedPlan + Nothing + targetSelectors' + + return (targets, hackageNames) + + let + planMap = InstallPlan.toMap elaboratedPlan + targetIds = Map.keys targets + + sdistize (SpecificSourcePackage spkg@SourcePackage{..}) = SpecificSourcePackage spkg' + where + sdistPath = distSdistFile localDistDirLayout packageInfoId TargzFormat + spkg' = spkg { packageSource = LocalTarballPackage sdistPath } + sdistize named = named + + local = sdistize <$> localPackages localBaseCtx + + gatherTargets :: UnitId -> TargetSelector + gatherTargets targetId = TargetPackageNamed pkgName Nothing + where + Just targetUnit = Map.lookup targetId planMap + PackageIdentifier{..} = packageId targetUnit + + targets' = fmap gatherTargets targetIds + + hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage] + hackagePkgs = flip NamedPackage [] <$> hackageNames + hackageTargets :: [TargetSelector] + hackageTargets = flip TargetPackageNamed Nothing <$> hackageNames + + createDirectoryIfMissing True (distSdistDirectory localDistDirLayout) + + unless (Map.null targets) $ + mapM_ + (\(SpecificSourcePackage pkg) -> packageToSdist verbosity + (distProjectRootDirectory localDistDirLayout) (Archive TargzFormat) + (distSdistFile localDistDirLayout (packageId pkg) TargzFormat) pkg + ) (localPackages localBaseCtx) + + if null targets + then return (hackagePkgs, hackageTargets) + else return (local ++ hackagePkgs, targets' ++ hackageTargets) + + return (specs ++ packageSpecifiers, selectors ++ packageTargets, projectConfig localBaseCtx) + + withoutProject globalConfig = do + let + parsePkg pkgName + | Just (pkg :: PackageId) <- simpleParse pkgName = return pkg + | otherwise = die' verbosity ("Invalid package ID: " ++ pkgName) + packageIds <- mapM parsePkg targetStrings + let + packageSpecifiers = flip fmap packageIds $ \case + PackageIdentifier{..} + | pkgVersion == nullVersion -> NamedPackage pkgName [] + | otherwise -> + NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)] + packageTargets = flip TargetPackageNamed Nothing . pkgName <$> packageIds + return (packageSpecifiers, packageTargets, globalConfig <> cliConfig) + + (specs, selectors, config) <- withProjectOrGlobalConfig verbosity globalConfigFlag + withProject withoutProject + + home <- getHomeDirectory + let + ProjectConfig { + projectConfigShared = ProjectConfigShared { + projectConfigHcFlavor, + projectConfigHcPath, + projectConfigHcPkg + }, + projectConfigLocalPackages = PackageConfig { + packageConfigProgramPaths, + packageConfigProgramArgs, + packageConfigProgramPathExtra + } + } = config + + hcFlavor = flagToMaybe projectConfigHcFlavor + hcPath = flagToMaybe projectConfigHcPath + hcPkg = flagToMaybe projectConfigHcPkg + + progDb = + userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths)) + . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs)) + . modifyProgramSearchPath + (++ [ ProgramSearchPathDir dir + | dir <- fromNubList packageConfigProgramPathExtra ]) + $ defaultProgramDb + + (compiler@Compiler { compilerId = + compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb') <- + configCompilerEx hcFlavor hcPath hcPkg progDb verbosity + + let + globalEnv name = + home ".ghc" ghcPlatformAndVersionString platform compilerVersion + "environments" name + localEnv dir = + dir ".ghc.environment." ++ ghcPlatformAndVersionString platform compilerVersion + + GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler + -- Why? We know what the first part will be, we only care about the packages. + filterEnvEntries = filter $ \case + GhcEnvFilePackageId _ -> True + _ -> False + + envFile <- case flagToMaybe (ninstEnvironmentPath newInstallFlags) of + Just spec + -- Is spec a bare word without any "pathy" content, then it refers to + -- a named global environment. + | takeBaseName spec == spec -> return (globalEnv spec) + | otherwise -> do + spec' <- makeAbsolute spec + isDir <- doesDirectoryExist spec' + if isDir + -- If spec is a directory, then make an ambient environment inside + -- that directory. + then return (localEnv spec') + -- Otherwise, treat it like a literal file path. + else return spec' + Nothing -> return (globalEnv "default") + + envFileExists <- doesFileExist envFile + envEntries <- filterEnvEntries <$> if + (compilerFlavor == GHC || compilerFlavor == GHCJS) + && supportsPkgEnvFiles && envFileExists + then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) -> + warn verbosity ("The environment file " ++ envFile ++ + " is unparsable. Libraries cannot be installed.") >> return [] + else return [] + + cabalDir <- getCabalDir + let + mstoreDir = flagToMaybe (globalStoreDir globalFlags) + mlogsDir = flagToMaybe (globalLogsDir globalFlags) + cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir + packageDbs = storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId + + installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb' + + let (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex envEntries + + -- Second, we need to use a fake project to let Cabal build the + -- installables correctly. For that, we need a place to put a + -- temporary dist directory. globalTmp <- getTemporaryDirectory withTempDirectory verbosity globalTmp "cabal-install." $ \tmpDir -> do - - let packageNames = mkPackageName <$> targetStrings - packageSpecifiers = - (\pname -> NamedPackage pname []) <$> packageNames - baseCtx <- establishDummyProjectBaseContext verbosity - cliConfig + config tmpDir - packageSpecifiers - - let targetSelectors = [ TargetPackageNamed pn Nothing - | pn <- packageNames ] + (envSpecs ++ specs) buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -161,7 +473,8 @@ selectComponentTarget TargetProblemCommon elaboratedPlan - targetSelectors + Nothing + selectors let elaboratedPlan' = pruneInstallPlanToTargets TargetActionBuild @@ -180,33 +493,84 @@ buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - let compiler = pkgConfigCompiler $ elaboratedShared buildCtx - let mkPkgBinDir = ( "bin") . - storePackageDirectory - (cabalStoreDirLayout $ cabalDirLayout baseCtx) - (compilerId compiler) + let + mkPkgBinDir = ( "bin") . + storePackageDirectory + (cabalStoreDirLayout $ cabalDirLayout baseCtx) + compilerId + installLibs = fromFlagOrDefault False (ninstInstallLibs newInstallFlags) - -- If there are exes, symlink them - let symlinkBindirUnknown = - "symlink-bindir is not defined. Set it in your cabal config file " - ++ "or use --symlink-bindir=" - symlinkBindir <- fromFlagOrDefault (die' verbosity symlinkBindirUnknown) - $ fmap makeAbsolute - $ projectConfigSymlinkBinDir - $ projectConfigBuildOnly - $ projectConfig $ baseCtx - createDirectoryIfMissingVerbose verbosity False symlinkBindir - traverse_ (symlinkBuiltPackage verbosity mkPkgBinDir symlinkBindir) - $ Map.toList $ targetsMap buildCtx + when (not installLibs) $ do + -- If there are exes, symlink them + let symlinkBindirUnknown = + "symlink-bindir is not defined. Set it in your cabal config file " + ++ "or use --symlink-bindir=" + symlinkBindir <- fromFlagOrDefault (die' verbosity symlinkBindirUnknown) + $ fmap makeAbsolute + $ projectConfigSymlinkBinDir + $ projectConfigBuildOnly + $ projectConfig $ baseCtx + createDirectoryIfMissingVerbose verbosity False symlinkBindir + traverse_ (symlinkBuiltPackage verbosity mkPkgBinDir symlinkBindir) + $ Map.toList $ targetsMap buildCtx runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + + when installLibs $ + if supportsPkgEnvFiles + then do + -- Why do we get it again? If we updated a globalPackage then we need + -- the new version. + installedIndex' <- getInstalledPackages verbosity compiler packageDbs progDb' + let + getLatest = fmap (head . snd) . take 1 . sortBy (comparing (Down . fst)) + . lookupPackageName installedIndex' + globalLatest = concat (getLatest <$> globalPackages) + + baseEntries = + GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs + globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest + pkgEntries = ordNub $ + globalEntries + ++ envEntries' + ++ entriesForLibraryComponents (targetsMap buildCtx) + contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries) + createDirectoryIfMissing True (takeDirectory envFile) + writeFileAtomic envFile (BS.pack contents') + else + warn verbosity $ + "The current compiler doesn't support safely installing libraries, " + ++ "so only executables will be available. (Library installation is " + ++ "supported on GHC 8.0+ only)" where configFlags' = disableTestsBenchsByDefault configFlags verbosity = fromFlagOrDefault normal (configVerbosity configFlags') cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags' configExFlags installFlags haddockFlags + globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) +globalPackages :: [PackageName] +globalPackages = mkPackageName <$> + [ "ghc", "hoopl", "bytestring", "unix", "base", "time", "hpc", "filepath" + , "process", "array", "integer-gmp", "containers", "ghc-boot", "binary" + , "ghc-prim", "ghci", "rts", "terminfo", "transformers", "deepseq" + , "ghc-boot-th", "pretty", "template-haskell", "directory", "text" + , "bin-package-db" + ] +environmentFileToSpecifiers :: InstalledPackageIndex -> [GhcEnvironmentFileEntry] + -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]) +environmentFileToSpecifiers ipi = foldMap $ \case + (GhcEnvFilePackageId unitId) + | Just InstalledPackageInfo{ sourcePackageId = PackageIdentifier{..}, installedUnitId } + <- lookupUnitId ipi unitId + , let pkgSpec = NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)] + -> if pkgName `elem` globalPackages + then ([pkgSpec], []) + else ([pkgSpec], [GhcEnvFilePackageId installedUnitId]) + _ -> ([], []) + + -- | Disables tests and benchmarks if they weren't explicitly enabled. disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags disableTestsBenchsByDefault configFlags = @@ -238,6 +602,20 @@ exe $ unUnqualComponentName exe +-- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries. +entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry] +entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) [] + where + hasLib :: (ComponentTarget, [TargetSelector]) -> Bool + hasLib (ComponentTarget CLibName _, _) = True + hasLib (ComponentTarget (CSubLibName _) _, _) = True + hasLib _ = False + + go :: UnitId -> [(ComponentTarget, [TargetSelector])] -> [GhcEnvironmentFileEntry] + go unitId targets + | any hasLib targets = [GhcEnvFilePackageId unitId] + | otherwise = [] + -- | Create a dummy project context, without a .cabal or a .cabal.project file -- (a place where to put a temporary dist directory is still needed) establishDummyProjectBaseContext @@ -250,7 +628,7 @@ -> IO ProjectBaseContext establishDummyProjectBaseContext verbosity cliConfig tmpDir localPackages = do - cabalDir <- defaultCabalDir + cabalDir <- getCabalDir -- Create the dist directories createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout @@ -264,9 +642,12 @@ let projectConfig = globalConfig <> cliConfig let ProjectConfigBuildOnly { - projectConfigLogsDir, - projectConfigStoreDir + projectConfigLogsDir } = projectConfigBuildOnly projectConfig + + ProjectConfigShared { + projectConfigStoreDir + } = projectConfigShared projectConfig mlogsDir = flagToMaybe projectConfigLogsDir mstoreDir = flagToMaybe projectConfigStoreDir diff --git a/Distribution/Client/CmdLegacy.hs b/Distribution/Client/CmdLegacy.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/CmdLegacy.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +module Distribution.Client.CmdLegacy ( legacyCmd, legacyWrapperCmd, newCmd ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Client.Sandbox + ( loadConfigOrSandboxConfig, findSavedDistPref ) +import qualified Distribution.Client.Setup as Client +import Distribution.Client.SetupWrapper + ( SetupScriptOptions(..), setupWrapper, defaultSetupScriptOptions ) +import qualified Distribution.Simple.Setup as Setup +import Distribution.Simple.Command +import Distribution.Simple.Utils + ( warn, wrapText ) +import Distribution.Verbosity + ( Verbosity, normal ) + +import Control.Exception + ( SomeException(..), try ) +import qualified Data.Text as T + +-- Tweaked versions of code from Main. +regularCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> Bool -> CommandSpec (globals -> IO action) +regularCmd ui action shouldWarn = + CommandSpec ui ((flip commandAddAction) (\flags extra globals -> showWarning flags >> action flags extra globals)) NormalCommand + where + showWarning flags = if shouldWarn + then warn (verbosity flags) (deprecationNote (commandName ui) ++ "\n") + else return () + +wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Bool -> CommandSpec (Client.GlobalFlags -> IO ()) +wrapperCmd ui verbosity' distPref shouldWarn = + CommandSpec ui (\ui' -> wrapperAction ui' verbosity' distPref shouldWarn) NormalCommand + +wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Bool -> Command (Client.GlobalFlags -> IO ()) +wrapperAction command verbosityFlag distPrefFlag shouldWarn = + commandAddAction command + { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do + let verbosity' = Setup.fromFlagOrDefault normal (verbosityFlag flags) + + if shouldWarn + then warn verbosity' (deprecationNote (commandName command) ++ "\n") + else return () + + load <- try (loadConfigOrSandboxConfig verbosity' globalFlags) + let config = either (\(SomeException _) -> mempty) snd load + distPref <- findSavedDistPref config (distPrefFlag flags) + let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } + + let command' = command { commandName = T.unpack . T.replace "v1-" "" . T.pack . commandName $ command } + + setupWrapper verbosity' setupScriptOptions Nothing + command' (const flags) (const extraArgs) + +-- + +class HasVerbosity a where + verbosity :: a -> Verbosity + +instance HasVerbosity (Setup.Flag Verbosity) where + verbosity = Setup.fromFlagOrDefault normal + +instance (HasVerbosity a) => HasVerbosity (a, b) where + verbosity (a, _) = verbosity a + +instance (HasVerbosity b) => HasVerbosity (a, b, c) where + verbosity (_ , b, _) = verbosity b + +instance (HasVerbosity a) => HasVerbosity (a, b, c, d) where + verbosity (a, _, _, _) = verbosity a + +instance HasVerbosity Setup.BuildFlags where + verbosity = verbosity . Setup.buildVerbosity + +instance HasVerbosity Setup.ConfigFlags where + verbosity = verbosity . Setup.configVerbosity + +instance HasVerbosity Setup.ReplFlags where + verbosity = verbosity . Setup.replVerbosity + +instance HasVerbosity Client.FreezeFlags where + verbosity = verbosity . Client.freezeVerbosity + +instance HasVerbosity Setup.HaddockFlags where + verbosity = verbosity . Setup.haddockVerbosity + +instance HasVerbosity Client.ExecFlags where + verbosity = verbosity . Client.execVerbosity + +instance HasVerbosity Client.UpdateFlags where + verbosity = verbosity . Client.updateVerbosity + +instance HasVerbosity Setup.CleanFlags where + verbosity = verbosity . Setup.cleanVerbosity + +instance HasVerbosity Client.SDistFlags where + verbosity = verbosity . Client.sDistVerbosity + +instance HasVerbosity Client.SandboxFlags where + verbosity = verbosity . Client.sandboxVerbosity + +instance HasVerbosity Setup.DoctestFlags where + verbosity = verbosity . Setup.doctestVerbosity + +-- + +deprecationNote :: String -> String +deprecationNote cmd = wrapText $ + "The " ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++ + + "Please switch to using either the new project style and the new-" ++ cmd ++ + " command or the legacy v1-" ++ cmd ++ " alias as new-style projects will" ++ + " become the default in the next version of cabal-install. Please file a" ++ + " bug if you cannot replicate a working v1- use case with the new-style commands.\n\n" ++ + + "For more information, see: https://wiki.haskell.org/Cabal/NewBuild\n" + +legacyNote :: String -> String +legacyNote cmd = wrapText $ + "The v1-" ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++ + + "It is a legacy feature and will be removed in a future release of cabal-install." ++ + " Please file a bug if you cannot replicate a working v1- use case with the new-style" ++ + " commands.\n\n" ++ + + "For more information, see: https://wiki.haskell.org/Cabal/NewBuild\n" + +toLegacyCmd :: (Bool -> CommandSpec (globals -> IO action)) -> [CommandSpec (globals -> IO action)] +toLegacyCmd mkSpec = [toDeprecated (mkSpec True), toLegacy (mkSpec False)] + where + legacyMsg = T.unpack . T.replace "v1-" "" . T.pack + + toLegacy (CommandSpec origUi@CommandUI{..} action type') = CommandSpec legUi action type' + where + legUi = origUi + { commandName = "v1-" ++ commandName + , commandNotes = Just $ \pname -> case commandNotes of + Just notes -> notes pname ++ "\n" ++ legacyNote commandName + Nothing -> legacyNote commandName + } + + toDeprecated (CommandSpec origUi@CommandUI{..} action type') = CommandSpec depUi action type' + where + depUi = origUi + { commandName = legacyMsg commandName + , commandUsage = legacyMsg . commandUsage + , commandDescription = (legacyMsg .) <$> commandDescription + , commandNotes = Just $ \pname -> case commandNotes of + Just notes -> legacyMsg (notes pname) ++ "\n" ++ deprecationNote commandName + Nothing -> deprecationNote commandName + } + +legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] +legacyCmd ui action = toLegacyCmd (regularCmd ui action) + +legacyWrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> [CommandSpec (Client.GlobalFlags -> IO ())] +legacyWrapperCmd ui verbosity' distPref = toLegacyCmd (wrapperCmd ui verbosity' distPref) + +newCmd :: CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] +newCmd origUi@CommandUI{..} action = [cmd v2Ui, cmd origUi] + where + cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand + v2Msg = T.unpack . T.replace "new-" "v2-" . T.pack + v2Ui = origUi + { commandName = v2Msg commandName + , commandUsage = v2Msg . commandUsage + , commandDescription = (v2Msg .) <$> commandDescription + , commandNotes = (v2Msg .) <$> commandDescription + } diff --git a/Distribution/Client/CmdRepl.hs b/Distribution/Client/CmdRepl.hs --- a/Distribution/Client/CmdRepl.hs +++ b/Distribution/Client/CmdRepl.hs @@ -1,4 +1,8 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} -- | cabal-install CLI command: repl -- @@ -13,33 +17,126 @@ selectComponentTarget ) where -import Distribution.Client.ProjectOrchestration -import Distribution.Client.CmdErrorMessages +import Prelude () +import Distribution.Client.Compat.Prelude +import Distribution.Compat.Lens +import qualified Distribution.Types.Lens as L + +import Distribution.Client.CmdErrorMessages +import Distribution.Client.CmdInstall + ( establishDummyProjectBaseContext ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.ProjectBuilding + ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages ) +import Distribution.Client.ProjectConfig + ( ProjectConfig(..), withProjectOrGlobalConfig + , projectConfigConfigFile, readGlobalConfig ) +import Distribution.Client.ProjectOrchestration +import Distribution.Client.ProjectPlanning + ( ElaboratedSharedConfig(..), ElaboratedInstallPlan ) +import Distribution.Client.RebuildMonad + ( runRebuild ) import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client +import Distribution.Client.Types + ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage ) import Distribution.Simple.Setup - ( HaddockFlags, fromFlagOrDefault ) + ( HaddockFlags, fromFlagOrDefault, replOptions + , Flag(..), toFlag, trueArg, falseArg ) import Distribution.Simple.Command - ( CommandUI(..), usageAlternatives ) + ( CommandUI(..), liftOption, usageAlternatives, option + , ShowOrParseArgs, OptionField, reqArg ) import Distribution.Package - ( packageName ) + ( Package(..), packageName, UnitId, installedUnitId ) +import Distribution.PackageDescription.PrettyPrint +import Distribution.Parsec.Class + ( Parsec(..) ) +import Distribution.Pretty + ( prettyShow ) +import Distribution.ReadE + ( ReadE, parsecToReadE ) +import qualified Distribution.SPDX.License as SPDX +import Distribution.Solver.Types.SourcePackage + ( SourcePackage(..) ) +import Distribution.Types.BuildInfo + ( BuildInfo(..), emptyBuildInfo ) import Distribution.Types.ComponentName ( componentNameString ) +import Distribution.Types.CondTree + ( CondTree(..), traverseCondTreeC ) +import Distribution.Types.Dependency + ( Dependency(..) ) +import Distribution.Types.GenericPackageDescription + ( emptyGenericPackageDescription ) +import Distribution.Types.PackageDescription + ( PackageDescription(..), emptyPackageDescription ) +import Distribution.Types.Library + ( Library(..), emptyLibrary ) +import Distribution.Types.PackageId + ( PackageIdentifier(..) ) +import Distribution.Types.Version + ( mkVersion, version0 ) +import Distribution.Types.VersionRange + ( anyVersion ) import Distribution.Text ( display ) import Distribution.Verbosity - ( Verbosity, normal ) + ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils - ( wrapText, die', ordNub ) + ( wrapText, die', debugNoWrap, ordNub, createTempDirectory, handleDoesNotExist ) +import Language.Haskell.Extension + ( Language(..) ) +import Data.List + ( (\\) ) import qualified Data.Map as Map import qualified Data.Set as Set -import Control.Monad (when) +import System.Directory + ( getTemporaryDirectory, removeDirectoryRecursive ) +import System.FilePath + ( () ) +type ReplFlags = [String] -replCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +data EnvFlags = EnvFlags + { envPackages :: [Dependency] + , envIncludeTransitive :: Flag Bool + , envIgnoreProject :: Flag Bool + } + +defaultEnvFlags :: EnvFlags +defaultEnvFlags = EnvFlags + { envPackages = [] + , envIncludeTransitive = toFlag True + , envIgnoreProject = toFlag False + } + +envOptions :: ShowOrParseArgs -> [OptionField EnvFlags] +envOptions _ = + [ option ['b'] ["build-depends"] + "Include an additional package in the environment presented to GHCi." + envPackages (\p flags -> flags { envPackages = p ++ envPackages flags }) + (reqArg "DEPENDENCY" dependencyReadE (fmap prettyShow :: [Dependency] -> [String])) + , option [] ["no-transitive-deps"] + "Don't automatically include transitive dependencies of requested packages." + envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p }) + falseArg + , option ['z'] ["ignore-project"] + "Only include explicitly specified packages (and 'base')." + envIgnoreProject (\p flags -> flags { envIgnoreProject = p }) + trueArg + ] + where + dependencyReadE :: ReadE [Dependency] + dependencyReadE = + fmap pure $ + parsecToReadE + ("couldn't parse dependency: " ++) + parsec + +replCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, ReplFlags, EnvFlags) replCommand = Client.installCommand { commandName = "new-repl", commandSynopsis = "Open an interactive session for the given component.", @@ -69,11 +166,36 @@ ++ " for the component named 'cname'\n" ++ " " ++ pname ++ " new-repl pkgname:cname\n" ++ " for the component 'cname' in the package 'pkgname'\n\n" + ++ " " ++ pname ++ " new-repl --build-depends lens\n" + ++ " add the latest version of the library 'lens' to the default component " + ++ "(or no componentif there is no project present)\n" + ++ " " ++ pname ++ " new-repl --build-depends \"lens >= 4.15 && < 4.18\"\n" + ++ " add a version (constrained between 4.15 and 4.18) of the library 'lens' " + ++ "to the default component (or no component if there is no project present)\n" - ++ cmdCommonHelpTextNewBuildBeta + ++ cmdCommonHelpTextNewBuildBeta, + commandDefaultFlags = (configFlags,configExFlags,installFlags,haddockFlags,[],defaultEnvFlags), + commandOptions = \showOrParseArgs -> + map liftOriginal (commandOptions Client.installCommand showOrParseArgs) + ++ map liftReplOpts (replOptions showOrParseArgs) + ++ map liftEnvOpts (envOptions showOrParseArgs) } + where + (configFlags,configExFlags,installFlags,haddockFlags) = commandDefaultFlags Client.installCommand + liftOriginal = liftOption projectOriginal updateOriginal + liftReplOpts = liftOption projectReplOpts updateReplOpts + liftEnvOpts = liftOption projectEnvOpts updateEnvOpts + projectOriginal (a,b,c,d,_,_) = (a,b,c,d) + updateOriginal (a,b,c,d) (_,_,_,_,e,f) = (a,b,c,d,e,f) + + projectReplOpts (_,_,_,_,e,_) = e + updateReplOpts e (a,b,c,d,_,f) = (a,b,c,d,e,f) + + projectEnvOpts (_,_,_,_,_,f) = f + updateEnvOpts f (a,b,c,d,e,_) = (a,b,c,d,e,f) + -- | The @repl@ command is very much like @build@. It brings the install plan -- up to date, selects that part of the plan needed by the given or implicit -- repl target and then executes the plan. @@ -85,56 +207,214 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" -- -replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) +replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, ReplFlags, EnvFlags) -> [String] -> GlobalFlags -> IO () -replAction (configFlags, configExFlags, installFlags, haddockFlags) +replAction (configFlags, configExFlags, installFlags, haddockFlags, replFlags, envFlags) targetStrings globalFlags = do - - baseCtx <- establishProjectBaseContext verbosity cliConfig + let + ignoreProject = fromFlagOrDefault False (envIgnoreProject envFlags) + with = withProject cliConfig verbosity targetStrings + without config = withoutProject (config <> cliConfig) verbosity targetStrings + + (baseCtx, targetSelectors, finalizer) <- if ignoreProject + then do + globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag + without globalConfig + else withProjectOrGlobalConfig verbosity globalConfigFlag with without - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) targetStrings + when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + die' verbosity $ "The repl command does not support '--only-dependencies'. " + ++ "You may wish to use 'build --only-dependencies' and then " + ++ "use 'repl'." - buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + (originalComponent, baseCtx') <- if null (envPackages envFlags) + then return (Nothing, baseCtx) + else + -- Unfortunately, the best way to do this is to let the normal solver + -- help us resolve the targets, but that isn't ideal for performance, + -- especially in the no-project case. + withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan _ -> do + targets <- validatedTargets elaboratedPlan targetSelectors + + let + (unitId, _) = head $ Map.toList targets + originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId + oci = OriginalComponentInfo unitId originalDeps + Just pkgId = packageId <$> InstallPlan.lookup elaboratedPlan unitId + baseCtx' = addDepsToProjectTarget (envPackages envFlags) pkgId baseCtx - when (buildSettingOnlyDeps (buildSettings baseCtx)) $ - die' verbosity $ "The repl command does not support '--only-dependencies'. " - ++ "You may wish to use 'build --only-dependencies' and then " - ++ "use 'repl'." + return (Just oci, baseCtx') + + -- Now, we run the solver again with the added packages. While the graph + -- won't actually reflect the addition of transitive dependencies, + -- they're going to be available already and will be offered to the REPL + -- and that's good enough. + -- + -- In addition, to avoid a *third* trip through the solver, we are + -- replicating the second half of 'runProjectPreBuildPhase' by hand + -- here. + (buildCtx, replFlags') <- withInstallPlan verbosity baseCtx' $ + \elaboratedPlan elaboratedShared' -> do + let ProjectBaseContext{..} = baseCtx' + + -- Recalculate with updated project. + targets <- validatedTargets elaboratedPlan targetSelectors - -- Interpret the targets on the command line as repl targets - -- (as opposed to say build or haddock targets). - targets <- either (reportTargetProblems verbosity) return - $ resolveTargets - selectPackageTargets - selectComponentTarget - TargetProblemCommon - elaboratedPlan - targetSelectors + let + elaboratedPlan' = pruneInstallPlanToTargets + TargetActionRepl + targets + elaboratedPlan + includeTransitive = fromFlagOrDefault True (envIncludeTransitive envFlags) + replFlags' = case originalComponent of + Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci + Nothing -> [] + + pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared' + elaboratedPlan' - -- Reject multiple targets, or at least targets in different - -- components. It is ok to have two module/file targets in the - -- same component, but not two that live in different components. - when (Set.size (distinctTargetComponents targets) > 1) $ - reportTargetProblems verbosity - [TargetProblemMultipleTargets targets] + let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages + pkgsBuildStatus elaboratedPlan' + debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'') - let elaboratedPlan' = pruneInstallPlanToTargets - TargetActionRepl - targets - elaboratedPlan - return (elaboratedPlan', targets) + let + buildCtx = ProjectBuildContext + { elaboratedPlanOriginal = elaboratedPlan + , elaboratedPlanToExecute = elaboratedPlan'' + , elaboratedShared = elaboratedShared' + , pkgsBuildStatus + , targetsMap = targets + } + return (buildCtx, replFlags') - printPlan verbosity baseCtx buildCtx + let buildCtx' = buildCtx + { elaboratedShared = (elaboratedShared buildCtx) + { pkgConfigReplOptions = replFlags ++ replFlags' } + } + printPlan verbosity baseCtx' buildCtx' - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx' + runProjectPostBuildPhase verbosity baseCtx' buildCtx' buildOutcomes + finalizer where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags installFlags haddockFlags + globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) + + validatedTargets elaboratedPlan targetSelectors = do + -- Interpret the targets on the command line as repl targets + -- (as opposed to say build or haddock targets). + targets <- either (reportTargetProblems verbosity) return + $ resolveTargets + selectPackageTargets + selectComponentTarget + TargetProblemCommon + elaboratedPlan + Nothing + targetSelectors + + -- Reject multiple targets, or at least targets in different + -- components. It is ok to have two module/file targets in the + -- same component, but not two that live in different components. + when (Set.size (distinctTargetComponents targets) > 1) $ + reportTargetProblems verbosity + [TargetProblemMultipleTargets targets] + + return targets + +data OriginalComponentInfo = OriginalComponentInfo + { ociUnitId :: UnitId + , ociOriginalDeps :: [UnitId] + } + deriving (Show) + +withProject :: ProjectConfig -> Verbosity -> [String] -> IO (ProjectBaseContext, [TargetSelector], IO ()) +withProject cliConfig verbosity targetStrings = do + baseCtx <- establishProjectBaseContext verbosity cliConfig + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors (localPackages baseCtx) (Just LibKind) targetStrings + + return (baseCtx, targetSelectors, return ()) + +withoutProject :: ProjectConfig -> Verbosity -> [String] -> IO (ProjectBaseContext, [TargetSelector], IO ()) +withoutProject config verbosity extraArgs = do + unless (null extraArgs) $ + die' verbosity $ "'repl' doesn't take any extra arguments when outside a project: " ++ unwords extraArgs + + globalTmp <- getTemporaryDirectory + tempDir <- createTempDirectory globalTmp "cabal-repl." + + -- We need to create a dummy package that lives in our dummy project. + let + sourcePackage = SourcePackage + { packageInfoId = pkgId + , packageDescription = genericPackageDescription + , packageSource = LocalUnpackedPackage tempDir + , packageDescrOverride = Nothing + } + genericPackageDescription = emptyGenericPackageDescription + & L.packageDescription .~ packageDescription + & L.condLibrary .~ Just (CondNode library [baseDep] []) + packageDescription = emptyPackageDescription + { package = pkgId + , specVersionRaw = Left (mkVersion [2, 2]) + , licenseRaw = Left SPDX.NONE + } + library = emptyLibrary { libBuildInfo = buildInfo } + buildInfo = emptyBuildInfo + { targetBuildDepends = [baseDep] + , defaultLanguage = Just Haskell2010 + } + baseDep = Dependency "base" anyVersion + pkgId = PackageIdentifier "fake-package" version0 + + writeGenericPackageDescription (tempDir "fake-package.cabal") genericPackageDescription + + baseCtx <- + establishDummyProjectBaseContext + verbosity + config + tempDir + [SpecificSourcePackage sourcePackage] + + let + targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing] + finalizer = handleDoesNotExist () (removeDirectoryRecursive tempDir) + + return (baseCtx, targetSelectors, finalizer) + +addDepsToProjectTarget :: [Dependency] + -> PackageId + -> ProjectBaseContext + -> ProjectBaseContext +addDepsToProjectTarget deps pkgId ctx = + (\p -> ctx { localPackages = p }) . fmap addDeps . localPackages $ ctx + where + addDeps :: PackageSpecifier UnresolvedSourcePackage + -> PackageSpecifier UnresolvedSourcePackage + addDeps (SpecificSourcePackage pkg) + | packageId pkg /= pkgId = SpecificSourcePackage pkg + | SourcePackage{..} <- pkg = + SpecificSourcePackage $ pkg { packageDescription = + packageDescription & (\f -> L.allCondTrees $ traverseCondTreeC f) + %~ (deps ++) + } + addDeps spec = spec + +generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> ReplFlags +generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = flags + where + deps, deps', trans, trans' :: [UnitId] + flags :: ReplFlags + deps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId + deps' = deps \\ ociOriginalDeps + trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps' + trans' = trans \\ ociOriginalDeps + flags = ("-package-id " ++) . prettyShow <$> + if includeTransitive then trans' else deps' -- | This defines what a 'TargetSelector' means for the @repl@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to, diff --git a/Distribution/Client/CmdRun.hs b/Distribution/Client/CmdRun.hs --- a/Distribution/Client/CmdRun.hs +++ b/Distribution/Client/CmdRun.hs @@ -1,4 +1,7 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | cabal-install CLI command: run -- @@ -6,6 +9,7 @@ -- * The @run@ CLI and action runCommand, runAction, + handleShebang, -- * Internals exposed for testing TargetProblem(..), @@ -20,7 +24,9 @@ import Distribution.Client.CmdErrorMessages import Distribution.Client.Setup - ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) + ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags ) +import Distribution.Client.GlobalFlags + ( defaultGlobalFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) @@ -33,12 +39,20 @@ import Distribution.Verbosity ( Verbosity, normal ) import Distribution.Simple.Utils - ( wrapText, die', ordNub, info ) + ( wrapText, die', ordNub, info + , createTempDirectory, handleDoesNotExist ) +import Distribution.Client.CmdInstall + ( establishDummyProjectBaseContext ) +import Distribution.Client.ProjectConfig + ( ProjectConfig(..), ProjectConfigShared(..) + , withProjectOrGlobalConfig ) import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage(..) , ElaboratedInstallPlan, binDirectoryFor ) import Distribution.Client.ProjectPlanning.Types ( dataDirsEnvironmentForPlan ) +import Distribution.Client.TargetSelector + ( TargetSelectorProblem(..), TargetString(..) ) import Distribution.Client.InstallPlan ( toList, foldPlanPackage ) import Distribution.Types.UnqualComponentName @@ -49,12 +63,51 @@ import Distribution.Types.UnitId ( UnitId ) +import Distribution.CabalSpecVersion + ( cabalSpecLatest ) +import Distribution.Client.Types + ( PackageLocation(..), PackageSpecifier(..) ) +import Distribution.FieldGrammar + ( takeFields, parseFieldGrammar ) +import Distribution.PackageDescription.FieldGrammar + ( executableFieldGrammar ) +import Distribution.PackageDescription.PrettyPrint + ( writeGenericPackageDescription ) +import Distribution.Parsec.Common + ( Position(..) ) +import Distribution.Parsec.ParseResult + ( ParseResult, parseString, parseFatalFailure ) +import Distribution.Parsec.Parser + ( readFields ) +import qualified Distribution.SPDX.License as SPDX +import Distribution.Solver.Types.SourcePackage as SP + ( SourcePackage(..) ) +import Distribution.Types.BuildInfo + ( BuildInfo(..) ) +import Distribution.Types.CondTree + ( CondTree(..) ) +import Distribution.Types.Executable + ( Executable(..) ) +import Distribution.Types.GenericPackageDescription as GPD + ( GenericPackageDescription(..), emptyGenericPackageDescription ) +import Distribution.Types.PackageDescription + ( PackageDescription(..), emptyPackageDescription ) +import Distribution.Types.PackageId + ( PackageIdentifier(..) ) +import Distribution.Types.Version + ( mkVersion, version0 ) +import Language.Haskell.Extension + ( Language(..) ) + +import qualified Data.ByteString.Char8 as BS import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Text.Parsec as P +import System.Directory + ( getTemporaryDirectory, removeDirectoryRecursive, doesFileExist ) import System.FilePath ( () ) - runCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) runCommand = Client.installCommand { commandName = "new-run", @@ -91,9 +144,8 @@ ++ " Build with '-O2' and run the program, passing it extra arguments.\n\n" ++ cmdCommonHelpTextNewBuildBeta - } - - + } + -- | The @run@ command runs a specified executable-like component, building it -- first if necessary. The component can be either an executable, a test, -- or a benchmark. This is particularly useful for passing arguments to @@ -106,17 +158,40 @@ -> [String] -> GlobalFlags -> IO () runAction (configFlags, configExFlags, installFlags, haddockFlags) targetStrings globalFlags = do - - baseCtx <- establishProjectBaseContext verbosity cliConfig + globalTmp <- getTemporaryDirectory + tempDir <- createTempDirectory globalTmp "cabal-repl." + + let + with = + establishProjectBaseContext verbosity cliConfig + without config = + establishDummyProjectBaseContext verbosity (config <> cliConfig) tempDir [] - targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) - (take 1 targetStrings) -- Drop the exe's args. + baseCtx <- withProjectOrGlobalConfig verbosity globalConfigFlag with without + let + scriptOrError script err = do + exists <- doesFileExist script + if exists + then BS.readFile script >>= handleScriptCase verbosity baseCtx tempDir + else reportTargetSelectorProblems verbosity err + + (baseCtx', targetSelectors) <- + readTargetSelectors (localPackages baseCtx) (Just ExeKind) (take 1 targetStrings) + >>= \case + Left err@(TargetSelectorNoTargetsInProject:_) + | (script:_) <- targetStrings -> scriptOrError script err + Left err@(TargetSelectorNoSuch t _:_) + | TargetString1 script <- t -> scriptOrError script err + Left err@(TargetSelectorExpected t _ _:_) + | TargetString1 script <- t -> scriptOrError script err + Left err -> reportTargetSelectorProblems verbosity err + Right sels -> return (baseCtx, sels) + buildCtx <- - runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do + runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do - when (buildSettingOnlyDeps (buildSettings baseCtx)) $ + when (buildSettingOnlyDeps (buildSettings baseCtx')) $ die' verbosity $ "The run command does not support '--only-dependencies'. " ++ "You may wish to use 'build --only-dependencies' and then " @@ -130,6 +205,7 @@ selectComponentTarget TargetProblemCommon elaboratedPlan + Nothing targetSelectors -- Reject multiple targets, or at least targets in different @@ -158,10 +234,10 @@ ++ "phase has been reached. This is a bug.") $ targetsMap buildCtx - printPlan verbosity baseCtx buildCtx + printPlan verbosity baseCtx' buildCtx - buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx - runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes + buildOutcomes <- runProjectBuildPhase verbosity baseCtx' buildCtx + runProjectPostBuildPhase verbosity baseCtx' buildCtx buildOutcomes let elaboratedPlan = elaboratedPlanToExecute buildCtx @@ -212,11 +288,96 @@ progInvokeArgs = args, progInvokeEnv = dataDirsEnvironmentForPlan elaboratedPlan } + + handleDoesNotExist () (removeDirectoryRecursive tempDir) where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags installFlags haddockFlags + globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) + +handleShebang :: String -> IO () +handleShebang script = + runAction (commandDefaultFlags runCommand) [script] defaultGlobalFlags + +parseScriptBlock :: BS.ByteString -> ParseResult Executable +parseScriptBlock str = + case readFields str of + Right fs -> do + let (fields, _) = takeFields fs + parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script") + Left perr -> parseFatalFailure pos (show perr) where + ppos = P.errorPos perr + pos = Position (P.sourceLine ppos) (P.sourceColumn ppos) + +readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable +readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block" + +readScriptBlockFromScript :: Verbosity -> BS.ByteString -> IO (Executable, BS.ByteString) +readScriptBlockFromScript verbosity str = + (\x -> (x, noShebang)) <$> readScriptBlock verbosity str' + where + start = "{- cabal:" + end = "-}" + + str' = BS.unlines + . takeWhile (/= end) + . drop 1 . dropWhile (/= start) + $ lines' + + noShebang = BS.unlines + . filter ((/= "#!") . BS.take 2) + $ lines' + + lines' = BS.lines str + +handleScriptCase :: Verbosity + -> ProjectBaseContext + -> FilePath + -> BS.ByteString + -> IO (ProjectBaseContext, [TargetSelector]) +handleScriptCase verbosity baseCtx tempDir scriptContents = do + (executable, contents') <- readScriptBlockFromScript verbosity scriptContents + + -- We need to create a dummy package that lives in our dummy project. + let + sourcePackage = SourcePackage + { packageInfoId = pkgId + , SP.packageDescription = genericPackageDescription + , packageSource = LocalUnpackedPackage tempDir + , packageDescrOverride = Nothing + } + genericPackageDescription = emptyGenericPackageDescription + { GPD.packageDescription = packageDescription + , condExecutables = [("script", CondNode executable' targetBuildDepends [])] + } + executable' = executable + { modulePath = "Main.hs" + , buildInfo = binfo + { defaultLanguage = + case defaultLanguage of + just@(Just _) -> just + Nothing -> Just Haskell2010 + } + } + binfo@BuildInfo{..} = buildInfo executable + packageDescription = emptyPackageDescription + { package = pkgId + , specVersionRaw = Left (mkVersion [2, 2]) + , licenseRaw = Left SPDX.NONE + } + pkgId = PackageIdentifier "fake-package" version0 + + writeGenericPackageDescription (tempDir "fake-package.cabal") genericPackageDescription + BS.writeFile (tempDir "Main.hs") contents' + + let + baseCtx' = baseCtx + { localPackages = localPackages baseCtx ++ [SpecificSourcePackage sourcePackage] } + targetSelectors = [TargetPackage TargetExplicitNamed [pkgId] Nothing] + + return (baseCtx', targetSelectors) singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName) singleExeOrElse action targetsMap = diff --git a/Distribution/Client/CmdSdist.hs b/Distribution/Client/CmdSdist.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/CmdSdist.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +module Distribution.Client.CmdSdist + ( sdistCommand, sdistAction, packageToSdist + , SdistFlags(..), defaultSdistFlags + , OutputFormat(..), ArchiveFormat(..) ) where + +import Distribution.Client.CmdErrorMessages + ( Plural(..), renderComponentKind ) +import Distribution.Client.ProjectOrchestration + ( ProjectBaseContext(..), establishProjectBaseContext ) +import Distribution.Client.TargetSelector + ( TargetSelector(..), ComponentKind + , readTargetSelectors, reportTargetSelectorProblems ) +import Distribution.Client.RebuildMonad + ( runRebuild ) +import Distribution.Client.Setup + ( ArchiveFormat(..), GlobalFlags(..) ) +import Distribution.Solver.Types.SourcePackage + ( SourcePackage(..) ) +import Distribution.Client.Types + ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage ) +import Distribution.Client.DistDirLayout + ( DistDirLayout(..), defaultDistDirLayout ) +import Distribution.Client.ProjectConfig + ( findProjectRoot, readProjectConfig ) + +import Distribution.Package + ( Package(packageId) ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.Pretty + ( prettyShow ) +import Distribution.ReadE + ( succeedReadE ) +import Distribution.Simple.Command + ( CommandUI(..), option, choiceOpt, reqArg ) +import Distribution.Simple.PreProcess + ( knownSuffixHandlers ) +import Distribution.Simple.Setup + ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe + , optionVerbosity, optionDistPref, trueArg + ) +import Distribution.Simple.SrcDist + ( listPackageSources ) +import Distribution.Simple.Utils + ( die', notice, withOutputMarker ) +import Distribution.Types.ComponentName + ( ComponentName, showComponentName ) +import Distribution.Types.PackageName + ( PackageName, unPackageName ) +import Distribution.Verbosity + ( Verbosity, normal ) + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Codec.Archive.Zip as Zip +import qualified Codec.Compression.GZip as GZip +import Control.Exception + ( throwIO ) +import Control.Monad + ( when, forM, forM_ ) +import Control.Monad.Trans + ( liftIO ) +import Control.Monad.State.Lazy + ( StateT, modify, gets, evalStateT ) +import Control.Monad.Writer.Lazy + ( WriterT, tell, execWriterT ) +import Data.Bits + ( shiftL ) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as BSL +import Data.Either + ( partitionEithers ) +import Data.List + ( find, sortOn, nub, intercalate ) +import qualified Data.Set as Set +import System.Directory + ( getCurrentDirectory, setCurrentDirectory + , createDirectoryIfMissing, makeAbsolute ) +import System.FilePath + ( (), (<.>), makeRelative, normalise, takeDirectory ) + +sdistCommand :: CommandUI SdistFlags +sdistCommand = CommandUI + { commandName = "new-sdist" + , commandSynopsis = "Generate a source distribution file (.tar.gz)." + , commandUsage = \pname -> + "Usage: " ++ pname ++ " new-sdist [FLAGS] [PACKAGES]\n" + , commandDescription = Just $ \_ -> + "Generates tarballs of project packages suitable for upload to Hackage." + , commandNotes = Nothing + , commandDefaultFlags = defaultSdistFlags + , commandOptions = \showOrParseArgs -> + [ optionVerbosity + sdistVerbosity (\v flags -> flags { sdistVerbosity = v }) + , optionDistPref + sdistDistDir (\dd flags -> flags { sdistDistDir = dd }) + showOrParseArgs + , option [] ["project-file"] + "Set the name of the cabal.project file to search for in parent directories" + sdistProjectFile (\pf flags -> flags { sdistProjectFile = pf }) + (reqArg "FILE" (succeedReadE Flag) flagToList) + , option ['l'] ["list-only"] + "Just list the sources, do not make a tarball" + sdistListSources (\v flags -> flags { sdistListSources = v }) + trueArg + , option ['z'] ["null-sep"] + "Separate the source files with NUL bytes rather than newlines." + sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v }) + trueArg + , option [] ["archive-format"] + "Choose what type of archive to create. No effect if given with '--list-only'" + sdistArchiveFormat (\v flags -> flags { sdistArchiveFormat = v }) + (choiceOpt + [ (Flag TargzFormat, ([], ["targz"]), + "Produce a '.tar.gz' format archive (default and required for uploading to hackage)") + , (Flag ZipFormat, ([], ["zip"]), + "Produce a '.zip' format archive") + ] + ) + , option ['o'] ["output-dir", "outputdir"] + "Choose the output directory of this command. '-' sends all output to stdout" + sdistOutputPath (\o flags -> flags { sdistOutputPath = o }) + (reqArg "PATH" (succeedReadE Flag) flagToList) + ] + } + +data SdistFlags = SdistFlags + { sdistVerbosity :: Flag Verbosity + , sdistDistDir :: Flag FilePath + , sdistProjectFile :: Flag FilePath + , sdistListSources :: Flag Bool + , sdistNulSeparated :: Flag Bool + , sdistArchiveFormat :: Flag ArchiveFormat + , sdistOutputPath :: Flag FilePath + } + +defaultSdistFlags :: SdistFlags +defaultSdistFlags = SdistFlags + { sdistVerbosity = toFlag normal + , sdistDistDir = mempty + , sdistProjectFile = mempty + , sdistListSources = toFlag False + , sdistNulSeparated = toFlag False + , sdistArchiveFormat = toFlag TargzFormat + , sdistOutputPath = mempty + } + +-- + +sdistAction :: SdistFlags -> [String] -> GlobalFlags -> IO () +sdistAction SdistFlags{..} targetStrings globalFlags = do + let verbosity = fromFlagOrDefault normal sdistVerbosity + mDistDirectory = flagToMaybe sdistDistDir + mProjectFile = flagToMaybe sdistProjectFile + globalConfig = globalConfigFile globalFlags + listSources = fromFlagOrDefault False sdistListSources + nulSeparated = fromFlagOrDefault False sdistNulSeparated + archiveFormat = fromFlagOrDefault TargzFormat sdistArchiveFormat + mOutputPath = flagToMaybe sdistOutputPath + + projectRoot <- either throwIO return =<< findProjectRoot Nothing mProjectFile + let distLayout = defaultDistDirLayout projectRoot mDistDirectory + dir <- getCurrentDirectory + projectConfig <- runRebuild dir $ readProjectConfig verbosity globalConfig distLayout + baseCtx <- establishProjectBaseContext verbosity projectConfig + let localPkgs = localPackages baseCtx + + targetSelectors <- either (reportTargetSelectorProblems verbosity) return + =<< readTargetSelectors localPkgs Nothing targetStrings + + mOutputPath' <- case mOutputPath of + Just "-" -> return (Just "-") + Just path -> Just <$> makeAbsolute path + Nothing -> return Nothing + + let + format = + if | listSources, nulSeparated -> SourceList '\0' + | listSources -> SourceList '\n' + | otherwise -> Archive archiveFormat + + ext = case format of + SourceList _ -> "list" + Archive TargzFormat -> "tar.gz" + Archive ZipFormat -> "zip" + + outputPath pkg = case mOutputPath' of + Just path + | path == "-" -> "-" + | otherwise -> path prettyShow (packageId pkg) <.> ext + Nothing + | listSources -> "-" + | otherwise -> distSdistFile distLayout (packageId pkg) archiveFormat + + createDirectoryIfMissing True (distSdistDirectory distLayout) + + case reifyTargetSelectors localPkgs targetSelectors of + Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs + Right pkgs + | length pkgs > 1, not listSources, Just "-" <- mOutputPath' -> + die' verbosity "Can't write multiple tarballs to standard output!" + | otherwise -> + mapM_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distLayout) format (outputPath pkg) pkg) pkgs + +data IsExec = Exec | NoExec + deriving (Show, Eq) + +data OutputFormat = SourceList Char + | Archive ArchiveFormat + deriving (Show, Eq) + +packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO () +packageToSdist verbosity projectRootDir format outputFile pkg = do + dir <- case packageSource pkg of + LocalUnpackedPackage path -> return path + _ -> die' verbosity "The impossible happened: a local package isn't local" + oldPwd <- getCurrentDirectory + setCurrentDirectory dir + + let norm flag = fmap ((flag, ) . normalise) + (norm NoExec -> nonexec, norm Exec -> exec) <- + listPackageSources verbosity (flattenPackageDescription $ packageDescription pkg) knownSuffixHandlers + + let write = if outputFile == "-" + then putStr . withOutputMarker verbosity . BSL.unpack + else BSL.writeFile outputFile + files = nub . sortOn snd $ nonexec ++ exec + + case format of + SourceList nulSep -> do + let prefix = makeRelative projectRootDir dir + write (BSL.pack . (++ [nulSep]) . intercalate [nulSep] . fmap ((prefix ) . snd) $ files) + when (outputFile /= "-") $ + notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n" + Archive TargzFormat -> do + let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) () + entriesM = do + let prefix = prettyShow (packageId pkg) + modify (Set.insert prefix) + case Tar.toTarPath True prefix of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [Tar.directoryEntry path] + + forM_ files $ \(perm, file) -> do + let fileDir = takeDirectory (prefix file) + perm' = case perm of + Exec -> Tar.executableFilePermissions + NoExec -> Tar.ordinaryFilePermissions + needsEntry <- gets (Set.notMember fileDir) + + when needsEntry $ do + modify (Set.insert fileDir) + case Tar.toTarPath True fileDir of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [Tar.directoryEntry path] + + contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ file + case Tar.toTarPath False (prefix file) of + Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) + Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = perm' }] + + entries <- execWriterT (evalStateT entriesM mempty) + let -- Pretend our GZip file is made on Unix. + normalize bs = BSL.concat [first, "\x03", rest'] + where + (first, rest) = BSL.splitAt 9 bs + rest' = BSL.tail rest + write . normalize . GZip.compress . Tar.write $ entries + when (outputFile /= "-") $ + notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n" + Archive ZipFormat -> do + let prefix = prettyShow (packageId pkg) + entries <- forM files $ \(perm, file) -> do + let perm' = case perm of + -- -rwxr-xr-x + Exec -> 0o010755 `shiftL` 16 + -- -rw-r--r-- + NoExec -> 0o010644 `shiftL` 16 + contents <- BSL.readFile file + return $ (Zip.toEntry (prefix file) 0 contents) { Zip.eExternalFileAttributes = perm' } + let archive = foldr Zip.addEntryToArchive Zip.emptyArchive entries + write (Zip.fromArchive archive) + when (outputFile /= "-") $ + notice verbosity $ "Wrote zip sdist to " ++ outputFile ++ "\n" + setCurrentDirectory oldPwd + +-- + +reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage] +reifyTargetSelectors pkgs sels = + case partitionEithers (foldMap go sels) of + ([], sels') -> Right sels' + (errs, _) -> Left errs + where + flatten (SpecificSourcePackage pkg@SourcePackage{}) = pkg + flatten _ = error "The impossible happened: how do we not know about a local package?" + pkgs' = fmap flatten pkgs + + getPkg pid = case find ((== pid) . packageId) pkgs' of + Just pkg -> Right pkg + Nothing -> error "The impossible happened: we have a reference to a local package that isn't in localPackages." + + go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage] + go (TargetPackage _ pids Nothing) = fmap getPkg pids + go (TargetAllPackages Nothing) = Right <$> pkgs' + + go (TargetPackage _ _ (Just kind)) = [Left (AllComponentsOnly kind)] + go (TargetAllPackages (Just kind)) = [Left (AllComponentsOnly kind)] + + go (TargetPackageNamed pname _) = [Left (NonlocalPackageNotAllowed pname)] + go (TargetComponentUnknown pname _ _) = [Left (NonlocalPackageNotAllowed pname)] + + go (TargetComponent _ cname _) = [Left (ComponentsNotAllowed cname)] + +data TargetProblem = AllComponentsOnly ComponentKind + | NonlocalPackageNotAllowed PackageName + | ComponentsNotAllowed ComponentName + +renderTargetProblem :: TargetProblem -> String +renderTargetProblem (AllComponentsOnly kind) = + "It is not possible to package only the " ++ renderComponentKind Plural kind ++ " from a package " + ++ "for distribution. Only entire packages may be packaged for distribution." +renderTargetProblem (ComponentsNotAllowed cname) = + "The component " ++ showComponentName cname ++ " cannot be packaged for distribution on its own. " + ++ "Only entire packages may be packaged for distribution." +renderTargetProblem (NonlocalPackageNotAllowed pname) = + "The package " ++ unPackageName pname ++ " cannot be packaged for distribution, because it is not " + ++ "local to this project." + diff --git a/Distribution/Client/CmdTest.hs b/Distribution/Client/CmdTest.hs --- a/Distribution/Client/CmdTest.hs +++ b/Distribution/Client/CmdTest.hs @@ -50,7 +50,10 @@ ++ "Dependencies are built or rebuilt as necessary. Additional " ++ "configuration flags can be specified on the command line and these " ++ "extend the project configuration from the 'cabal.project', " - ++ "'cabal.project.local' and other files.", + ++ "'cabal.project.local' and other files.\n\n" + + ++ "To pass command-line arguments to a test suite, see the " + ++ "new-run command.", commandNotes = Just $ \pname -> "Examples:\n" ++ " " ++ pname ++ " new-test\n" @@ -84,7 +87,7 @@ baseCtx <- establishProjectBaseContext verbosity cliConfig targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) targetStrings + =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -103,6 +106,7 @@ selectComponentTarget TargetProblemCommon elaboratedPlan + Nothing targetSelectors let elaboratedPlan' = pruneInstallPlanToTargets diff --git a/Distribution/Client/CmdUpdate.hs b/Distribution/Client/CmdUpdate.hs --- a/Distribution/Client/CmdUpdate.hs +++ b/Distribution/Client/CmdUpdate.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ViewPatterns, +{-# LANGUAGE CPP, LambdaCase, NamedFieldPuns, RecordWildCards, ViewPatterns, TupleSections #-} -- | cabal-install CLI command: update @@ -8,12 +8,17 @@ updateAction, ) where +import Prelude () +import Distribution.Client.Compat.Prelude + import Distribution.Client.Compat.Directory ( setModificationTime ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectConfig ( ProjectConfig(..) - , projectConfigWithSolverRepoContext ) + , ProjectConfigShared(projectConfigConfigFile) + , projectConfigWithSolverRepoContext + , withProjectOrGlobalConfig ) import Distribution.Client.Types ( Repo(..), RemoteRepo(..), isRepoRemote ) import Distribution.Client.HttpUtils @@ -29,7 +34,7 @@ import Distribution.Simple.Setup ( HaddockFlags, fromFlagOrDefault ) import Distribution.Simple.Utils - ( die', notice, wrapText, writeFileAtomic, noticeNoWrap, intercalate ) + ( die', notice, wrapText, writeFileAtomic, noticeNoWrap ) import Distribution.Verbosity ( Verbosity, normal, lessVerbose ) import Distribution.Client.IndexUtils.Timestamp @@ -43,7 +48,7 @@ import qualified Distribution.Compat.ReadP as ReadP import qualified Text.PrettyPrint as Disp -import Control.Monad (unless, when) +import Control.Monad (mapM, mapM_) import qualified Data.ByteString.Lazy as BS import Distribution.Client.GZipUtils (maybeDecompress) import System.FilePath ((<.>), dropExtension) @@ -109,10 +114,9 @@ -> [String] -> GlobalFlags -> IO () updateAction (configFlags, configExFlags, installFlags, haddockFlags) extraArgs globalFlags = do - - ProjectBaseContext { - projectConfig - } <- establishProjectBaseContext verbosity cliConfig + projectConfig <- withProjectOrGlobalConfig verbosity globalConfigFlag + (projectConfig <$> establishProjectBaseContext verbosity cliConfig) + (\globalConfig -> return $ globalConfig <> cliConfig) projectConfigWithSolverRepoContext verbosity (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig) @@ -165,6 +169,7 @@ cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags configExFlags installFlags haddockFlags + globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, IndexState) -> IO () diff --git a/Distribution/Client/Compat/ExecutablePath.hs b/Distribution/Client/Compat/ExecutablePath.hs --- a/Distribution/Client/Compat/ExecutablePath.hs +++ b/Distribution/Client/Compat/ExecutablePath.hs @@ -35,25 +35,6 @@ import System.Posix.Internals #endif --- GHC 7.0.* compatibility. 'System.Posix.Internals' in base-4.3.* doesn't --- provide 'peekFilePath' and 'peekFilePathLen'. -#if !MIN_VERSION_base(4,4,0) -#ifdef mingw32_HOST_OS - -peekFilePath :: CWString -> IO FilePath -peekFilePath = peekCWString - -#else - -peekFilePath :: CString -> IO FilePath -peekFilePath = peekCString - -peekFilePathLen :: CStringLen -> IO FilePath -peekFilePathLen = peekCStringLen - -#endif -#endif - -- The exported function is defined outside any if-guard to make sure -- every OS implements it with the same type. diff --git a/Distribution/Client/Compat/Prelude.hs b/Distribution/Client/Compat/Prelude.hs --- a/Distribution/Client/Compat/Prelude.hs +++ b/Distribution/Client/Compat/Prelude.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - -- to suppress WARNING in "Distribution.Compat.Prelude.Internal" {-# OPTIONS_GHC -fno-warn-deprecations #-} @@ -20,16 +18,5 @@ import Prelude (IO) import Distribution.Compat.Prelude.Internal hiding (IO) - -#if MIN_VERSION_base(4,6,0) import Text.Read ( readMaybe ) -#endif - -#if !MIN_VERSION_base(4,6,0) --- | An implementation of readMaybe, for compatibility with older base versions. -readMaybe :: Read a => String -> Maybe a -readMaybe s = case reads s of - [(x,"")] -> Just x - _ -> Nothing -#endif diff --git a/Distribution/Client/Compat/Process.hs b/Distribution/Client/Compat/Process.hs --- a/Distribution/Client/Compat/Process.hs +++ b/Distribution/Client/Compat/Process.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE CPP #-} - ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Compat.Process @@ -17,10 +15,6 @@ module Distribution.Client.Compat.Process ( readProcessWithExitCode ) where - -#if !MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif import Control.Exception (catch, throw) import System.Exit (ExitCode (ExitFailure)) diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs --- a/Distribution/Client/Config.hs +++ b/Distribution/Client/Config.hs @@ -22,7 +22,7 @@ showConfigWithComments, parseConfig, - defaultCabalDir, + getCabalDir, defaultConfigFile, defaultCacheDir, defaultCompiler, @@ -124,7 +124,7 @@ import System.IO.Error ( isDoesNotExistError ) import Distribution.Compat.Environment - ( getEnvironment ) + ( getEnvironment, lookupEnv ) import Distribution.Compat.Exception ( catchIO ) import qualified Paths_cabal_install @@ -408,12 +408,14 @@ haddockInternal = combine haddockInternal, haddockCss = combine haddockCss, haddockLinkedSource = combine haddockLinkedSource, + haddockQuickJump = combine haddockQuickJump, haddockHscolourCss = combine haddockHscolourCss, haddockContents = combine haddockContents, haddockDistPref = combine haddockDistPref, haddockKeepTempFiles = combine haddockKeepTempFiles, haddockVerbosity = combine haddockVerbosity, - haddockCabalFilePath = combine haddockCabalFilePath + haddockCabalFilePath = combine haddockCabalFilePath, + haddockArgs = lastNonEmpty haddockArgs } where combine = combine' savedHaddockFlags @@ -431,7 +433,7 @@ -- baseSavedConfig :: IO SavedConfig baseSavedConfig = do - userPrefix <- defaultCabalDir + userPrefix <- getCabalDir cacheDir <- defaultCacheDir logsDir <- defaultLogsDir worldFile <- defaultWorldFile @@ -481,40 +483,45 @@ } } ---TODO: misleading, there's no way to override this default --- either make it possible or rename to simply getCabalDir. defaultCabalDir :: IO FilePath defaultCabalDir = getAppUserDataDirectory "cabal" +getCabalDir :: IO FilePath +getCabalDir = do + mDir <- lookupEnv "CABAL_DIR" + case mDir of + Nothing -> defaultCabalDir + Just dir -> return dir + defaultConfigFile :: IO FilePath defaultConfigFile = do - dir <- defaultCabalDir + dir <- getCabalDir return $ dir "config" defaultCacheDir :: IO FilePath defaultCacheDir = do - dir <- defaultCabalDir + dir <- getCabalDir return $ dir "packages" defaultLogsDir :: IO FilePath defaultLogsDir = do - dir <- defaultCabalDir + dir <- getCabalDir return $ dir "logs" -- | Default position of the world file defaultWorldFile :: IO FilePath defaultWorldFile = do - dir <- defaultCabalDir + dir <- getCabalDir return $ dir "world" defaultExtraPath :: IO [FilePath] defaultExtraPath = do - dir <- defaultCabalDir + dir <- getCabalDir return [dir "bin"] defaultSymlinkPath :: IO FilePath defaultSymlinkPath = do - dir <- defaultCabalDir + dir <- getCabalDir return (dir "bin") defaultCompiler :: CompilerFlavor diff --git a/Distribution/Client/Configure.hs b/Distribution/Client/Configure.hs --- a/Distribution/Client/Configure.hs +++ b/Distribution/Client/Configure.hs @@ -134,7 +134,7 @@ ++ message ++ "\nTrying configure anyway." setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing) - Nothing configureCommand (const configFlags) extraArgs + Nothing configureCommand (const configFlags) (const extraArgs) Right installPlan0 -> let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0 @@ -387,7 +387,7 @@ extraArgs = setupWrapper verbosity - scriptOptions (Just pkg) configureCommand configureFlags extraArgs + scriptOptions (Just pkg) configureCommand configureFlags (const extraArgs) where gpkg = packageDescription spkg diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs --- a/Distribution/Client/Dependency.hs +++ b/Distribution/Client/Dependency.hs @@ -946,24 +946,24 @@ (sortNubOn dependencyName required) (sortNubOn packageName specified) + compSpec = enableStanzas stanzas -- TODO: It would be nicer to use ComponentDeps here so we can be more - -- precise in our checks. That's a bit tricky though, as this currently - -- relies on the 'buildDepends' field of 'PackageDescription'. (OTOH, that - -- field is deprecated and should be removed anyway.) As long as we _do_ - -- use a flat list here, we have to allow for duplicates when we fold - -- specifiedDeps; once we have proper ComponentDeps here we should get rid - -- of the `nubOn` in `mergeDeps`. + -- precise in our checks. In fact, this no longer relies on buildDepends and + -- thus should be easier to fix. As long as we _do_ use a flat list here, we + -- have to allow for duplicates when we fold specifiedDeps; once we have + -- proper ComponentDeps here we should get rid of the `nubOn` in + -- `mergeDeps`. requiredDeps :: [Dependency] requiredDeps = --TODO: use something lower level than finalizePD case finalizePD specifiedFlags - (enableStanzas stanzas) + compSpec (const True) platform cinfo [] (packageDescription pkg) of Right (resolvedPkg, _) -> - externalBuildDepends resolvedPkg + externalBuildDepends resolvedPkg compSpec ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg) Left _ -> error "configuredPackageInvalidDeps internal error" diff --git a/Distribution/Client/DistDirLayout.hs b/Distribution/Client/DistDirLayout.hs --- a/Distribution/Client/DistDirLayout.hs +++ b/Distribution/Client/DistDirLayout.hs @@ -27,10 +27,14 @@ import Distribution.Package ( PackageId, ComponentId, UnitId ) +import Distribution.Client.Setup + ( ArchiveFormat(..) ) import Distribution.Compiler import Distribution.Simple.Compiler ( PackageDB(..), PackageDBStack, OptimisationLevel(..) ) import Distribution.Text +import Distribution.Pretty + ( prettyShow ) import Distribution.Types.ComponentName import Distribution.System @@ -85,10 +89,14 @@ distBuildDirectory :: DistDirParams -> FilePath, distBuildRootDirectory :: FilePath, + -- | The directory under dist where we download tarballs and source + -- control repos to. + -- + distDownloadSrcDirectory :: FilePath, + -- | The directory under dist where we put the unpacked sources of -- packages, in those cases where it makes sense to keep the build - -- artifacts to reduce rebuild times. These can be tarballs or could be - -- scm repos. + -- artifacts to reduce rebuild times. -- distUnpackedSrcDirectory :: PackageId -> FilePath, distUnpackedSrcRootDirectory :: FilePath, @@ -105,6 +113,10 @@ distPackageCacheFile :: DistDirParams -> String -> FilePath, distPackageCacheDirectory :: DistDirParams -> FilePath, + -- | The location that sdists are placed by default. + distSdistFile :: PackageId -> ArchiveFormat -> FilePath, + distSdistDirectory :: FilePath, + distTempDirectory :: FilePath, distBinDirectory :: FilePath, @@ -205,12 +217,22 @@ distUnpackedSrcRootDirectory = distDirectory "src" distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory display pkgid + -- we shouldn't get name clashes so this should be fine: + distDownloadSrcDirectory = distUnpackedSrcRootDirectory distProjectCacheDirectory = distDirectory "cache" distProjectCacheFile name = distProjectCacheDirectory name distPackageCacheDirectory params = distBuildDirectory params "cache" distPackageCacheFile params name = distPackageCacheDirectory params name + + distSdistFile pid format = distSdistDirectory prettyShow pid <.> ext + where + ext = case format of + TargzFormat -> "tar.gz" + ZipFormat -> "zip" + + distSdistDirectory = distDirectory "sdist" distTempDirectory = distDirectory "tmp" diff --git a/Distribution/Client/Fetch.hs b/Distribution/Client/Fetch.hs --- a/Distribution/Client/Fetch.hs +++ b/Distribution/Client/Fetch.hs @@ -218,6 +218,10 @@ die' verbosity $ "The 'fetch' command does not yet support remote tarballs. " ++ "In the meantime you can use the 'unpack' commands." + RemoteSourceRepoPackage _repo _ -> + die' verbosity $ "The 'fetch' command does not yet support remote " + ++ "source repositores." + RepoTarballPackage repo pkgid _ -> do _ <- fetchRepoTarball verbosity repoCtxt repo pkgid return () diff --git a/Distribution/Client/FetchUtils.hs b/Distribution/Client/FetchUtils.hs --- a/Distribution/Client/FetchUtils.hs +++ b/Distribution/Client/FetchUtils.hs @@ -40,13 +40,15 @@ import Distribution.Package ( PackageId, packageName, packageVersion ) import Distribution.Simple.Utils - ( notice, info, debug, setupMessage ) + ( notice, info, debug, die' ) import Distribution.Text ( display ) import Distribution.Verbosity ( Verbosity, verboseUnmarkOutput ) import Distribution.Client.GlobalFlags ( RepoContext(..) ) +import Distribution.Client.Utils + ( ProgressPhase(..), progressMessage ) import Data.Maybe import Data.Map (Map) @@ -81,6 +83,8 @@ LocalTarballPackage _file -> return True RemoteTarballPackage _uri local -> return (isJust local) RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid) + RemoteSourceRepoPackage _ local -> return (isJust local) + -- | Checks if the package has already been fetched (or does not need -- fetching) and if so returns evidence in the form of a 'PackageLocation' @@ -97,13 +101,15 @@ return (Just $ RemoteTarballPackage uri file) RepoTarballPackage repo pkgid (Just file) -> return (Just $ RepoTarballPackage repo pkgid file) + RemoteSourceRepoPackage repo (Just dir) -> + return (Just $ RemoteSourceRepoPackage repo dir) - RemoteTarballPackage _uri Nothing -> return Nothing + RemoteTarballPackage _uri Nothing -> return Nothing + RemoteSourceRepoPackage _repo Nothing -> return Nothing RepoTarballPackage repo pkgid Nothing -> fmap (fmap (RepoTarballPackage repo pkgid)) (checkRepoTarballFetched repo pkgid) - -- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'. -- checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath) @@ -130,6 +136,8 @@ return (RemoteTarballPackage uri file) RepoTarballPackage repo pkgid (Just file) -> return (RepoTarballPackage repo pkgid file) + RemoteSourceRepoPackage repo (Just dir) -> + return (RemoteSourceRepoPackage repo dir) RemoteTarballPackage uri Nothing -> do path <- downloadTarballPackage uri @@ -137,6 +145,8 @@ RepoTarballPackage repo pkgid Nothing -> do local <- fetchRepoTarball verbosity repoCtxt repo pkgid return (RepoTarballPackage repo pkgid local) + RemoteSourceRepoPackage _repo Nothing -> + die' verbosity "fetchPackage: source repos not supported" where downloadTarballPackage uri = do transport <- repoContextGetTransport repoCtxt @@ -157,8 +167,12 @@ if fetched then do info verbosity $ display pkgid ++ " has already been downloaded." return (packageFile repo pkgid) - else do setupMessage verbosity "Downloading" pkgid - downloadRepoPackage + else do progressMessage verbosity ProgressDownloading (display pkgid) + res <- downloadRepoPackage + progressMessage verbosity ProgressDownloaded (display pkgid) + return res + + where downloadRepoPackage = case repo of RepoLocal{..} -> return (packageFile repo pkgid) diff --git a/Distribution/Client/FileMonitor.hs b/Distribution/Client/FileMonitor.hs --- a/Distribution/Client/FileMonitor.hs +++ b/Distribution/Client/FileMonitor.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving, +{-# LANGUAGE DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving, NamedFieldPuns, BangPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -39,11 +39,7 @@ import Prelude () import Distribution.Client.Compat.Prelude -#if MIN_VERSION_containers(0,5,0) import qualified Data.Map.Strict as Map -#else -import qualified Data.Map as Map -#endif import qualified Data.ByteString.Lazy as BS import qualified Distribution.Compat.Binary as Binary import qualified Data.Hashable as Hashable diff --git a/Distribution/Client/GenBounds.hs b/Distribution/Client/GenBounds.hs --- a/Distribution/Client/GenBounds.hs +++ b/Distribution/Client/GenBounds.hs @@ -29,7 +29,7 @@ import Distribution.Package ( Package(..), unPackageName, packageName, packageVersion ) import Distribution.PackageDescription - ( buildDepends ) + ( enabledBuildDepends ) import Distribution.PackageDescription.Configuration ( finalizePD ) import Distribution.PackageDescription.Parsec @@ -122,7 +122,7 @@ Left _ -> putStrLn "finalizePD failed" Right (pd,_) -> do let needBounds = filter (not . hasUpperBound . depVersion) $ - buildDepends pd + enabledBuildDepends pd defaultComponentRequestedSpec if (null needBounds) then putStrLn diff --git a/Distribution/Client/Get.hs b/Distribution/Client/Get.hs --- a/Distribution/Client/Get.hs +++ b/Distribution/Client/Get.hs @@ -14,7 +14,12 @@ ----------------------------------------------------------------------------- module Distribution.Client.Get ( - get + get, + + -- * Cloning 'SourceRepo's + -- | Mainly exported for testing purposes + clonePackagesFromSourceRepo, + ClonePackageException(..), ) where import Prelude () @@ -25,39 +30,33 @@ import Distribution.Simple.Setup ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.Utils - ( notice, die', info, rawSystemExitCode, writeFileAtomic ) + ( notice, die', info, writeFileAtomic ) import Distribution.Verbosity ( Verbosity ) -import Distribution.Text(display) +import Distribution.Text (display) import qualified Distribution.PackageDescription as PD +import Distribution.Simple.Program + ( programName ) import Distribution.Client.Setup ( GlobalFlags(..), GetFlags(..), RepoContext(..) ) import Distribution.Client.Types import Distribution.Client.Targets import Distribution.Client.Dependency +import Distribution.Client.VCS import Distribution.Client.FetchUtils import qualified Distribution.Client.Tar as Tar (extractTarGzFile) import Distribution.Client.IndexUtils as IndexUtils ( getSourcePackagesAtIndexState ) -import Distribution.Client.Compat.Process - ( readProcessWithExitCode ) -import Distribution.Compat.Exception - ( catchIO ) - import Distribution.Solver.Types.SourcePackage import Control.Exception - ( finally ) + ( Exception(..), catch, throwIO ) import Control.Monad - ( forM_, mapM_ ) -import qualified Data.Map -import Data.Ord - ( comparing ) + ( mapM, forM_, mapM_ ) +import qualified Data.Map as Map import System.Directory - ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist - , getCurrentDirectory, setCurrentDirectory - ) + ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist ) import System.Exit ( ExitCode(..) ) import System.FilePath @@ -75,11 +74,11 @@ notice verbosity "No packages requested. Nothing to do." get verbosity repoCtxt globalFlags getFlags userTargets = do - let useFork = case (getSourceRepository getFlags) of - NoFlag -> False - _ -> True + let useSourceRepo = case getSourceRepository getFlags of + NoFlag -> False + _ -> True - unless useFork $ + unless useSourceRepo $ mapM_ (checkTarget verbosity) userTargets let idxState = flagToMaybe $ getIndexState getFlags @@ -98,8 +97,8 @@ unless (null prefix) $ createDirectoryIfMissing True prefix - if useFork - then fork pkgs + if useSourceRepo + then clone pkgs else unpack pkgs where @@ -109,11 +108,15 @@ prefix = fromFlagOrDefault "" (getDestDir getFlags) - fork :: [UnresolvedSourcePackage] -> IO () - fork pkgs = do - let kind = fromFlag . getSourceRepository $ getFlags - branchers <- findUsableBranchers - mapM_ (forkPackage verbosity branchers prefix kind) pkgs + clone :: [UnresolvedSourcePackage] -> IO () + clone = clonePackagesFromSourceRepo verbosity prefix kind + . map (\pkg -> (packageId pkg, packageSourceRepos pkg)) + where + kind = fromFlag . getSourceRepository $ getFlags + packageSourceRepos :: SourcePackage loc -> [SourceRepo] + packageSourceRepos = PD.sourceRepos + . PD.packageDescription + . packageDescription unpack :: [UnresolvedSourcePackage] -> IO () unpack pkgs = do @@ -132,6 +135,10 @@ RepoTarballPackage _repo _pkgid tarballPath -> unpackPackage verbosity prefix pkgid descOverride tarballPath + RemoteSourceRepoPackage _repo _ -> + die' verbosity $ "The 'get' command does no yet support targets " + ++ "that are remote source repositories." + LocalUnpackedPackage _ -> error "Distribution.Client.Get.unpack: the impossible happened." where @@ -178,174 +185,115 @@ -- ------------------------------------------------------------ --- * Forking the source repository +-- * Cloning packages from their declared source repositories -- ------------------------------------------------------------ -data BranchCmd = BranchCmd (Verbosity -> FilePath -> IO ExitCode) -data Brancher = Brancher - { brancherBinary :: String - , brancherBuildCmd :: PD.SourceRepo -> Maybe BranchCmd - } +data ClonePackageException = + ClonePackageNoSourceRepos PackageId + | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind) + | ClonePackageNoRepoType PackageId SourceRepo + | ClonePackageUnsupportedRepoType PackageId SourceRepo RepoType + | ClonePackageNoRepoLocation PackageId SourceRepo + | ClonePackageDestinationExists PackageId FilePath Bool + | ClonePackageFailedWithExitCode PackageId SourceRepo String ExitCode + deriving (Show, Eq) --- | The set of all supported branch drivers. -allBranchers :: [(PD.RepoType, Brancher)] -allBranchers = - [ (PD.Bazaar, branchBzr) - , (PD.Darcs, branchDarcs) - , (PD.Git, branchGit) - , (PD.Mercurial, branchHg) - , (PD.SVN, branchSvn) - ] +instance Exception ClonePackageException where + displayException (ClonePackageNoSourceRepos pkgid) = + "Cannot fetch a source repository for package " ++ display pkgid + ++ ". The package does not specify any source repositories." --- | Find which usable branch drivers (selected from 'allBranchers') are --- available and usable on the local machine. --- --- Each driver's main command is run with @--help@, and if the child process --- exits successfully, that brancher is considered usable. -findUsableBranchers :: IO (Data.Map.Map PD.RepoType Brancher) -findUsableBranchers = do - let usable (_, brancher) = flip catchIO (const (return False)) $ do - let cmd = brancherBinary brancher - (exitCode, _, _) <- readProcessWithExitCode cmd ["--help"] "" - return (exitCode == ExitSuccess) - pairs <- filterM usable allBranchers - return (Data.Map.fromList pairs) + displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) = + "Cannot fetch a source repository for package " ++ display pkgid + ++ ". The package does not specify a source repository of the requested " + ++ "kind" ++ maybe "." (\k -> " (kind " ++ display k ++ ").") repoKind --- | Fork a single package from a remote source repository to the local --- file system. -forkPackage :: Verbosity - -> Data.Map.Map PD.RepoType Brancher - -- ^ Branchers supported by the local machine. - -> FilePath - -- ^ The directory in which new branches or repositories will - -- be created. - -> (Maybe PD.RepoKind) - -- ^ Which repo to choose. - -> SourcePackage loc - -- ^ The package to fork. - -> IO () -forkPackage verbosity branchers prefix kind src = do - let desc = PD.packageDescription (packageDescription src) - pkgid = display (packageId src) - pkgname = display (packageName src) - destdir = prefix pkgname + displayException (ClonePackageNoRepoType pkgid _repo) = + "Cannot fetch the source repository for package " ++ display pkgid + ++ ". The package's description specifies a source repository but does " + ++ "not specify the repository 'type' field (e.g. git, darcs or hg)." - destDirExists <- doesDirectoryExist destdir - when destDirExists $ do - die' verbosity ("The directory " ++ show destdir ++ " already exists, not forking.") + displayException (ClonePackageUnsupportedRepoType pkgid _ repoType) = + "Cannot fetch the source repository for package " ++ display pkgid + ++ ". The repository type '" ++ display repoType + ++ "' is not yet supported." - destFileExists <- doesFileExist destdir - when destFileExists $ do - die' verbosity ("A file " ++ show destdir ++ " is in the way, not forking.") + displayException (ClonePackageNoRepoLocation pkgid _repo) = + "Cannot fetch the source repository for package " ++ display pkgid + ++ ". The package's description specifies a source repository but does " + ++ "not specify the repository 'location' field (i.e. the URL)." - let repos = PD.sourceRepos desc - case findBranchCmd branchers repos kind of - Just (BranchCmd io) -> do - exitCode <- io verbosity destdir - case exitCode of - ExitSuccess -> return () - ExitFailure _ -> die' verbosity ("Couldn't fork package " ++ pkgid) - Nothing -> case repos of - [] -> die' verbosity ("Package " ++ pkgid - ++ " does not have any source repositories.") - _ -> die' verbosity ("Package " ++ pkgid - ++ " does not have any usable source repositories.") + displayException (ClonePackageDestinationExists pkgid dest isdir) = + "Not fetching the source repository for package " ++ display pkgid ++ ". " + ++ if isdir then "The destination directory " ++ dest ++ " already exists." + else "A file " ++ dest ++ " is in the way." --- | Given a set of possible branchers, and a set of possible source --- repositories, find a repository that is both 1) likely to be specific to --- this source version and 2) is supported by the local machine. -findBranchCmd :: Data.Map.Map PD.RepoType Brancher -> [PD.SourceRepo] - -> (Maybe PD.RepoKind) -> Maybe BranchCmd -findBranchCmd branchers allRepos maybeKind = cmd where - -- Sort repositories by kind, from This to Head to Unknown. Repositories - -- with equivalent kinds are selected based on the order they appear in - -- the Cabal description file. - repos' = sortBy (comparing thisFirst) allRepos - thisFirst r = case PD.repoKind r of - PD.RepoThis -> 0 :: Int - PD.RepoHead -> case PD.repoTag r of - -- If the type is 'head' but the author specified a tag, they - -- probably meant to create a 'this' repository but screwed up. - Just _ -> 0 - Nothing -> 1 - PD.RepoKindUnknown _ -> 2 + displayException (ClonePackageFailedWithExitCode + pkgid repo vcsprogname exitcode) = + "Failed to fetch the source repository for package " ++ display pkgid + ++ maybe "" (", repository location " ++) (PD.repoLocation repo) ++ " (" + ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")." - -- If the user has specified the repo kind, filter out the repositories - -- she's not interested in. - repos = maybe repos' (\k -> filter ((==) k . PD.repoKind) repos') maybeKind - repoBranchCmd repo = do - t <- PD.repoType repo - brancher <- Data.Map.lookup t branchers - brancherBuildCmd brancher repo +-- | Given a bunch of package ids and their corresponding available +-- 'SourceRepo's, pick a single 'SourceRepo' for each one and clone into +-- new subdirs of the given directory. +-- +clonePackagesFromSourceRepo :: Verbosity + -> FilePath -- ^ destination dir prefix + -> Maybe RepoKind -- ^ preferred 'RepoKind' + -> [(PackageId, [SourceRepo])] + -- ^ the packages and their + -- available 'SourceRepo's + -> IO () +clonePackagesFromSourceRepo verbosity destDirPrefix + preferredRepoKind pkgrepos = do - cmd = listToMaybe (mapMaybe repoBranchCmd repos) + -- Do a bunch of checks and collect the required info + pkgrepos' <- mapM preCloneChecks pkgrepos --- | Branch driver for Bazaar. -branchBzr :: Brancher -branchBzr = Brancher "bzr" $ \repo -> do - src <- PD.repoLocation repo - let args dst = case PD.repoTag repo of - Just tag -> ["branch", src, dst, "-r", "tag:" ++ tag] - Nothing -> ["branch", src, dst] - return $ BranchCmd $ \verbosity dst -> do - notice verbosity ("bzr: branch " ++ show src) - rawSystemExitCode verbosity "bzr" (args dst) + -- Configure the VCS drivers for all the repository types we may need + vcss <- configureVCSs verbosity $ + Map.fromList [ (vcsRepoType vcs, vcs) + | (_, _, vcs, _) <- pkgrepos' ] --- | Branch driver for Darcs. -branchDarcs :: Brancher -branchDarcs = Brancher "darcs" $ \repo -> do - src <- PD.repoLocation repo - let args dst = case PD.repoTag repo of - Just tag -> ["get", src, dst, "-t", tag] - Nothing -> ["get", src, dst] - return $ BranchCmd $ \verbosity dst -> do - notice verbosity ("darcs: get " ++ show src) - rawSystemExitCode verbosity "darcs" (args dst) + -- Now execute all the required commands for each repo + sequence_ + [ cloneSourceRepo verbosity vcs' repo destDir + `catch` \exitcode -> + throwIO (ClonePackageFailedWithExitCode + pkgid repo (programName (vcsProgram vcs)) exitcode) + | (pkgid, repo, vcs, destDir) <- pkgrepos' + , let Just vcs' = Map.lookup (vcsRepoType vcs) vcss + ] --- | Branch driver for Git. -branchGit :: Brancher -branchGit = Brancher "git" $ \repo -> do - src <- PD.repoLocation repo - let postClone verbosity dst = case PD.repoTag repo of - Just t -> do - cwd <- getCurrentDirectory - setCurrentDirectory dst - finally - (rawSystemExitCode verbosity "git" ["checkout", t]) - (setCurrentDirectory cwd) - Nothing -> return ExitSuccess - return $ BranchCmd $ \verbosity dst -> do - notice verbosity ("git: clone " ++ show src) - code <- rawSystemExitCode verbosity "git" (["clone", src, dst] ++ - case PD.repoBranch repo of - Nothing -> [] - Just b -> ["--branch", b]) - case code of - ExitFailure _ -> return code - ExitSuccess -> postClone verbosity dst + where + preCloneChecks :: (PackageId, [SourceRepo]) + -> IO (PackageId, SourceRepo, VCS Program, FilePath) + preCloneChecks (pkgid, repos) = do + repo <- case selectPackageSourceRepo preferredRepoKind repos of + Just repo -> return repo + Nothing | null repos -> throwIO (ClonePackageNoSourceRepos pkgid) + Nothing -> throwIO (ClonePackageNoSourceReposOfKind + pkgid preferredRepoKind) --- | Branch driver for Mercurial. -branchHg :: Brancher -branchHg = Brancher "hg" $ \repo -> do - src <- PD.repoLocation repo - let branchArgs = case PD.repoBranch repo of - Just b -> ["--branch", b] - Nothing -> [] - let tagArgs = case PD.repoTag repo of - Just t -> ["--rev", t] - Nothing -> [] - let args dst = ["clone", src, dst] ++ branchArgs ++ tagArgs - return $ BranchCmd $ \verbosity dst -> do - notice verbosity ("hg: clone " ++ show src) - rawSystemExitCode verbosity "hg" (args dst) + vcs <- case validateSourceRepo repo of + Right (_, _, _, vcs) -> return vcs + Left SourceRepoRepoTypeUnspecified -> + throwIO (ClonePackageNoRepoType pkgid repo) --- | Branch driver for Subversion. -branchSvn :: Brancher -branchSvn = Brancher "svn" $ \repo -> do - src <- PD.repoLocation repo - let args dst = ["checkout", src, dst] - return $ BranchCmd $ \verbosity dst -> do - notice verbosity ("svn: checkout " ++ show src) - rawSystemExitCode verbosity "svn" (args dst) + Left (SourceRepoRepoTypeUnsupported repoType) -> + throwIO (ClonePackageUnsupportedRepoType pkgid repo repoType) + + Left SourceRepoLocationUnspecified -> + throwIO (ClonePackageNoRepoLocation pkgid repo) + + let destDir = destDirPrefix display (packageName pkgid) + destDirExists <- doesDirectoryExist destDir + destFileExists <- doesFileExist destDir + when (destDirExists || destFileExists) $ + throwIO (ClonePackageDestinationExists pkgid destDir destDirExists) + + return (pkgid, repo, vcs, destDir) + diff --git a/Distribution/Client/Haddock.hs b/Distribution/Client/Haddock.hs --- a/Distribution/Client/Haddock.hs +++ b/Distribution/Client/Haddock.hs @@ -40,7 +40,7 @@ -> IO () regenerateHaddockIndex verbosity pkgs progdb index = do (paths, warns) <- haddockPackagePaths pkgs' Nothing - let paths' = [ (interface, html) | (interface, Just html) <- paths] + let paths' = [ (interface, html) | (interface, Just html, _) <- paths] forM_ warns (debug verbosity) (confHaddock, _, _) <- diff --git a/Distribution/Client/Init.hs b/Distribution/Client/Init.hs --- a/Distribution/Client/Init.hs +++ b/Distribution/Client/Init.hs @@ -288,7 +288,7 @@ return $ flags { extraSrc = extraSrcFiles } defaultChangeLog :: FilePath -defaultChangeLog = "ChangeLog.md" +defaultChangeLog = "CHANGELOG.md" -- | Try to guess things to include in the extra-source-files field. -- For now, we just look for things in the root directory named diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -80,7 +80,7 @@ , ConfigFlags(..), configureCommand, filterConfigureFlags , ConfigExFlags(..), InstallFlags(..) ) import Distribution.Client.Config - ( defaultCabalDir, defaultUserInstall ) + ( getCabalDir, defaultUserInstall ) import Distribution.Client.Sandbox.Timestamp ( withUpdateTimestamps ) import Distribution.Client.Sandbox.Types @@ -160,9 +160,9 @@ , withTempDirectory ) import Distribution.Client.Utils ( determineNumJobs, logDirChange, mergeBy, MergeResult(..) - , tryCanonicalizePath ) + , tryCanonicalizePath, ProgressPhase(..), progressMessage ) import Distribution.System - ( Platform, OS(Windows), buildOS ) + ( Platform, OS(Windows), buildOS, buildPlatform ) import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity @@ -858,7 +858,7 @@ storeDetailedBuildReports :: Verbosity -> FilePath -> [(BuildReports.BuildReport, Maybe Repo)] -> IO () storeDetailedBuildReports verbosity logsDir reports = sequence_ - [ do dotCabal <- defaultCabalDir + [ do dotCabal <- getCabalDir let logFileName = display (BuildReports.package report) <.> "log" logFile = logsDir logFileName reportsDir = dotCabal "reports" remoteRepoName remoteRepo @@ -1197,7 +1197,7 @@ -- otherwise. printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO () printBuildResult pkgid uid buildOutcome = case buildOutcome of - (Right _) -> notice verbosity $ "Installed " ++ display pkgid + (Right _) -> progressMessage verbosity ProgressCompleted (display pkgid) (Left _) -> do notice verbosity $ "Failed to install " ++ display pkgid when (verbosity >= normal) $ @@ -1285,6 +1285,9 @@ LocalUnpackedPackage dir -> installPkg (Just dir) + RemoteSourceRepoPackage _repo dir -> + installPkg (Just dir) + LocalTarballPackage tarballPath -> installLocalTarballPackage verbosity pkgid tarballPath distPref installPkg @@ -1297,7 +1300,6 @@ installLocalTarballPackage verbosity pkgid tarballPath distPref installPkg - installLocalTarballPackage :: Verbosity -> PackageIdentifier -> FilePath -> FilePath @@ -1396,14 +1398,12 @@ logDirChange (maybe (const (return ())) appendFile mLogPath) workingDir $ do -- Configure phase onFailure ConfigureFailed $ do - when (numJobs > 1) $ notice verbosity $ - "Configuring " ++ display pkgid ++ "..." + noticeProgress ProgressStarting setup configureCommand configureFlags mLogPath -- Build phase onFailure BuildFailed $ do - when (numJobs > 1) $ notice verbosity $ - "Building " ++ display pkgid ++ "..." + noticeProgress ProgressBuilding setup buildCommand' buildFlags mLogPath -- Doc generation phase @@ -1450,6 +1450,12 @@ uid = installedUnitId rpkg cinfo = compilerInfo comp buildCommand' = buildCommand progdb + dispname = display pkgid + isParallelBuild = numJobs >= 2 + + noticeProgress phase = when isParallelBuild $ + progressMessage verbosity phase dispname + buildFlags _ = emptyBuildFlags { buildDistPref = configDistPref configFlags, buildVerbosity = toFlag verbosity' @@ -1551,7 +1557,7 @@ scriptOptions { useLoggingHandle = logFileHandle , useWorkingDir = workingDir } (Just pkg) - cmd flags []) + cmd flags (const [])) -- helper @@ -1593,7 +1599,7 @@ (CompilerId compFlavor _) = compilerInfoId cinfo exeInstallPaths defaultDirs = - [ InstallDirs.bindir absoluteDirs exeName <.> exeExtension + [ InstallDirs.bindir absoluteDirs exeName <.> exeExtension buildPlatform | exe <- PackageDescription.executables pkg , PackageDescription.buildable (PackageDescription.buildInfo exe) , let exeName = prefix ++ display (PackageDescription.exeName exe) ++ suffix diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs --- a/Distribution/Client/InstallPlan.hs +++ b/Distribution/Client/InstallPlan.hs @@ -62,6 +62,7 @@ showInstallPlan, -- * Graph-like operations + dependencyClosure, reverseTopologicalOrder, reverseDependencyClosure, ) where @@ -402,6 +403,15 @@ -> [GenericPlanPackage ipkg srcpkg] reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan) + +-- | Return the packages in the plan that are direct or indirect dependencies of +-- the given packages. +-- +dependencyClosure :: GenericInstallPlan ipkg srcpkg + -> [UnitId] + -> [GenericPlanPackage ipkg srcpkg] +dependencyClosure plan = fromMaybe [] + . Graph.closure (planGraph plan) -- | Return the packages in the plan that depend directly or indirectly on the -- given packages. diff --git a/Distribution/Client/List.hs b/Distribution/Client/List.hs --- a/Distribution/Client/List.hs +++ b/Distribution/Client/List.hs @@ -470,7 +470,7 @@ source, dependencies = combine (map (SourceDependency . simplifyDependency) - . Source.buildDepends) source + . Source.allBuildDepends) source (map InstalledDependency . Installed.depends) installed, haddockHtml = fromMaybe "" . join . fmap (listToMaybe . Installed.haddockHTMLs) diff --git a/Distribution/Client/Outdated.hs b/Distribution/Client/Outdated.hs --- a/Distribution/Client/Outdated.hs +++ b/Distribution/Client/Outdated.hs @@ -27,12 +27,12 @@ import Distribution.Solver.Types.PackageIndex import Distribution.Client.Sandbox.PackageEnvironment -import Distribution.Package (PackageName - ,packageVersion) -import Distribution.PackageDescription (buildDepends) +import Distribution.Package (PackageName, packageVersion) +import Distribution.PackageDescription (allBuildDepends) import Distribution.PackageDescription.Configuration (finalizePD) import Distribution.Simple.Compiler (Compiler, compilerInfo) -import Distribution.Simple.Setup (fromFlagOrDefault) +import Distribution.Simple.Setup + (fromFlagOrDefault, flagToMaybe) import Distribution.Simple.Utils (die', notice, debug, tryFindPackageDesc) import Distribution.System (Platform) @@ -61,6 +61,8 @@ let freezeFile = fromFlagOrDefault False (outdatedFreezeFile outdatedFlags) newFreezeFile = fromFlagOrDefault False (outdatedNewFreezeFile outdatedFlags) + mprojectFile = flagToMaybe + (outdatedProjectFile outdatedFlags) simpleOutput = fromFlagOrDefault False (outdatedSimpleOutput outdatedFlags) quiet = fromFlagOrDefault False (outdatedQuiet outdatedFlags) @@ -76,13 +78,17 @@ in \pkgname -> pkgname `S.member` minorSet verbosity = if quiet then silent else verbosity0 + when (not newFreezeFile && isJust mprojectFile) $ + die' verbosity $ + "--project-file must only be used with --new-freeze-file." + sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext let pkgIndex = packageIndex sourcePkgDb deps <- if freezeFile then depsFromFreezeFile verbosity else if newFreezeFile - then depsFromNewFreezeFile verbosity - else depsFromPkgDesc verbosity comp platform + then depsFromNewFreezeFile verbosity mprojectFile + else depsFromPkgDesc verbosity comp platform debug verbosity $ "Dependencies loaded: " ++ (intercalate ", " $ map display deps) let outdatedDeps = listOutdated deps pkgIndex @@ -124,11 +130,10 @@ return deps -- | Read the list of dependencies from the new-style freeze file. -depsFromNewFreezeFile :: Verbosity -> IO [Dependency] -depsFromNewFreezeFile verbosity = do +depsFromNewFreezeFile :: Verbosity -> Maybe FilePath -> IO [Dependency] +depsFromNewFreezeFile verbosity mprojectFile = do projectRoot <- either throwIO return =<< - findProjectRoot Nothing - {- TODO: Support '--project-file': -} Nothing + findProjectRoot Nothing mprojectFile let distDirLayout = defaultDistDirLayout projectRoot {- TODO: Support dist dir override -} Nothing projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ @@ -136,8 +141,8 @@ let ucnstrs = map fst . projectConfigConstraints . projectConfigShared $ projectConfig deps = userConstraintsToDependencies ucnstrs - debug verbosity - "Reading the list of dependencies from the new-style freeze file" + debug verbosity $ + "Reading the list of dependencies from the new-style freeze file " ++ distProjectFile distDirLayout "freeze" return deps -- | Read the list of dependencies from the package description. @@ -152,7 +157,7 @@ case epd of Left _ -> die' verbosity "finalizePD failed" Right (pd, _) -> do - let bd = buildDepends pd + let bd = allBuildDepends pd debug verbosity "Reading the list of dependencies from the package description" return bd diff --git a/Distribution/Client/PackageHash.hs b/Distribution/Client/PackageHash.hs --- a/Distribution/Client/PackageHash.hs +++ b/Distribution/Client/PackageHash.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-} -- | Functions to calculate nix-style hashes for package ids. -- @@ -135,22 +135,22 @@ | otherwise = take (n-1) s ++ "_" -- | On macOS we shorten the name very aggressively. The mach-o linker on --- macOS has a limited load command size, to which the name of the lirbary +-- macOS has a limited load command size, to which the name of the library -- as well as its relative path (\@rpath) entry count. To circumvent this, -- on macOS the libraries are not stored as -- @store//libHS.dylib@ --- where libraryname contains the librarys name, version and abi hash, but in +-- where libraryname contains the libraries name, version and abi hash, but in -- @store/lib/libHS.dylib@ -- where the very short library name drops all vowels from the package name, -- and truncates the hash to 4 bytes. -- --- We therefore only need one \@rpath entry to @store/lib@ instead of one +-- We therefore we only need one \@rpath entry to @store/lib@ instead of one -- \@rpath entry for each library. And the reduced library name saves some -- additional space. -- -- This however has two major drawbacks: --- 1) Packages can easier collide due to the shortened hash. --- 2) The lirbaries are *not* prefix relocateable anymore as they all end up +-- 1) Packages can collide more easily due to the shortened hash. +-- 2) The libraries are *not* prefix relocatable anymore as they all end up -- in the same @store/lib@ folder. -- -- The ultimate solution would have to include generating proxy dynamic @@ -211,11 +211,25 @@ pkgHashExtraFrameworkDirs :: [FilePath], pkgHashExtraIncludeDirs :: [FilePath], pkgHashProgPrefix :: Maybe PathTemplate, - pkgHashProgSuffix :: Maybe PathTemplate + pkgHashProgSuffix :: Maybe PathTemplate, + -- Haddock options + pkgHashDocumentation :: Bool, + pkgHashHaddockHoogle :: Bool, + pkgHashHaddockHtml :: Bool, + pkgHashHaddockHtmlLocation :: Maybe String, + pkgHashHaddockForeignLibs :: Bool, + pkgHashHaddockExecutables :: Bool, + pkgHashHaddockTestSuites :: Bool, + pkgHashHaddockBenchmarks :: Bool, + pkgHashHaddockInternal :: Bool, + pkgHashHaddockCss :: Maybe FilePath, + pkgHashHaddockLinkedSource :: Bool, + pkgHashHaddockQuickJump :: Bool, + pkgHashHaddockContents :: Maybe PathTemplate + -- TODO: [required eventually] pkgHashToolsVersions ? -- TODO: [required eventually] pkgHashToolsExtraOptions ? --- TODO: [research required] and what about docs? } deriving Show @@ -248,7 +262,7 @@ -- the default value for that feature. So if we avoid adding entries with -- the default value then most of the time adding new features will not -- change the hashes of existing packages and so fewer packages will need - -- to be rebuilt. + -- to be rebuilt. --TODO: [nice to have] ultimately we probably want to put this config info -- into the ghc-pkg db. At that point this should probably be changed to @@ -276,8 +290,8 @@ , opt "ghci-lib" False display pkgHashGHCiLib , opt "prof-lib" False display pkgHashProfLib , opt "prof-exe" False display pkgHashProfExe - , opt "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail - , opt "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail + , opt "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail + , opt "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail , opt "hpc" False display pkgHashCoverage , opt "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization , opt "split-objs" False display pkgHashSplitObjs @@ -290,6 +304,21 @@ , opt "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs , opt "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix , opt "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix + + , opt "documentation" False display pkgHashDocumentation + , opt "haddock-hoogle" False display pkgHashHaddockHoogle + , opt "haddock-html" False display pkgHashHaddockHtml + , opt "haddock-html-location" Nothing (fromMaybe "") pkgHashHaddockHtmlLocation + , opt "haddock-foreign-libraries" False display pkgHashHaddockForeignLibs + , opt "haddock-executables" False display pkgHashHaddockExecutables + , opt "haddock-tests" False display pkgHashHaddockTestSuites + , opt "haddock-benchmarks" False display pkgHashHaddockBenchmarks + , opt "haddock-internal" False display pkgHashHaddockInternal + , opt "haddock-css" Nothing (fromMaybe "") pkgHashHaddockCss + , opt "haddock-hyperlink-source" False display pkgHashHaddockLinkedSource + , opt "haddock-quickjump" False display pkgHashHaddockQuickJump + , opt "haddock-contents-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockContents + ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs where entry key format value = Just (key ++ ": " ++ format value) @@ -315,7 +344,7 @@ -- package ids. newtype HashValue = HashValue BS.ByteString - deriving (Eq, Show, Typeable) + deriving (Eq, Generic, Show, Typeable) instance Binary HashValue where put (HashValue digest) = put digest @@ -354,4 +383,3 @@ (hash, trailing) | not (BS.null hash) && BS.null trailing -> HashValue hash _ -> error "hashFromTUF: cannot decode base16 hash" - diff --git a/Distribution/Client/PackageUtils.hs b/Distribution/Client/PackageUtils.hs --- a/Distribution/Client/PackageUtils.hs +++ b/Distribution/Client/PackageUtils.hs @@ -16,18 +16,20 @@ import Distribution.Package ( packageVersion, packageName ) +import Distribution.Types.ComponentRequestedSpec + ( ComponentRequestedSpec ) import Distribution.Types.Dependency import Distribution.Types.UnqualComponentName import Distribution.PackageDescription - ( PackageDescription(..), libName ) + ( PackageDescription(..), libName, enabledBuildDepends ) import Distribution.Version ( withinRange, isAnyVersion ) -- | The list of dependencies that refer to external packages -- rather than internal package components. -- -externalBuildDepends :: PackageDescription -> [Dependency] -externalBuildDepends pkg = filter (not . internal) (buildDepends pkg) +externalBuildDepends :: PackageDescription -> ComponentRequestedSpec -> [Dependency] +externalBuildDepends pkg spec = filter (not . internal) (enabledBuildDepends pkg spec) where -- True if this dependency is an internal one (depends on a library -- defined in the same package). diff --git a/Distribution/Client/ProjectBuilding.hs b/Distribution/Client/ProjectBuilding.hs --- a/Distribution/Client/ProjectBuilding.hs +++ b/Distribution/Client/ProjectBuilding.hs @@ -60,11 +60,15 @@ import Distribution.Client.FetchUtils import Distribution.Client.GlobalFlags (RepoContext) import qualified Distribution.Client.Tar as Tar -import Distribution.Client.Setup (filterConfigureFlags) +import Distribution.Client.Setup + ( filterConfigureFlags, filterHaddockArgs + , filterHaddockFlags ) import Distribution.Client.SourceFiles import Distribution.Client.SrcDist (allPackageSourceFiles) -import Distribution.Client.Utils (removeExistingFile) +import Distribution.Client.Utils + ( ProgressPhase(..), progressMessage, removeExistingFile ) +import Distribution.Compat.Lens import Distribution.Package hiding (InstalledPackageId, installedPackageId) import qualified Distribution.PackageDescription as PD import Distribution.InstalledPackageInfo (InstalledPackageInfo) @@ -72,15 +76,16 @@ import Distribution.Simple.BuildPaths (haddockDirName) import qualified Distribution.Simple.InstallDirs as InstallDirs import Distribution.Types.BuildType +import Distribution.Types.PackageDescription.Lens (componentModules) import Distribution.Simple.Program import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Command (CommandUI) import qualified Distribution.Simple.Register as Cabal -import Distribution.Simple.LocalBuildInfo (ComponentName) +import Distribution.Simple.LocalBuildInfo (ComponentName(..)) import Distribution.Simple.Compiler ( Compiler, compilerId, PackageDB(..) ) -import Distribution.Simple.Utils hiding (matchFileGlob) +import Distribution.Simple.Utils import Distribution.Version import Distribution.Verbosity import Distribution.Text @@ -96,6 +101,7 @@ import Control.Monad import Control.Exception +import Data.Function (on) import Data.Maybe import System.FilePath @@ -203,6 +209,11 @@ -- artifacts under the shared dist directory. dryRunLocalPkg pkg depsBuildStatus srcdir + Just (RemoteSourceRepoPackage _repo srcdir) -> + -- At this point, source repos are essentially the same as local + -- dirs, since we've already download them. + dryRunLocalPkg pkg depsBuildStatus srcdir + -- The three tarball cases are handled the same as each other, -- though depending on the build style. Just (LocalTarballPackage tarball) -> @@ -249,7 +260,7 @@ return (BuildStatusUpToDate buildResult) where packageFileMonitor = - newPackageFileMonitor distDirLayout (elabDistDirParams shared pkg) + newPackageFileMonitor shared distDirLayout (elabDistDirParams shared pkg) -- | A specialised traversal over the packages in an install plan. @@ -328,11 +339,20 @@ -- type BuildResultMisc = (DocsResult, TestsResult) -newPackageFileMonitor :: DistDirLayout -> DistDirParams -> PackageFileMonitor -newPackageFileMonitor DistDirLayout{distPackageCacheFile} dparams = +newPackageFileMonitor :: ElaboratedSharedConfig + -> DistDirLayout + -> DistDirParams + -> PackageFileMonitor +newPackageFileMonitor shared + DistDirLayout{distPackageCacheFile} + dparams = PackageFileMonitor { pkgFileMonitorConfig = - newFileMonitor (distPackageCacheFile dparams "config"), + FileMonitor { + fileMonitorCacheFile = distPackageCacheFile dparams "config", + fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared, + fileMonitorCheckIfOnlyValueChanged = False + }, pkgFileMonitorBuild = FileMonitor { @@ -366,11 +386,12 @@ -- elab_config = elab { - elabBuildTargets = [], - elabTestTargets = [], + elabBuildTargets = [], + elabTestTargets = [], elabBenchTargets = [], - elabReplTarget = Nothing, - elabBuildHaddocks = False + elabReplTarget = Nothing, + elabHaddockTargets = [], + elabBuildHaddocks = False } -- The second part is the value used to guard the build step. So this is @@ -919,32 +940,26 @@ --TODO: [required feature] docs and tests --TODO: [required feature] sudo re-exec - let dispname = case elabPkgOrComp pkg of - ElabPackage _ -> display pkgid - ++ " (all, legacy fallback)" - ElabComponent comp -> display pkgid - ++ " (" ++ maybe "custom" display (compComponentName comp) ++ ")" - -- Configure phase - when isParallelBuild $ - notice verbosity $ "Configuring " ++ dispname ++ "..." + noticeProgress ProgressStarting + annotateFailure mlogFile ConfigureFailed $ setup' configureCommand configureFlags configureArgs -- Build phase - when isParallelBuild $ - notice verbosity $ "Building " ++ dispname ++ "..." + noticeProgress ProgressBuilding + annotateFailure mlogFile BuildFailed $ setup buildCommand buildFlags -- Haddock phase whenHaddock $ do - when isParallelBuild $ - notice verbosity $ "Generating " ++ dispname ++ " documentation..." + noticeProgress ProgressHaddock annotateFailureNoLog HaddocksFailed $ setup haddockCommand haddockFlags -- Install phase + noticeProgress ProgressInstalling annotateFailure mlogFile InstallFailed $ do let copyPkgFiles tmpDir = do @@ -1017,6 +1032,8 @@ let docsResult = DocsNotTried testsResult = TestsNotTried + noticeProgress ProgressCompleted + return BuildResult { buildResultDocs = docsResult, buildResultTests = testsResult, @@ -1028,17 +1045,26 @@ uid = installedUnitId rpkg compid = compilerId compiler + dispname = case elabPkgOrComp pkg of + ElabPackage _ -> display pkgid + ++ " (all, legacy fallback)" + ElabComponent comp -> display pkgid + ++ " (" ++ maybe "custom" display (compComponentName comp) ++ ")" + + noticeProgress phase = when isParallelBuild $ + progressMessage verbosity phase dispname + isParallelBuild = buildSettingNumJobs >= 2 whenHaddock action - | elabBuildHaddocks pkg = action - | otherwise = return () + | hasValidHaddockTargets pkg = action + | otherwise = return () configureCommand = Cabal.configureCommand defaultProgramDb configureFlags v = flip filterConfigureFlags v $ setupHsConfigureFlags rpkg pkgshared verbosity builddir - configureArgs = setupHsConfigureArgs pkg + configureArgs _ = setupHsConfigureArgs pkg buildCommand = Cabal.buildCommand defaultProgramDb buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir @@ -1064,9 +1090,9 @@ isParallelBuild cacheLock setup :: CommandUI flags -> (Version -> flags) -> IO () - setup cmd flags = setup' cmd flags [] + setup cmd flags = setup' cmd flags (const []) - setup' :: CommandUI flags -> (Version -> flags) -> [String] -> IO () + setup' :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) -> IO () setup' cmd flags args = withLogging $ \mLogFileHandle -> setupWrapper @@ -1097,6 +1123,27 @@ Just logFile -> withFile logFile AppendMode (action . Just) +hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool +hasValidHaddockTargets ElaboratedConfiguredPackage{..} + | not elabBuildHaddocks = False + | otherwise = any componentHasHaddocks components + where + components = elabBuildTargets ++ elabTestTargets ++ elabBenchTargets + ++ maybeToList elabReplTarget ++ elabHaddockTargets + + componentHasHaddocks :: ComponentTarget -> Bool + componentHasHaddocks (ComponentTarget name _) = + case name of + CLibName -> hasHaddocks + CSubLibName _ -> elabHaddockInternal && hasHaddocks + CFLibName _ -> elabHaddockForeignLibs && hasHaddocks + CExeName _ -> elabHaddockExecutables && hasHaddocks + CTestName _ -> elabHaddockTestSuites && hasHaddocks + CBenchName _ -> elabHaddockBenchmarks && hasHaddocks + where + hasHaddocks = not (null (elabPkgDescription ^. componentModules name)) + + buildInplaceUnpackedPackage :: Verbosity -> DistDirLayout -> BuildTimeSettings -> Lock -> Lock @@ -1220,7 +1267,7 @@ -- Haddock phase whenHaddock $ annotateFailureNoLog HaddocksFailed $ do - setup haddockCommand haddockFlags [] + setup haddockCommand haddockFlags haddockArgs let haddockTarget = elabHaddockForHackage pkg when (haddockTarget == Cabal.ForHackage) $ do let dest = distDirectory name <.> "tar.gz" @@ -1241,7 +1288,7 @@ isParallelBuild = buildSettingNumJobs >= 2 - packageFileMonitor = newPackageFileMonitor distDirLayout dparams + packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams whenReConfigure action = case buildStatus of BuildStatusConfigure _ -> action @@ -1267,8 +1314,8 @@ | otherwise = action whenHaddock action - | elabBuildHaddocks pkg = action - | otherwise = return () + | hasValidHaddockTargets pkg = action + | otherwise = return () whenReRegister action = case buildStatus of @@ -1282,45 +1329,48 @@ configureFlags v = flip filterConfigureFlags v $ setupHsConfigureFlags rpkg pkgshared verbosity builddir - configureArgs = setupHsConfigureArgs pkg + configureArgs _ = setupHsConfigureArgs pkg buildCommand = Cabal.buildCommand defaultProgramDb buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir - buildArgs = setupHsBuildArgs pkg + buildArgs _ = setupHsBuildArgs pkg testCommand = Cabal.testCommand -- defaultProgramDb testFlags _ = setupHsTestFlags pkg pkgshared verbosity builddir - testArgs = setupHsTestArgs pkg + testArgs _ = setupHsTestArgs pkg benchCommand = Cabal.benchmarkCommand benchFlags _ = setupHsBenchFlags pkg pkgshared verbosity builddir - benchArgs = setupHsBenchArgs pkg + benchArgs _ = setupHsBenchArgs pkg replCommand = Cabal.replCommand defaultProgramDb replFlags _ = setupHsReplFlags pkg pkgshared verbosity builddir - replArgs = setupHsReplArgs pkg + replArgs _ = setupHsReplArgs pkg haddockCommand = Cabal.haddockCommand - haddockFlags _ = setupHsHaddockFlags pkg pkgshared + haddockFlags v = flip filterHaddockFlags v $ + setupHsHaddockFlags pkg pkgshared verbosity builddir + haddockArgs v = flip filterHaddockArgs v $ + setupHsHaddockArgs pkg scriptOptions = setupHsScriptOptions rpkg plan pkgshared srcdir builddir isParallelBuild cacheLock setupInteractive :: CommandUI flags - -> (Version -> flags) -> [String] -> IO () + -> (Version -> flags) -> (Version -> [String]) -> IO () setupInteractive cmd flags args = setupWrapper verbosity scriptOptions { isInteractive = True } (Just (elabPkgDescription pkg)) cmd flags args - setup :: CommandUI flags -> (Version -> flags) -> [String] -> IO () + setup :: CommandUI flags -> (Version -> flags) -> (Version -> [String]) -> IO () setup cmd flags args = setupWrapper verbosity scriptOptions @@ -1335,7 +1385,7 @@ pkg pkgshared verbosity builddir pkgConfDest - setup Cabal.registerCommand registerFlags [] + setup Cabal.registerCommand registerFlags (const []) withTempInstalledPackageInfoFile :: Verbosity -> FilePath -> (FilePath -> IO ()) @@ -1395,4 +1445,3 @@ where handler :: Exception e => e -> IO a handler = throwIO . BuildFailure mlogFile . annotate . toException - diff --git a/Distribution/Client/ProjectBuilding/Types.hs b/Distribution/Client/ProjectBuilding/Types.hs --- a/Distribution/Client/ProjectBuilding/Types.hs +++ b/Distribution/Client/ProjectBuilding/Types.hs @@ -204,4 +204,3 @@ | BenchFailed SomeException | InstallFailed SomeException deriving Show - diff --git a/Distribution/Client/ProjectConfig.hs b/Distribution/Client/ProjectConfig.hs --- a/Distribution/Client/ProjectConfig.hs +++ b/Distribution/Client/ProjectConfig.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, DeriveDataTypeable #-} +{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, DeriveDataTypeable, LambdaCase #-} -- | Handling project configuration. -- @@ -22,6 +22,7 @@ readProjectConfig, readGlobalConfig, readProjectLocalFreezeConfig, + withProjectOrGlobalConfig, writeProjectLocalExtraConfig, writeProjectLocalFreezeConfig, writeProjectConfigFile, @@ -33,7 +34,7 @@ BadPackageLocation(..), BadPackageLocationMatch(..), findProjectPackages, - readSourcePackage, + fetchAndReadSourcePackages, -- * Resolving configuration lookupLocalPackageConfig, @@ -57,6 +58,9 @@ import Distribution.Client.RebuildMonad import Distribution.Client.Glob ( isTrivialFilePathGlob ) +import Distribution.Client.VCS + ( validateSourceRepos, SourceRepoProblem(..) + , VCS(..), knownVCSs, configureVCS, syncSourceRepos ) import Distribution.Client.Types import Distribution.Client.DistDirLayout @@ -67,6 +71,9 @@ ( ReportLevel(..) ) import Distribution.Client.Config ( loadConfig, getConfigFilePath ) +import Distribution.Client.HttpUtils + ( HttpTransport, configureTransport, transportCheckHttps + , downloadURI ) import Distribution.Solver.Types.SourcePackage import Distribution.Solver.Types.Settings @@ -78,10 +85,16 @@ import Distribution.Types.Dependency import Distribution.System ( Platform ) -import Distribution.PackageDescription - ( SourceRepo(..) ) +import Distribution.Types.GenericPackageDescription + ( GenericPackageDescription ) import Distribution.PackageDescription.Parsec - ( readGenericPackageDescription ) + ( parseGenericPackageDescription ) +import Distribution.Parsec.ParseResult + ( runParseResult ) +import Distribution.Parsec.Common as NewParser + ( PError, PWarning, showPWarning ) +import Distribution.Types.SourceRepo + ( SourceRepo(..), RepoType(..), ) import Distribution.Simple.Compiler ( Compiler, compilerInfo ) import Distribution.Simple.Program @@ -95,27 +108,42 @@ ( PathTemplate, fromPathTemplate , toPathTemplate, substPathTemplate, initialPathTemplateEnv ) import Distribution.Simple.Utils - ( die', warn ) + ( die', warn, notice, info, createDirectoryIfMissingVerbose ) import Distribution.Client.Utils ( determineNumJobs ) import Distribution.Utils.NubList ( fromNubList ) import Distribution.Verbosity ( Verbosity, modifyVerbosity, verbose ) +import Distribution.Version + ( Version ) import Distribution.Text -import Distribution.ParseUtils +import Distribution.ParseUtils as OldParser ( ParseResult(..), locatedErrorMsg, showPWarning ) +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Archive.Tar.Entry as Tar +import qualified Distribution.Client.Tar as Tar +import qualified Distribution.Client.GZipUtils as GZipUtils + import Control.Monad import Control.Monad.Trans (liftIO) import Control.Exception import Data.Either +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Hashable as Hashable +import Numeric (showHex) + import System.FilePath hiding (combine) +import System.IO + ( withBinaryFile, IOMode(ReadMode) ) import System.Directory -import Network.URI (URI(..), URIAuth(..), parseAbsoluteURI) +import Network.URI + ( URI(..), URIAuth(..), parseAbsoluteURI, uriToString ) ---------------------------------------- @@ -411,45 +439,63 @@ renderBadProjectRoot (BadProjectRootExplicitFile projectFile) = "The given project file '" ++ projectFile ++ "' does not exist." +withProjectOrGlobalConfig :: Verbosity + -> Flag FilePath + -> IO a + -> (ProjectConfig -> IO a) + -> IO a +withProjectOrGlobalConfig verbosity globalConfigFlag with without = do + globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag + let + res' = catch with + $ \case + (BadPackageLocations prov locs) + | prov == Set.singleton Implicit + , let + isGlobErr (BadLocGlobEmptyMatch _) = True + isGlobErr _ = False + , any isGlobErr locs -> + without globalConfig + err -> throwIO err + + catch res' + $ \case + (BadProjectRootExplicitFile "") -> without globalConfig + err -> throwIO err + -- | Read all the config relevant for a project. This includes the project -- file if any, plus other global config. -- -readProjectConfig :: Verbosity -> Flag FilePath -> DistDirLayout -> Rebuild ProjectConfig +readProjectConfig :: Verbosity + -> Flag FilePath + -> DistDirLayout + -> Rebuild ProjectConfig readProjectConfig verbosity configFileFlag distDirLayout = do - global <- readGlobalConfig verbosity configFileFlag - local <- readProjectLocalConfig verbosity distDirLayout - freeze <- readProjectLocalFreezeConfig verbosity distDirLayout - extra <- readProjectLocalExtraConfig verbosity distDirLayout + global <- readGlobalConfig verbosity configFileFlag + local <- readProjectLocalConfigOrDefault verbosity distDirLayout + freeze <- readProjectLocalFreezeConfig verbosity distDirLayout + extra <- readProjectLocalExtraConfig verbosity distDirLayout return (global <> local <> freeze <> extra) -- | Reads an explicit @cabal.project@ file in the given project root dir, -- or returns the default project config for an implicitly defined project. -- -readProjectLocalConfig :: Verbosity -> DistDirLayout -> Rebuild ProjectConfig -readProjectLocalConfig verbosity DistDirLayout{distProjectFile} = do +readProjectLocalConfigOrDefault :: Verbosity + -> DistDirLayout + -> Rebuild ProjectConfig +readProjectLocalConfigOrDefault verbosity distDirLayout = do usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile if usesExplicitProjectRoot then do - monitorFiles [monitorFileHashed projectFile] - addProjectFileProvenance <$> liftIO readProjectFile + readProjectFile verbosity distDirLayout "" "project file" else do monitorFiles [monitorNonExistentFile projectFile] return defaultImplicitProjectConfig where - projectFile = distProjectFile "" - readProjectFile = - reportParseResult verbosity "project file" projectFile - . parseProjectConfig - =<< readFile projectFile - - addProjectFileProvenance config = - config { - projectConfigProvenance = - Set.insert (Explicit projectFile) (projectConfigProvenance config) - } + projectFile = distProjectFile distDirLayout "" defaultImplicitProjectConfig :: ProjectConfig defaultImplicitProjectConfig = @@ -470,7 +516,7 @@ readProjectLocalExtraConfig :: Verbosity -> DistDirLayout -> Rebuild ProjectConfig readProjectLocalExtraConfig verbosity distDirLayout = - readProjectExtensionFile verbosity distDirLayout "local" + readProjectFile verbosity distDirLayout "local" "project local configuration file" -- | Reads a @cabal.project.freeze@ file in the given project root dir, @@ -480,19 +526,22 @@ readProjectLocalFreezeConfig :: Verbosity -> DistDirLayout -> Rebuild ProjectConfig readProjectLocalFreezeConfig verbosity distDirLayout = - readProjectExtensionFile verbosity distDirLayout "freeze" + readProjectFile verbosity distDirLayout "freeze" "project freeze file" -- | Reads a named config file in the given project root dir, or returns empty. -- -readProjectExtensionFile :: Verbosity -> DistDirLayout -> String -> FilePath - -> Rebuild ProjectConfig -readProjectExtensionFile verbosity DistDirLayout{distProjectFile} +readProjectFile :: Verbosity + -> DistDirLayout + -> String + -> String + -> Rebuild ProjectConfig +readProjectFile verbosity DistDirLayout{distProjectFile} extensionName extensionDescription = do exists <- liftIO $ doesFileExist extensionFile if exists then do monitorFiles [monitorFileHashed extensionFile] - liftIO readExtensionFile + addProjectFileProvenance <$> liftIO readExtensionFile else do monitorFiles [monitorNonExistentFile extensionFile] return mempty where @@ -503,7 +552,13 @@ . parseProjectConfig =<< readFile extensionFile + addProjectFileProvenance config = + config { + projectConfigProvenance = + Set.insert (Explicit extensionFile) (projectConfigProvenance config) + } + -- | Parse the 'ProjectConfig' format. -- -- For the moment this is implemented in terms of parsers for legacy @@ -558,7 +613,7 @@ reportParseResult :: Verbosity -> String -> FilePath -> ParseResult a -> IO a reportParseResult verbosity _filetype filename (ParseOk warnings x) = do unless (null warnings) $ - let msg = unlines (map (showPWarning filename) warnings) + let msg = unlines (map (OldParser.showPWarning filename) warnings) in warn verbosity msg return x reportParseResult verbosity filetype filename (ParseFailed err) = @@ -568,7 +623,7 @@ --------------------------------------------- --- Reading packages in the project +-- Finding packages in the project -- -- | The location of a package as part of a project. Local file paths are @@ -885,35 +940,411 @@ Just x -> return (Just x) --- | Read the @.cabal@ file of the given package. +------------------------------------------------- +-- Fetching and reading packages in the project -- + +-- | Read the @.cabal@ files for a set of packages. For remote tarballs and +-- VCS source repos this also fetches them if needed. +-- -- Note here is where we convert from project-root relative paths to absolute -- paths. -- -readSourcePackage :: Verbosity -> ProjectPackageLocation - -> Rebuild (PackageSpecifier UnresolvedSourcePackage) -readSourcePackage verbosity (ProjectPackageLocalCabalFile cabalFile) = - readSourcePackage verbosity (ProjectPackageLocalDirectory dir cabalFile) +fetchAndReadSourcePackages + :: Verbosity + -> DistDirLayout + -> ProjectConfigShared + -> ProjectConfigBuildOnly + -> [ProjectPackageLocation] + -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] +fetchAndReadSourcePackages verbosity distDirLayout + projectConfigShared + projectConfigBuildOnly + pkgLocations = do + + pkgsLocalDirectory <- + sequence + [ readSourcePackageLocalDirectory verbosity dir cabalFile + | location <- pkgLocations + , (dir, cabalFile) <- projectPackageLocal location ] + + pkgsLocalTarball <- + sequence + [ readSourcePackageLocalTarball verbosity path + | ProjectPackageLocalTarball path <- pkgLocations ] + + pkgsRemoteTarball <- do + getTransport <- delayInitSharedResource $ + configureTransport verbosity progPathExtra + preferredHttpTransport + sequence + [ fetchAndReadSourcePackageRemoteTarball verbosity distDirLayout + getTransport uri + | ProjectPackageRemoteTarball uri <- pkgLocations ] + + pkgsRemoteRepo <- + syncAndReadSourcePackagesRemoteRepos + verbosity distDirLayout + projectConfigShared + [ repo | ProjectPackageRemoteRepo repo <- pkgLocations ] + + let pkgsNamed = + [ NamedPackage pkgname [PackagePropertyVersion verrange] + | ProjectPackageNamed (Dependency pkgname verrange) <- pkgLocations ] + + return $ concat + [ pkgsLocalDirectory + , pkgsLocalTarball + , pkgsRemoteTarball + , pkgsRemoteRepo + , pkgsNamed + ] where - dir = takeDirectory cabalFile + projectPackageLocal (ProjectPackageLocalDirectory dir file) = [(dir, file)] + projectPackageLocal (ProjectPackageLocalCabalFile file) = [(dir, file)] + where dir = takeDirectory file + projectPackageLocal _ = [] -readSourcePackage verbosity (ProjectPackageLocalDirectory dir cabalFile) = do + progPathExtra = fromNubList (projectConfigProgPathExtra projectConfigShared) + preferredHttpTransport = + flagToMaybe (projectConfigHttpTransport projectConfigBuildOnly) + +-- | A helper for 'fetchAndReadSourcePackages' to handle the case of +-- 'ProjectPackageLocalDirectory' and 'ProjectPackageLocalCabalFile'. +-- We simply read the @.cabal@ file. +-- +readSourcePackageLocalDirectory + :: Verbosity + -> FilePath -- ^ The package directory + -> FilePath -- ^ The package @.cabal@ file + -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) +readSourcePackageLocalDirectory verbosity dir cabalFile = do monitorFiles [monitorFileHashed cabalFile] root <- askRoot - pkgdesc <- liftIO $ readGenericPackageDescription verbosity (root cabalFile) - return $ SpecificSourcePackage SourcePackage { - packageInfoId = packageId pkgdesc, - packageDescription = pkgdesc, - packageSource = LocalUnpackedPackage (root dir), + let location = LocalUnpackedPackage (root dir) + liftIO $ fmap (mkSpecificSourcePackage location) + . readSourcePackageCabalFile verbosity cabalFile + =<< BS.readFile (root cabalFile) + + +-- | A helper for 'fetchAndReadSourcePackages' to handle the case of +-- 'ProjectPackageLocalTarball'. We scan through the @.tar.gz@ file to find +-- the @.cabal@ file and read that. +-- +readSourcePackageLocalTarball + :: Verbosity + -> FilePath + -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) +readSourcePackageLocalTarball verbosity tarballFile = do + monitorFiles [monitorFile tarballFile] + root <- askRoot + let location = LocalTarballPackage (root tarballFile) + liftIO $ fmap (mkSpecificSourcePackage location) + . uncurry (readSourcePackageCabalFile verbosity) + =<< extractTarballPackageCabalFile (root tarballFile) + + +-- | A helper for 'fetchAndReadSourcePackages' to handle the case of +-- 'ProjectPackageRemoteTarball'. We download the tarball to the dist src dir +-- and after that handle it like the local tarball case. +-- +fetchAndReadSourcePackageRemoteTarball + :: Verbosity + -> DistDirLayout + -> Rebuild HttpTransport + -> URI + -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) +fetchAndReadSourcePackageRemoteTarball verbosity + DistDirLayout { + distDownloadSrcDirectory + } + getTransport + tarballUri = + -- The tarball download is expensive so we use another layer of file + -- monitor to avoid it whenever possible. + rerunIfChanged verbosity monitor tarballUri $ do + + -- Download + transport <- getTransport + liftIO $ do + transportCheckHttps verbosity transport tarballUri + notice verbosity ("Downloading " ++ show tarballUri) + createDirectoryIfMissingVerbose verbosity True + distDownloadSrcDirectory + _ <- downloadURI transport verbosity tarballUri tarballFile + return () + + -- Read + monitorFiles [monitorFile tarballFile] + let location = RemoteTarballPackage tarballUri tarballFile + liftIO $ fmap (mkSpecificSourcePackage location) + . uncurry (readSourcePackageCabalFile verbosity) + =<< extractTarballPackageCabalFile tarballFile + where + tarballStem = distDownloadSrcDirectory + localFileNameForRemoteTarball tarballUri + tarballFile = tarballStem <.> "tar.gz" + + monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) + monitor = newFileMonitor (tarballStem <.> "cache") + + +-- | A helper for 'fetchAndReadSourcePackages' to handle all the cases of +-- 'ProjectPackageRemoteRepo'. +-- +syncAndReadSourcePackagesRemoteRepos + :: Verbosity + -> DistDirLayout + -> ProjectConfigShared + -> [SourceRepo] + -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] +syncAndReadSourcePackagesRemoteRepos verbosity + DistDirLayout{distDownloadSrcDirectory} + ProjectConfigShared { + projectConfigProgPathExtra + } + repos = do + + repos' <- either reportSourceRepoProblems return $ + validateSourceRepos repos + + -- All 'SourceRepo's grouped by referring to the "same" remote repo + -- instance. So same location but can differ in commit/tag/branch/subdir. + let reposByLocation :: Map (RepoType, String) + [(SourceRepo, RepoType)] + reposByLocation = Map.fromListWith (++) + [ ((rtype, rloc), [(repo, vcsRepoType vcs)]) + | (repo, rloc, rtype, vcs) <- repos' ] + + --TODO: pass progPathExtra on to 'configureVCS' + let _progPathExtra = fromNubList projectConfigProgPathExtra + getConfiguredVCS <- delayInitSharedResources $ \repoType -> + let Just vcs = Map.lookup repoType knownVCSs in + configureVCS verbosity {-progPathExtra-} vcs + + concat <$> sequence + [ rerunIfChanged verbosity monitor repoGroup' $ do + vcs' <- getConfiguredVCS repoType + syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup' + | repoGroup@((primaryRepo, repoType):_) <- Map.elems reposByLocation + , let repoGroup' = map fst repoGroup + pathStem = distDownloadSrcDirectory + localFileNameForRemoteRepo primaryRepo + monitor :: FileMonitor + [SourceRepo] + [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] + monitor = newFileMonitor (pathStem <.> "cache") + ] + where + syncRepoGroupAndReadSourcePackages + :: VCS ConfiguredProgram + -> FilePath + -> [SourceRepo] + -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] + syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do + liftIO $ createDirectoryIfMissingVerbose verbosity False + distDownloadSrcDirectory + + -- For syncing we don't care about different 'SourceRepo' values that + -- are just different subdirs in the same repo. + syncSourceRepos verbosity vcs + [ (repo, repoPath) + | (repo, _, repoPath) <- repoGroupWithPaths ] + + -- But for reading we go through each 'SourceRepo' including its subdir + -- value and have to know which path each one ended up in. + sequence + [ readPackageFromSourceRepo repoWithSubdir repoPath + | (_, reposWithSubdir, repoPath) <- repoGroupWithPaths + , repoWithSubdir <- reposWithSubdir ] + where + -- So to do both things above, we pair them up here. + repoGroupWithPaths = + zipWith (\(x, y) z -> (x,y,z)) + (Map.toList + (Map.fromListWith (++) + [ (repo { repoSubdir = Nothing }, [repo]) + | repo <- repoGroup ])) + repoPaths + + -- The repos in a group are given distinct names by simple enumeration + -- foo, foo-2, foo-3 etc + repoPaths = pathStem + : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ] + + readPackageFromSourceRepo repo repoPath = do + let packageDir = maybe repoPath (repoPath ) (repoSubdir repo) + entries <- liftIO $ getDirectoryContents packageDir + --TODO: wrap exceptions + case filter (\e -> takeExtension e == ".cabal") entries of + [] -> liftIO $ throwIO NoCabalFileFound + (_:_:_) -> liftIO $ throwIO MultipleCabalFilesFound + [cabalFileName] -> do + monitorFiles [monitorFileHashed cabalFilePath] + liftIO $ fmap (mkSpecificSourcePackage location) + . readSourcePackageCabalFile verbosity cabalFilePath + =<< BS.readFile cabalFilePath + where + cabalFilePath = packageDir cabalFileName + location = RemoteSourceRepoPackage repo packageDir + + + reportSourceRepoProblems :: [(SourceRepo, SourceRepoProblem)] -> Rebuild a + reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems + + renderSourceRepoProblems :: [(SourceRepo, SourceRepoProblem)] -> String + renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems" + + +-- | Utility used by all the helpers of 'fetchAndReadSourcePackages' to make an +-- appropriate @'PackageSpecifier' ('SourcePackage' (..))@ for a given package +-- from a given location. +-- +mkSpecificSourcePackage :: PackageLocation FilePath + -> GenericPackageDescription + -> PackageSpecifier + (SourcePackage (PackageLocation (Maybe FilePath))) +mkSpecificSourcePackage location pkg = + SpecificSourcePackage SourcePackage { + packageInfoId = packageId pkg, + packageDescription = pkg, + --TODO: it is silly that we still have to use a Maybe FilePath here + packageSource = fmap Just location, packageDescrOverride = Nothing } -readSourcePackage _ (ProjectPackageNamed (Dependency pkgname verrange)) = - return $ NamedPackage pkgname [PackagePropertyVersion verrange] -readSourcePackage _verbosity _ = - fail $ "TODO: add support for fetching and reading local tarballs, remote " - ++ "tarballs, remote repos and passing named packages through" +-- | Errors reported upon failing to parse a @.cabal@ file. +-- +data CabalFileParseError = + CabalFileParseError + FilePath + [PError] + (Maybe Version) -- We might discover the spec version the package needs + [PWarning] + deriving (Show, Typeable) + +instance Exception CabalFileParseError + + +-- | Wrapper for the @.cabal@ file parser. It reports warnings on higher +-- verbosity levels and throws 'CabalFileParseError' on failure. +-- +readSourcePackageCabalFile :: Verbosity + -> FilePath + -> BS.ByteString + -> IO GenericPackageDescription +readSourcePackageCabalFile verbosity pkgfilename content = + case runParseResult (parseGenericPackageDescription content) of + (warnings, Right pkg) -> do + unless (null warnings) $ + info verbosity (formatWarnings warnings) + return pkg + + (warnings, Left (mspecVersion, errors)) -> + throwIO $ CabalFileParseError pkgfilename errors mspecVersion warnings + where + formatWarnings warnings = + "The package description file " ++ pkgfilename + ++ " has warnings: " + ++ unlines (map (NewParser.showPWarning pkgfilename) warnings) + + +-- | When looking for a package's @.cabal@ file we can find none, or several, +-- both of which are failures. +-- +data CabalFileSearchFailure = + NoCabalFileFound + | MultipleCabalFilesFound + deriving (Show, Typeable) + +instance Exception CabalFileSearchFailure + + +-- | Find the @.cabal@ file within a tarball file and return it by value. +-- +-- Can fail with a 'Tar.FormatError' or 'CabalFileSearchFailure' exception. +-- +extractTarballPackageCabalFile :: FilePath -> IO (FilePath, BS.ByteString) +extractTarballPackageCabalFile tarballFile = + withBinaryFile tarballFile ReadMode $ \hnd -> do + content <- LBS.hGetContents hnd + case extractTarballPackageCabalFilePure content of + Left (Left e) -> throwIO e + Left (Right e) -> throwIO e + Right (fileName, fileContent) -> + (,) fileName <$> evaluate (LBS.toStrict fileContent) + + +-- | Scan through a tar file stream and collect the @.cabal@ file, or fail. +-- +extractTarballPackageCabalFilePure :: LBS.ByteString + -> Either (Either Tar.FormatError + CabalFileSearchFailure) + (FilePath, LBS.ByteString) +extractTarballPackageCabalFilePure = + check + . accumEntryMap + . Tar.filterEntries isCabalFile + . Tar.read + . GZipUtils.maybeDecompress + where + accumEntryMap = Tar.foldlEntries + (\m e -> Map.insert (Tar.entryTarPath e) e m) + Map.empty + + check (Left (e, _m)) = Left (Left e) + check (Right m) = case Map.elems m of + [] -> Left (Right NoCabalFileFound) + [file] -> case Tar.entryContent file of + Tar.NormalFile content _ -> Right (Tar.entryPath file, content) + _ -> Left (Right NoCabalFileFound) + _files -> Left (Right MultipleCabalFilesFound) + + isCabalFile e = case splitPath (Tar.entryPath e) of + [ _dir, file] -> takeExtension file == ".cabal" + [".", _dir, file] -> takeExtension file == ".cabal" + _ -> False + + +-- | The name to use for a local file for a remote tarball 'SourceRepo'. +-- This is deterministic based on the remote tarball URI, and is intended +-- to produce non-clashing file names for different tarballs. +-- +localFileNameForRemoteTarball :: URI -> FilePath +localFileNameForRemoteTarball uri = + mangleName uri + ++ "-" ++ showHex locationHash "" + where + mangleName = truncateString 10 . dropExtension . dropExtension + . takeFileName . dropTrailingPathSeparator . uriPath + + locationHash :: Word + locationHash = fromIntegral (Hashable.hash (uriToString id uri "")) + + +-- | The name to use for a local file or dir for a remote 'SourceRepo'. +-- This is deterministic based on the source repo identity details, and +-- intended to produce non-clashing file names for different repos. +-- +localFileNameForRemoteRepo :: SourceRepo -> FilePath +localFileNameForRemoteRepo SourceRepo{repoType, repoLocation, repoModule} = + maybe "" ((++ "-") . mangleName) repoLocation + ++ showHex locationHash "" + where + mangleName = truncateString 10 . dropExtension + . takeFileName . dropTrailingPathSeparator + + -- just the parts that make up the "identity" of the repo + locationHash :: Word + locationHash = + fromIntegral (Hashable.hash (show repoType, repoLocation, repoModule)) + + +-- | Truncate a string, with a visual indication that it is truncated. +truncateString :: Int -> String -> String +truncateString n s | length s <= n = s + | otherwise = take (n-1) s ++ "_" -- TODO: add something like this, here or in the project planning diff --git a/Distribution/Client/ProjectConfig/Legacy.hs b/Distribution/Client/ProjectConfig/Legacy.hs --- a/Distribution/Client/ProjectConfig/Legacy.hs +++ b/Distribution/Client/ProjectConfig/Legacy.hs @@ -193,7 +193,8 @@ splitConfig pc = (pc , mempty { packageConfigProgramPaths = packageConfigProgramPaths pc , packageConfigProgramArgs = packageConfigProgramArgs pc - , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc }) + , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc + , packageConfigDocumentation = packageConfigDocumentation pc }) -- | Convert from the types currently used for the user-wide @~/.cabal/config@ -- file into the 'ProjectConfig' type. @@ -303,7 +304,8 @@ globalSandboxConfigFile = _, -- ?? globalRemoteRepos = projectConfigRemoteRepos, globalLocalRepos = projectConfigLocalRepos, - globalProgPathExtra = projectConfigProgPathExtra + globalProgPathExtra = projectConfigProgPathExtra, + globalStoreDir = projectConfigStoreDir } = globalFlags ConfigFlags { @@ -388,7 +390,7 @@ configRelocatable = packageConfigRelocatable } = configFlags packageConfigProgramPaths = MapLast (Map.fromList configProgramPaths) - packageConfigProgramArgs = MapMappend (Map.fromList configProgramArgs) + packageConfigProgramArgs = MapMappend (Map.fromListWith (++) configProgramArgs) packageConfigCoverage = coverage <> libcoverage --TODO: defer this merging to the resolve phase @@ -410,6 +412,7 @@ haddockInternal = packageConfigHaddockInternal, haddockCss = packageConfigHaddockCss, haddockLinkedSource = packageConfigHaddockLinkedSource, + haddockQuickJump = packageConfigHaddockQuickJump, haddockHscolourCss = packageConfigHaddockHscolourCss, haddockContents = packageConfigHaddockContents } = haddockFlags @@ -431,8 +434,7 @@ globalLogsDir = projectConfigLogsDir, globalWorldFile = _, globalHttpTransport = projectConfigHttpTransport, - globalIgnoreExpiry = projectConfigIgnoreExpiry, - globalStoreDir = projectConfigStoreDir + globalIgnoreExpiry = projectConfigIgnoreExpiry } = globalFlags ConfigFlags { @@ -728,12 +730,14 @@ haddockInternal = packageConfigHaddockInternal, haddockCss = packageConfigHaddockCss, haddockLinkedSource = packageConfigHaddockLinkedSource, + haddockQuickJump = packageConfigHaddockQuickJump, haddockHscolourCss = packageConfigHaddockHscolourCss, haddockContents = packageConfigHaddockContents, haddockDistPref = mempty, haddockKeepTempFiles = mempty, haddockVerbosity = mempty, - haddockCabalFilePath = mempty + haddockCabalFilePath = mempty, + haddockArgs = mempty } @@ -1002,7 +1006,7 @@ [ "hoogle", "html", "html-location" , "foreign-libraries" , "executables", "tests", "benchmarks", "all", "internal", "css" - , "hyperlink-source", "hscolour-css" + , "hyperlink-source", "quickjump", "hscolour-css" , "contents-location", "keep-temp-files" ] . commandOptionsToFields diff --git a/Distribution/Client/ProjectConfig/Types.hs b/Distribution/Client/ProjectConfig/Types.hs --- a/Distribution/Client/ProjectConfig/Types.hs +++ b/Distribution/Client/ProjectConfig/Types.hs @@ -147,8 +147,7 @@ projectConfigHttpTransport :: Flag String, projectConfigIgnoreExpiry :: Flag Bool, projectConfigCacheDir :: Flag FilePath, - projectConfigLogsDir :: Flag FilePath, - projectConfigStoreDir :: Flag FilePath + projectConfigLogsDir :: Flag FilePath } deriving (Eq, Show, Generic) @@ -178,6 +177,7 @@ projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. projectConfigLocalRepos :: NubList FilePath, projectConfigIndexState :: Flag IndexState, + projectConfigStoreDir :: Flag FilePath, -- solver configuration projectConfigConstraints :: [(UserConstraint, ConstraintSource)], @@ -270,6 +270,7 @@ packageConfigHaddockInternal :: Flag Bool, --TODO: [required eventually] use this packageConfigHaddockCss :: Flag FilePath, --TODO: [required eventually] use this packageConfigHaddockLinkedSource :: Flag Bool, --TODO: [required eventually] use this + packageConfigHaddockQuickJump :: Flag Bool, --TODO: [required eventually] use this packageConfigHaddockHscolourCss :: Flag FilePath, --TODO: [required eventually] use this packageConfigHaddockContents :: Flag PathTemplate, --TODO: [required eventually] use this packageConfigHaddockForHackage :: Flag HaddockTarget diff --git a/Distribution/Client/ProjectOrchestration.hs b/Distribution/Client/ProjectOrchestration.hs --- a/Distribution/Client/ProjectOrchestration.hs +++ b/Distribution/Client/ProjectOrchestration.hs @@ -47,6 +47,7 @@ commandLineFlagsToProjectConfig, -- * Pre-build phase: decide what to do. + withInstallPlan, runProjectPreBuildPhase, ProjectBuildContext(..), @@ -56,6 +57,7 @@ resolveTargets, TargetsMap, TargetSelector(..), + TargetImplicitCwd(..), PackageId, AvailableTarget(..), AvailableTargetStatus(..), @@ -108,14 +110,17 @@ import Distribution.Client.Types ( GenericReadyPackage(..), UnresolvedSourcePackage - , PackageSpecifier(..) ) + , PackageSpecifier(..) + , SourcePackageDb(..) ) +import Distribution.Solver.Types.PackageIndex + ( lookupPackageName ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.TargetSelector - ( TargetSelector(..) + ( TargetSelector(..), TargetImplicitCwd(..) , ComponentKind(..), componentKind , readTargetSelectors, reportTargetSelectorProblems ) import Distribution.Client.DistDirLayout -import Distribution.Client.Config (defaultCabalDir) +import Distribution.Client.Config (getCabalDir) import Distribution.Client.Setup hiding (packageName) import Distribution.Types.ComponentName ( componentNameString ) @@ -136,8 +141,7 @@ import Distribution.Simple.Configure (computeEffectiveProfiling) import Distribution.Simple.Utils - ( die' - , notice, noticeNoWrap, debugNoWrap ) + ( die', warn, notice, noticeNoWrap, debugNoWrap ) import Distribution.Verbosity import Distribution.Text import Distribution.Simple.Compiler @@ -171,7 +175,7 @@ -> IO ProjectBaseContext establishProjectBaseContext verbosity cliConfig = do - cabalDir <- defaultCabalDir + cabalDir <- getCabalDir projectRoot <- either throwIO return =<< findProjectRoot Nothing mprojectFile @@ -184,10 +188,13 @@ cliConfig let ProjectConfigBuildOnly { - projectConfigLogsDir, - projectConfigStoreDir + projectConfigLogsDir } = projectConfigBuildOnly projectConfig + ProjectConfigShared { + projectConfigStoreDir + } = projectConfigShared projectConfig + mlogsDir = Setup.flagToMaybe projectConfigLogsDir mstoreDir = Setup.flagToMaybe projectConfigStoreDir cabalDirLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir @@ -243,6 +250,31 @@ -- | Pre-build phase: decide what to do. -- +withInstallPlan + :: Verbosity + -> ProjectBaseContext + -> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a) + -> IO a +withInstallPlan + verbosity + ProjectBaseContext { + distDirLayout, + cabalDirLayout, + projectConfig, + localPackages + } + action = do + -- Take the project configuration and make a plan for how to build + -- everything in the project. This is independent of any specific targets + -- the user has asked for. + -- + (elaboratedPlan, _, elaboratedShared) <- + rebuildInstallPlan verbosity + distDirLayout cabalDirLayout + projectConfig + localPackages + action elaboratedPlan elaboratedShared + runProjectPreBuildPhase :: Verbosity -> ProjectBaseContext @@ -257,7 +289,6 @@ localPackages } selectPlanSubset = do - -- Take the project configuration and make a plan for how to build -- everything in the project. This is independent of any specific targets -- the user has asked for. @@ -440,17 +471,11 @@ -> Either err k ) -> (TargetProblemCommon -> err) -> ElaboratedInstallPlan + -> Maybe (SourcePackageDb) -> [TargetSelector] -> Either [err] TargetsMap resolveTargets selectPackageTargets selectComponentTarget liftProblem - installPlan = - --TODO: [required eventually] - -- we cannot resolve names of packages other than those that are - -- directly in the current plan. We ought to keep a set of the known - -- hackage packages so we can resolve names to those. Though we don't - -- really need that until we can do something sensible with packages - -- outside of the project. - + installPlan mPkgDb = fmap mkTargetsMap . checkErrors . map (\ts -> (,) ts <$> checkTarget ts) @@ -531,10 +556,13 @@ . selectPackageTargets bt $ ats + | Just SourcePackageDb{ packageIndex } <- mPkgDb + , let pkg = lookupPackageName packageIndex pkgname + , not (null pkg) + = Left (liftProblem (TargetAvailableInIndex pkgname)) + | otherwise = Left (liftProblem (TargetNotInProject pkgname)) - --TODO: check if the package is in hackage and return different - -- error cases here so the commands can handle things appropriately componentTargets :: SubComponentTarget -> [(b, ComponentName)] @@ -705,6 +733,7 @@ data TargetProblemCommon = TargetNotInProject PackageName + | TargetAvailableInIndex PackageName | TargetComponentNotProjectLocal PackageId ComponentName SubComponentTarget | TargetComponentNotBuildable PackageId ComponentName SubComponentTarget | TargetOptionalStanzaDisabledByUser PackageId ComponentName SubComponentTarget @@ -914,7 +943,7 @@ -- For all failures, print either a short summary (if we showed the -- build log) or all details - die' verbosity $ unlines + dieIfNotHaddockFailure verbosity $ unlines [ case failureClassification of ShowBuildSummaryAndLog reason _ | verbosity > normal @@ -942,6 +971,15 @@ , InstallPlan.Configured pkg <- maybeToList (InstallPlan.lookup plan pkgid) ] + + dieIfNotHaddockFailure + | all isHaddockFailure failuresClassification = warn + | otherwise = die' + where + isHaddockFailure (_, ShowBuildSummaryOnly (HaddocksFailed _) ) = True + isHaddockFailure (_, ShowBuildSummaryAndLog (HaddocksFailed _) _) = True + isHaddockFailure _ = False + classifyBuildFailure :: BuildFailure -> BuildFailurePresentation classifyBuildFailure BuildFailure { diff --git a/Distribution/Client/ProjectPlanOutput.hs b/Distribution/Client/ProjectPlanOutput.hs --- a/Distribution/Client/ProjectPlanOutput.hs +++ b/Distribution/Client/ProjectPlanOutput.hs @@ -18,7 +18,7 @@ import Distribution.Client.ProjectPlanning.Types import Distribution.Client.ProjectBuilding.Types import Distribution.Client.DistDirLayout -import Distribution.Client.Types (confInstId) +import Distribution.Client.Types (Repo(..), RemoteRepo(..), PackageLocation(..), confInstId) import Distribution.Client.PackageHash (showHashValue) import qualified Distribution.Client.InstallPlan as InstallPlan @@ -139,6 +139,7 @@ , "flags" J..= J.object [ PD.unFlagName fn J..= v | (fn,v) <- PD.unFlagAssignment (elabFlagAssignment elab) ] , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab)) + , "pkg-src" J..= packageLocationToJ (elabPkgSourceLocation elab) ] ++ [ "pkg-src-sha256" J..= J.String (showHashValue hash) | Just hash <- [elabPkgSourceHash elab] ] ++ @@ -168,6 +169,57 @@ ] ++ bin_file (compSolverName comp) where + packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value + packageLocationToJ pkgloc = + case pkgloc of + LocalUnpackedPackage local -> + J.object [ "type" J..= J.String "local" + , "path" J..= J.String local + ] + LocalTarballPackage local -> + J.object [ "type" J..= J.String "local-tar" + , "path" J..= J.String local + ] + RemoteTarballPackage uri _ -> + J.object [ "type" J..= J.String "remote-tar" + , "uri" J..= J.String (show uri) + ] + RepoTarballPackage repo _ _ -> + J.object [ "type" J..= J.String "repo-tar" + , "repo" J..= repoToJ repo + ] + RemoteSourceRepoPackage srcRepo _ -> + J.object [ "type" J..= J.String "source-repo" + , "source-repo" J..= sourceRepoToJ srcRepo + ] + + repoToJ :: Repo -> J.Value + repoToJ repo = + case repo of + RepoLocal{..} -> + J.object [ "type" J..= J.String "local-repo" + , "path" J..= J.String repoLocalDir + ] + RepoRemote{..} -> + J.object [ "type" J..= J.String "remote-repo" + , "uri" J..= J.String (show (remoteRepoURI repoRemote)) + ] + RepoSecure{..} -> + J.object [ "type" J..= J.String "secure-repo" + , "uri" J..= J.String (show (remoteRepoURI repoRemote)) + ] + + sourceRepoToJ :: PD.SourceRepo -> J.Value + sourceRepoToJ PD.SourceRepo{..} = + J.object $ filter ((/= J.Null) . snd) $ + [ "type" J..= fmap jdisplay repoType + , "location" J..= fmap J.String repoLocation + , "module" J..= fmap J.String repoModule + , "branch" J..= fmap J.String repoBranch + , "tag" J..= fmap J.String repoTag + , "subdir" J..= fmap J.String repoSubdir + ] + dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elaboratedSharedConfig elab) @@ -510,7 +562,7 @@ Graph.revClosure packagesLibDepGraph ( Map.keys . Map.filter (uncurry buildAttempted) - $ Map.intersectionWith (,) pkgBuildStatus buildOutcomes + $ Map.intersectionWith (,) pkgBuildStatus buildOutcomes ) -- The plan graph but only counting dependency-on-library edges @@ -881,4 +933,3 @@ UserPackageDB -> UserPackageDB SpecificPackageDB path -> SpecificPackageDB relpath where relpath = makeRelative relroot path - diff --git a/Distribution/Client/ProjectPlanning.hs b/Distribution/Client/ProjectPlanning.hs --- a/Distribution/Client/ProjectPlanning.hs +++ b/Distribution/Client/ProjectPlanning.hs @@ -56,6 +56,7 @@ setupHsCopyFlags, setupHsRegisterFlags, setupHsHaddockFlags, + setupHsHaddockArgs, packageHashInputs, @@ -86,6 +87,7 @@ import Distribution.Client.SetupWrapper import Distribution.Client.JobControl import Distribution.Client.FetchUtils +import Distribution.Client.Config import qualified Hackage.Security.Client as Sec import Distribution.Client.Setup hiding (packageName, cabalVersion) import Distribution.Utils.NubList @@ -142,7 +144,7 @@ import Distribution.Backpack import Distribution.Types.ComponentInclude -import Distribution.Simple.Utils hiding (matchFileGlob) +import Distribution.Simple.Utils import Distribution.Version import Distribution.Verbosity import Distribution.Text @@ -294,41 +296,57 @@ rebuildProjectConfig :: Verbosity -> DistDirLayout -> ProjectConfig - -> IO (ProjectConfig, - [PackageSpecifier UnresolvedSourcePackage]) + -> IO ( ProjectConfig + , [PackageSpecifier UnresolvedSourcePackage] ) rebuildProjectConfig verbosity distDirLayout@DistDirLayout { distProjectRootDirectory, distDirectory, distProjectCacheFile, - distProjectCacheDirectory + distProjectCacheDirectory, + distProjectFile } cliConfig = do + fileMonitorProjectConfigKey <- do + configPath <- getConfigFilePath projectConfigConfigFile + return (configPath, distProjectFile "") + (projectConfig, localPackages) <- - runRebuild distProjectRootDirectory $ - rerunIfChanged verbosity fileMonitorProjectConfig () $ do + runRebuild distProjectRootDirectory + $ rerunIfChanged verbosity + fileMonitorProjectConfig + fileMonitorProjectConfigKey + $ do + liftIO $ info verbosity "Project settings changed, reconfiguring..." + projectConfig <- phaseReadProjectConfig + localPackages <- phaseReadLocalPackages projectConfig + return (projectConfig, localPackages) - projectConfig <- phaseReadProjectConfig - localPackages <- phaseReadLocalPackages projectConfig - return (projectConfig, localPackages) + info verbosity + $ unlines + $ ("this build was affected by the following (project) config files:" :) + $ [ "- " ++ path + | Explicit path <- Set.toList $ projectConfigProvenance projectConfig + ] return (projectConfig <> cliConfig, localPackages) where - ProjectConfigShared { - projectConfigConfigFile - } = projectConfigShared cliConfig - fileMonitorProjectConfig = newFileMonitor (distProjectCacheFile "config") + ProjectConfigShared { projectConfigConfigFile } = + projectConfigShared cliConfig + fileMonitorProjectConfig = + newFileMonitor (distProjectCacheFile "config") :: FileMonitor + (FilePath, FilePath) + (ProjectConfig, [PackageSpecifier UnresolvedSourcePackage]) + -- Read the cabal.project (or implicit config) and combine it with -- arguments from the command line -- phaseReadProjectConfig :: Rebuild ProjectConfig phaseReadProjectConfig = do - liftIO $ do - info verbosity "Project settings changed, reconfiguring..." readProjectConfig verbosity projectConfigConfigFile distDirLayout -- Look for all the cabal packages in the project @@ -336,8 +354,11 @@ -- phaseReadLocalPackages :: ProjectConfig -> Rebuild [PackageSpecifier UnresolvedSourcePackage] - phaseReadLocalPackages projectConfig = do - localCabalFiles <- findProjectPackages distDirLayout projectConfig + phaseReadLocalPackages projectConfig@ProjectConfig { + projectConfigShared, + projectConfigBuildOnly + } = do + pkgLocations <- findProjectPackages distDirLayout projectConfig -- Create folder only if findProjectPackages did not throw a -- BadPackageLocations exception. @@ -345,7 +366,10 @@ createDirectoryIfMissingVerbose verbosity True distDirectory createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory - mapM (readSourcePackage verbosity) localCabalFiles + fetchAndReadSourcePackages verbosity distDirLayout + projectConfigShared + projectConfigBuildOnly + pkgLocations -- | Return an up-to-date elaborated install plan. @@ -586,7 +610,7 @@ -> (Compiler, Platform, ProgramDb) -> PkgConfigDb -> SolverInstallPlan - -> [PackageSpecifier (SourcePackage loc)] + -> [PackageSpecifier (SourcePackage (PackageLocation loc))] -> Rebuild ( ElaboratedInstallPlan , ElaboratedSharedConfig ) phaseElaboratePlan ProjectConfig { @@ -1041,6 +1065,7 @@ -- respective major Cabal version bundled with the respective GHC -- release). -- + -- GHC 8.4 needs Cabal >= 2.4 -- GHC 8.4 needs Cabal >= 2.2 -- GHC 8.2 needs Cabal >= 2.0 -- GHC 8.0 needs Cabal >= 1.24 @@ -1052,11 +1077,12 @@ -- TODO: long-term, this compatibility matrix should be -- stored as a field inside 'Distribution.Compiler.Compiler' setupMinCabalVersionConstraint - | isGHC, compVer >= mkVersion [8,4,1] = mkVersion [2,2] - -- GHC 8.4.1-rc1 (GHC 8.4.0.20180224) still shipped with an - -- devel snapshot of Cabal-2.1.0.0; the rule below can be + | isGHC, compVer >= mkVersion [8,6,1] = mkVersion [2,4] + -- GHC 8.6alpha2 (GHC 8.6.0.20180714) still shipped with a + -- devel snapshot of Cabal-2.3.0.0; the rule below can be -- dropped at some point - | isGHC, compVer >= mkVersion [8,4] = mkVersion [2,1] + | isGHC, compVer >= mkVersion [8,6] = mkVersion [2,3] + | isGHC, compVer >= mkVersion [8,4] = mkVersion [2,2] | isGHC, compVer >= mkVersion [8,2] = mkVersion [2,0] | isGHC, compVer >= mkVersion [8,0] = mkVersion [1,24] | isGHC, compVer >= mkVersion [7,10] = mkVersion [1,22] @@ -1160,9 +1186,7 @@ -- (due to setup dependencies); we can't just look up the package name -- from the package description. -- --- However, we do have the following INVARIANT: a component never directly --- depends on multiple versions of the same package. Thus, we can --- adopt the following strategy: +-- We can adopt the following strategy: -- -- * When a package is transformed into components, record -- a mapping from SolverId to ALL of the components @@ -1175,12 +1199,12 @@ -- By the way, we can tell that SolverInstallPlan is not the "right" type -- because a SolverId cannot adequately represent all possible dependency -- solver states: we may need to record foo-0.1 multiple times in --- the solver install plan with different dependencies. The solver probably --- doesn't handle this correctly... but it should. The right way to solve --- this is to come up with something very much like a 'ConfiguredId', in that --- it incorporates the version choices of its dependencies, but less --- fine grained. Fortunately, this doesn't seem to have affected anyone, --- but it is good to watch out about. +-- the solver install plan with different dependencies. This imprecision in the +-- type currently doesn't cause any problems because the dependency solver +-- continues to enforce the single instance restriction regardless of compiler +-- version. The right way to solve this is to come up with something very much +-- like a 'ConfiguredId', in that it incorporates the version choices of its +-- dependencies, but less fine grained. -- | Produce an elaborated install plan using the policy for local builds with @@ -1194,7 +1218,7 @@ -> DistDirLayout -> StoreDirLayout -> SolverInstallPlan - -> [PackageSpecifier (SourcePackage loc)] + -> [PackageSpecifier (SourcePackage (PackageLocation loc))] -> Map PackageId PackageSourceHash -> InstallDirs.InstallDirTemplates -> ProjectConfigShared @@ -1219,7 +1243,8 @@ ElaboratedSharedConfig { pkgConfigPlatform = platform, pkgConfigCompiler = compiler, - pkgConfigCompilerProgs = compilerprogdb + pkgConfigCompilerProgs = compilerprogdb, + pkgConfigReplOptions = [] } preexistingInstantiatedPkgs = @@ -1385,10 +1410,14 @@ quotes (text (componentNameStanza cname))) $ do -- 1. Configure the component, but with a place holder ComponentId. - cc0 <- toConfiguredComponent pd + cc0 <- toConfiguredComponent + pd (error "Distribution.Client.ProjectPlanning.cc_cid: filled in later") - (Map.unionWith Map.union external_cc_map cc_map) comp + (Map.unionWith Map.union external_lib_cc_map cc_map) + (Map.unionWith Map.union external_exe_cc_map cc_map) + comp + -- 2. Read out the dependencies from the ConfiguredComponent cc0 let compLibDependencies = -- Nub because includes can show up multiple times @@ -1472,20 +1501,31 @@ -- 'elab'. external_lib_dep_sids = CD.select (== compSolverName) deps0 external_exe_dep_sids = CD.select (== compSolverName) exe_deps0 - -- TODO: The fact that lib SolverIds and exe SolverIds are - -- jammed together here means that we're losing information! - external_dep_sids = external_lib_dep_sids ++ external_exe_dep_sids - external_dep_pkgs = concatMap mapDep external_dep_sids + external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids + + -- Combine library and build-tool dependencies, for backwards + -- compatibility (See issue #5412 and the documentation for + -- InstallPlan.fromSolverInstallPlan), but prefer the versions + -- specified as build-tools. + external_exe_dep_pkgs = + concatMap mapDep $ + ordNubBy (pkgName . packageId) $ + external_exe_dep_sids ++ external_lib_dep_sids + external_exe_map = Map.fromList $ [ (getComponentId pkg, path) - | pkg <- external_dep_pkgs + | pkg <- external_exe_dep_pkgs , Just path <- [planPackageExePath pkg] ] exe_map1 = Map.union external_exe_map exe_map - external_cc_map = Map.fromListWith Map.union - $ map mkCCMapping external_dep_pkgs - external_lc_map = Map.fromList (map mkShapeMapping external_dep_pkgs) + external_lib_cc_map = Map.fromListWith Map.union + $ map mkCCMapping external_lib_dep_pkgs + external_exe_cc_map = Map.fromListWith Map.union + $ map mkCCMapping external_exe_dep_pkgs + external_lc_map = + Map.fromList $ map mkShapeMapping $ + external_lib_dep_pkgs ++ concatMap mapDep external_exe_dep_sids compPkgConfigDependencies = [ (pn, fromMaybe (error $ "compPkgConfigDependencies: impossible! " @@ -1727,6 +1767,8 @@ elabTestTargets = [] elabBenchTargets = [] elabReplTarget = Nothing + elabHaddockTargets = [] + elabBuildHaddocks = perPkgOptionFlag pkgid False packageConfigDocumentation @@ -1808,6 +1850,7 @@ elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource + elabHaddockQuickJump = perPkgOptionFlag pkgid False packageConfigHaddockQuickJump elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents @@ -1876,12 +1919,14 @@ --TODO: localPackages is a misnomer, it's all project packages -- here is where we decide which ones will be local! where - shouldBeLocal :: PackageSpecifier (SourcePackage loc) -> Maybe PackageId + shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId shouldBeLocal NamedPackage{} = Nothing - shouldBeLocal (SpecificSourcePackage pkg) = Just (packageId pkg) - -- TODO: It's not actually obvious for all of the - -- 'ProjectPackageLocation's that they should all be local. We might - -- need to provide the user with a choice. + shouldBeLocal (SpecificSourcePackage pkg) + | LocalTarballPackage _ <- packageSource pkg = Nothing + | otherwise = Just (packageId pkg) + -- TODO: Is it only LocalTarballPackages we can know about without + -- them being "local" in the sense meant here? + -- -- Also, review use of SourcePackage's loc vs ProjectPackageLocation pkgsUseSharedLibrary :: Set PackageId @@ -2437,6 +2482,7 @@ isJust (elabReplTarget elab) || (not . null) (elabTestTargets elab) || (not . null) (elabBenchTargets elab) + || (not . null) (elabHaddockTargets elab) || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab , subtarget /= WholeComponent ] @@ -2535,11 +2581,22 @@ (Just tgts, TargetActionBuild) -> elab { elabBuildTargets = tgts } (Just tgts, TargetActionTest) -> elab { elabTestTargets = tgts } (Just tgts, TargetActionBench) -> elab { elabBenchTargets = tgts } - (Just [tgt], TargetActionRepl) -> elab { elabReplTarget = Just tgt } - (Just _, TargetActionHaddock) -> elab { elabBuildHaddocks = True } + (Just [tgt], TargetActionRepl) -> elab { elabReplTarget = Just tgt + , elabBuildHaddocks = False } + (Just tgts, TargetActionHaddock) -> + foldr setElabHaddockTargets (elab { elabHaddockTargets = tgts + , elabBuildHaddocks = True }) tgts (Just _, TargetActionRepl) -> error "pruneInstallPlanToTargets: multiple repl targets" + setElabHaddockTargets tgt elab + | isTestComponentTarget tgt = elab { elabHaddockTestSuites = True } + | isBenchComponentTarget tgt = elab { elabHaddockBenchmarks = True } + | isForeignLibComponentTarget tgt = elab { elabHaddockForeignLibs = True } + | isExeComponentTarget tgt = elab { elabHaddockExecutables = True } + | isSubLibComponentTarget tgt = elab { elabHaddockInternal = True } + | otherwise = elab + -- | Assuming we have previously set the root build targets (i.e. the user -- targets but not rev deps yet), the first pruning pass does two things: -- @@ -2560,14 +2617,16 @@ roots = mapMaybe find_root pkgs' prune elab = PrunedPackage elab' (pruneOptionalDependencies elab') - where elab' = addOptionalStanzas elab + where elab' = + setDocumentation + $ addOptionalStanzas elab find_root (InstallPlan.Configured (PrunedPackage elab _)) = if not (null (elabBuildTargets elab) && null (elabTestTargets elab) && null (elabBenchTargets elab) && isNothing (elabReplTarget elab) - && not (elabBuildHaddocks elab)) + && null (elabHaddockTargets elab)) then Just (installedUnitId elab) else Nothing find_root _ = Nothing @@ -2613,6 +2672,26 @@ <> optionalStanzasWithDepsAvailable availablePkgs elab pkg addOptionalStanzas elab = elab + setDocumentation :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage + setDocumentation elab@ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } = + elab { + elabBuildHaddocks = + elabBuildHaddocks elab && documentationEnabled (compSolverName comp) elab + } + + where + documentationEnabled c = + case c of + CD.ComponentLib -> const True + CD.ComponentSubLib _ -> elabHaddockInternal + CD.ComponentFLib _ -> elabHaddockForeignLibs + CD.ComponentExe _ -> elabHaddockExecutables + CD.ComponentTest _ -> elabHaddockTestSuites + CD.ComponentBench _ -> elabHaddockBenchmarks + CD.ComponentSetup -> const False + + setDocumentation elab = elab + -- Calculate package dependencies but cut out those needed only by -- optional stanzas that we've determined we will not enable. -- These pruned deps are not persisted in this pass since they're based on @@ -2639,6 +2718,7 @@ ++ elabTestTargets pkg ++ elabBenchTargets pkg ++ maybeToList (elabReplTarget pkg) + ++ elabHaddockTargets pkg , stanza <- maybeToList (componentOptionalStanza cname) ] @@ -3313,13 +3393,14 @@ -> Verbosity -> FilePath -> Cabal.ReplFlags -setupHsReplFlags _ _ verbosity builddir = +setupHsReplFlags _ sharedConfig verbosity builddir = Cabal.ReplFlags { replProgramPaths = mempty, --unused, set at configure time replProgramArgs = mempty, --unused, set at configure time replVerbosity = toFlag verbosity, replDistPref = toFlag builddir, - replReload = mempty --only used as callback from repl + replReload = mempty, --only used as callback from repl + replReplOptions = pkgConfigReplOptions sharedConfig --runtime override for repl flags } @@ -3371,8 +3452,6 @@ -> Verbosity -> FilePath -> Cabal.HaddockFlags --- TODO: reconsider whether or not Executables/TestSuites/... --- needed for component setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.HaddockFlags { haddockProgramPaths = mempty, --unused, set at configure time @@ -3388,14 +3467,21 @@ haddockInternal = toFlag elabHaddockInternal, haddockCss = maybe mempty toFlag elabHaddockCss, haddockLinkedSource = toFlag elabHaddockLinkedSource, + haddockQuickJump = toFlag elabHaddockQuickJump, haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss, haddockContents = maybe mempty toFlag elabHaddockContents, haddockDistPref = toFlag builddir, haddockKeepTempFiles = mempty, --TODO: from build settings haddockVerbosity = toFlag verbosity, - haddockCabalFilePath = mempty + haddockCabalFilePath = mempty, + haddockArgs = mempty } +setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String] +-- TODO: Does the issue #3335 affects test as well +setupHsHaddockArgs elab = + map (showComponentTarget (packageId elab)) (elabHaddockTargets elab) + {- setupHsTestFlags :: ElaboratedConfiguredPackage -> ElaboratedSharedConfig @@ -3498,10 +3584,7 @@ packageHashConfigInputs :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> PackageHashConfigInputs -packageHashConfigInputs - ElaboratedSharedConfig{..} - ElaboratedConfiguredPackage{..} = - +packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg = PackageHashConfigInputs { pkgHashCompilerId = compilerId pkgConfigCompiler, pkgHashPlatform = pkgConfigPlatform, @@ -3527,9 +3610,24 @@ pkgHashExtraFrameworkDirs = elabExtraFrameworkDirs, pkgHashExtraIncludeDirs = elabExtraIncludeDirs, pkgHashProgPrefix = elabProgPrefix, - pkgHashProgSuffix = elabProgSuffix - } + pkgHashProgSuffix = elabProgSuffix, + pkgHashDocumentation = elabBuildHaddocks, + pkgHashHaddockHoogle = elabHaddockHoogle, + pkgHashHaddockHtml = elabHaddockHtml, + pkgHashHaddockHtmlLocation = elabHaddockHtmlLocation, + pkgHashHaddockForeignLibs = elabHaddockForeignLibs, + pkgHashHaddockExecutables = elabHaddockExecutables, + pkgHashHaddockTestSuites = elabHaddockTestSuites, + pkgHashHaddockBenchmarks = elabHaddockBenchmarks, + pkgHashHaddockInternal = elabHaddockInternal, + pkgHashHaddockCss = elabHaddockCss, + pkgHashHaddockLinkedSource = elabHaddockLinkedSource, + pkgHashHaddockQuickJump = elabHaddockQuickJump, + pkgHashHaddockContents = elabHaddockContents + } + where + ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage shared pkg -- | Given the 'InstalledPackageIndex' for a nix-style package store, and an -- 'ElaboratedInstallPlan', replace configured source packages by installed @@ -3584,4 +3682,3 @@ inplaceBinRoot layout config package = distBuildDirectory layout (elabDistDirParams config package) "build" - diff --git a/Distribution/Client/ProjectPlanning/Types.hs b/Distribution/Client/ProjectPlanning/Types.hs --- a/Distribution/Client/ProjectPlanning/Types.hs +++ b/Distribution/Client/ProjectPlanning/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeFamilies #-} -- | Types used while planning how to build everything in a project. @@ -11,6 +12,7 @@ -- * Elaborated install plan types ElaboratedInstallPlan, + normaliseConfiguredPackage, ElaboratedConfiguredPackage(..), elabDistDirParams, @@ -46,7 +48,11 @@ showBenchComponentTarget, SubComponentTarget(..), + isSubLibComponentTarget, + isForeignLibComponentTarget, + isExeComponentTarget, isTestComponentTarget, + isBenchComponentTarget, -- * Setup script SetupScriptStyle(..), @@ -79,7 +85,7 @@ import Distribution.Simple.Compiler import Distribution.Simple.Build.PathsModule (pkgPathEnvVar) import qualified Distribution.Simple.BuildTarget as Cabal -import Distribution.Simple.Program.Db +import Distribution.Simple.Program import Distribution.ModuleName (ModuleName) import Distribution.Simple.LocalBuildInfo (ComponentName(..)) import qualified Distribution.Simple.InstallDirs as InstallDirs @@ -94,6 +100,7 @@ import Distribution.Simple.Utils (ordNub) import Data.Map (Map) +import qualified Data.Map as Map import Data.Maybe (catMaybes) import Data.Set (Set) import qualified Data.ByteString.Lazy as LBS @@ -141,7 +148,8 @@ -- | The programs that the compiler configured (e.g. for GHC, the progs -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are -- used. - pkgConfigCompilerProgs :: ProgramDb + pkgConfigCompilerProgs :: ProgramDb, + pkgConfigReplOptions :: [String] } deriving (Show, Generic, Typeable) --TODO: [code cleanup] no Eq instance @@ -273,6 +281,7 @@ elabHaddockInternal :: Bool, elabHaddockCss :: Maybe FilePath, elabHaddockLinkedSource :: Bool, + elabHaddockQuickJump :: Bool, elabHaddockHscolourCss :: Maybe FilePath, elabHaddockContents :: Maybe PathTemplate, @@ -293,6 +302,8 @@ elabTestTargets :: [ComponentTarget], elabBenchTargets :: [ComponentTarget], elabReplTarget :: Maybe ComponentTarget, + elabHaddockTargets :: [ComponentTarget], + elabBuildHaddocks :: Bool, --pkgSourceDir ? -- currently passed in later because they can use temp locations @@ -303,6 +314,29 @@ } deriving (Eq, Show, Generic, Typeable) +normaliseConfiguredPackage :: ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> ElaboratedConfiguredPackage +normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg = + pkg { elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg) } + where + knownProgramDb = addKnownPrograms builtinPrograms pkgConfigCompilerProgs + + pkgDesc :: PackageDescription + pkgDesc = elabPkgDescription pkg + + removeEmpty :: [String] -> Maybe [String] + removeEmpty [] = Nothing + removeEmpty xs = Just xs + + lookupFilter :: String -> [String] -> Maybe [String] + lookupFilter n args = removeEmpty $ case lookupKnownProgram n knownProgramDb of + Just p -> programNormaliseArgs p (getVersion p) pkgDesc args + Nothing -> args + + getVersion :: Program -> Maybe Version + getVersion p = lookupProgram p knownProgramDb >>= programVersion + -- | The package/component contains/is a library and so must be registered elabRequiresRegistration :: ElaboratedConfiguredPackage -> Bool elabRequiresRegistration elab = @@ -702,6 +736,22 @@ showBenchComponentTarget :: PackageId -> ComponentTarget -> Maybe String showBenchComponentTarget _ (ComponentTarget (CBenchName n) _) = Just $ display n showBenchComponentTarget _ _ = Nothing + +isBenchComponentTarget :: ComponentTarget -> Bool +isBenchComponentTarget (ComponentTarget (CBenchName _) _) = True +isBenchComponentTarget _ = False + +isForeignLibComponentTarget :: ComponentTarget -> Bool +isForeignLibComponentTarget (ComponentTarget (CFLibName _) _) = True +isForeignLibComponentTarget _ = False + +isExeComponentTarget :: ComponentTarget -> Bool +isExeComponentTarget (ComponentTarget (CExeName _) _ ) = True +isExeComponentTarget _ = False + +isSubLibComponentTarget :: ComponentTarget -> Bool +isSubLibComponentTarget (ComponentTarget (CSubLibName _) _) = True +isSubLibComponentTarget _ = False --------------------------- -- Setup.hs script policy diff --git a/Distribution/Client/RebuildMonad.hs b/Distribution/Client/RebuildMonad.hs --- a/Distribution/Client/RebuildMonad.hs +++ b/Distribution/Client/RebuildMonad.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, BangPatterns #-} -- | An abstraction for re-running actions if values or files have changed. -- @@ -41,6 +41,8 @@ rerunIfChanged, -- * Utils + delayInitSharedResource, + delayInitSharedResources, matchFileGlob, getDirectoryContentsMonitored, createDirectoryMonitored, @@ -63,8 +65,10 @@ import Distribution.Simple.Utils (debug) import Distribution.Verbosity (Verbosity) +import qualified Data.Map.Strict as Map import Control.Monad.State as State import Control.Monad.Reader as Reader +import Control.Concurrent.MVar (MVar, newMVar, modifyMVar) import System.FilePath import System.Directory @@ -144,6 +148,76 @@ showReason (MonitoredValueChanged _) = "monitor value changed" showReason MonitorFirstRun = "first run" showReason MonitorCorruptCache = "invalid cache file" + + +-- | When using 'rerunIfChanged' for each element of a list of actions, it is +-- sometimes the case that each action needs to make use of some resource. e.g. +-- +-- > sequence +-- > [ rerunIfChanged verbosity monitor key $ do +-- > resource <- mkResource +-- > ... -- use the resource +-- > | ... ] +-- +-- For efficiency one would like to share the resource between the actions +-- but the straightforward way of doing this means initialising it every time +-- even when no actions need re-running. +-- +-- > resource <- mkResource +-- > sequence +-- > [ rerunIfChanged verbosity monitor key $ do +-- > ... -- use the resource +-- > | ... ] +-- +-- This utility allows one to get the best of both worlds: +-- +-- > getResource <- delayInitSharedResource mkResource +-- > sequence +-- > [ rerunIfChanged verbosity monitor key $ do +-- > resource <- getResource +-- > ... -- use the resource +-- > | ... ] +-- +delayInitSharedResource :: forall a. IO a -> Rebuild (Rebuild a) +delayInitSharedResource action = do + var <- liftIO (newMVar Nothing) + return (liftIO (getOrInitResource var)) + where + getOrInitResource :: MVar (Maybe a) -> IO a + getOrInitResource var = + modifyMVar var $ \mx -> + case mx of + Just x -> return (Just x, x) + Nothing -> do + x <- action + return (Just x, x) + + +-- | Much like 'delayInitSharedResource' but for a keyed set of resources. +-- +-- > getResource <- delayInitSharedResource mkResource +-- > sequence +-- > [ rerunIfChanged verbosity monitor key $ do +-- > resource <- getResource key +-- > ... -- use the resource +-- > | ... ] +-- +delayInitSharedResources :: forall k v. Ord k + => (k -> IO v) + -> Rebuild (k -> Rebuild v) +delayInitSharedResources action = do + var <- liftIO (newMVar Map.empty) + return (liftIO . getOrInitResource var) + where + getOrInitResource :: MVar (Map k v) -> k -> IO v + getOrInitResource var k = + modifyMVar var $ \m -> + case Map.lookup k m of + Just x -> return (m, x) + Nothing -> do + x <- action k + let !m' = Map.insert k x m + return (m', x) -- | Utility to match a file glob against the file system, starting from a diff --git a/Distribution/Client/Run.hs b/Distribution/Client/Run.hs --- a/Distribution/Client/Run.hs +++ b/Distribution/Client/Run.hs @@ -125,7 +125,7 @@ return (cmd, cmdArgs ++ [script']) _ -> do p <- tryCanonicalizePath $ - buildPref exeName' (exeName' <.> exeExtension) + buildPref exeName' (exeName' <.> exeExtension (hostPlatform lbi)) return (p, []) env <- (dataDirEnvVar:) <$> getEnvironment diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs --- a/Distribution/Client/Setup.hs +++ b/Distribution/Client/Setup.hs @@ -24,6 +24,7 @@ , replCommand, testCommand, benchmarkCommand , configureExOptions, reconfigureCommand , installCommand, InstallFlags(..), installOptions, defaultInstallFlags + , filterHaddockArgs, filterHaddockFlags , defaultSolver, defaultMaxBackjumps , listCommand, ListFlags(..) , updateCommand, UpdateFlags(..), defaultUpdateFlags @@ -48,8 +49,14 @@ , execCommand, ExecFlags(..), defaultExecFlags , userConfigCommand, UserConfigFlags(..) , manpageCommand + , haddockCommand + , cleanCommand + , doctestCommand + , copyCommand + , registerCommand , parsePackageArgs + , liftOptions --TODO: stop exporting these: , showRepo , parseRepo @@ -90,6 +97,8 @@ ( ConfigFlags(..), BuildFlags(..), ReplFlags , TestFlags(..), BenchmarkFlags(..) , SDistFlags(..), HaddockFlags(..) + , CleanFlags(..), DoctestFlags(..) + , CopyFlags(..), RegisterFlags(..) , readPackageDbList, showPackageDbList , Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag , BooleanFlag(..), optionVerbosity @@ -189,6 +198,44 @@ , "new-test" , "new-bench" , "new-haddock" + , "new-exec" + , "new-update" + , "new-install" + , "new-clean" + , "new-sdist" + -- v1 commands, stateful style + , "v1-build" + , "v1-configure" + , "v1-repl" + , "v1-freeze" + , "v1-run" + , "v1-test" + , "v1-bench" + , "v1-haddock" + , "v1-exec" + , "v1-update" + , "v1-install" + , "v1-clean" + , "v1-sdist" + , "v1-doctest" + , "v1-copy" + , "v1-register" + , "v1-reconfigure" + , "v1-sandbox" + -- v2 commands, nix-style + , "v2-build" + , "v2-configure" + , "v2-repl" + , "v2-freeze" + , "v2-run" + , "v2-test" + , "v2-bench" + , "v2-haddock" + , "v2-exec" + , "v2-update" + , "v2-install" + , "v2-clean" + , "v2-sdist" ] maxlen = maximum $ [length name | (name, _) <- cmdDescs] align str = str ++ replicate (maxlen - length str) ' ' @@ -256,6 +303,46 @@ , addCmd "new-bench" , addCmd "new-freeze" , addCmd "new-haddock" + , addCmd "new-exec" + , addCmd "new-update" + , addCmd "new-install" + , addCmd "new-clean" + , addCmd "new-sdist" + , par + , startGroup "new-style projects (forwards-compatible aliases)" + , addCmd "v2-build" + , addCmd "v2-configure" + , addCmd "v2-repl" + , addCmd "v2-run" + , addCmd "v2-test" + , addCmd "v2-bench" + , addCmd "v2-freeze" + , addCmd "v2-haddock" + , addCmd "v2-exec" + , addCmd "v2-update" + , addCmd "v2-install" + , addCmd "v2-clean" + , addCmd "v2-sdist" + , par + , startGroup "legacy command aliases" + , addCmd "v1-build" + , addCmd "v1-configure" + , addCmd "v1-repl" + , addCmd "v1-run" + , addCmd "v1-test" + , addCmd "v1-bench" + , addCmd "v1-freeze" + , addCmd "v1-haddock" + , addCmd "v1-exec" + , addCmd "v1-update" + , addCmd "v1-install" + , addCmd "v1-clean" + , addCmd "v1-sdist" + , addCmd "v1-doctest" + , addCmd "v1-copy" + , addCmd "v1-register" + , addCmd "v1-reconfigure" + , addCmd "v1-sandbox" ] ++ if null otherCmds then [] else par :startGroup "other" :[addCmd n | n <- otherCmds]) @@ -349,7 +436,7 @@ globalLocalRepos (\v flags -> flags { globalLocalRepos = v }) (reqArg' "DIR" (\x -> toNubList [x]) fromNubList) - ,option [] ["logs-dir"] + ,option [] ["logs-dir", "logsdir"] "The location to put log files" globalLogsDir (\v flags -> flags { globalLogsDir = v }) (reqArgFlag "DIR") @@ -359,7 +446,7 @@ globalWorldFile (\v flags -> flags { globalWorldFile = v }) (reqArgFlag "FILE") - ,option [] ["store-dir"] + ,option [] ["store-dir", "storedir"] "The location of the nix-local-build store" globalStoreDir (\v flags -> flags { globalStoreDir = v }) (reqArgFlag "DIR") @@ -371,16 +458,24 @@ configureCommand :: CommandUI ConfigFlags configureCommand = c - { commandDefaultFlags = mempty - , commandNotes = Just $ \pname -> (case commandNotes c of - Nothing -> "" - Just n -> n pname ++ "\n") - ++ "Examples:\n" - ++ " " ++ pname ++ " configure\n" - ++ " Configure with defaults;\n" - ++ " " ++ pname ++ " configure --enable-tests -fcustomflag\n" - ++ " Configure building package including tests,\n" - ++ " with some package-specific flag.\n" + { commandName = "configure" + , commandDefaultFlags = mempty + , commandDescription = Just $ \_ -> wrapText $ + "Configure how the package is built by setting " + ++ "package (and other) flags.\n" + ++ "\n" + ++ "The configuration affects several other commands, " + ++ "including v1-build, v1-test, v1-bench, v1-run, v1-repl.\n" + , commandUsage = \pname -> + "Usage: " ++ pname ++ " v1-configure [FLAGS]\n" + , commandNotes = Just $ \pname -> + (Cabal.programFlagsDescription defaultProgramDb ++ "\n") + ++ "Examples:\n" + ++ " " ++ pname ++ " v1-configure\n" + ++ " Configure with defaults;\n" + ++ " " ++ pname ++ " v1-configure --enable-tests -fcustomflag\n" + ++ " Configure building package including tests,\n" + ++ " with some package-specific flag.\n" } where c = Cabal.configureCommand defaultProgramDb @@ -613,17 +708,17 @@ , commandDescription = Just $ \pname -> wrapText $ "Run `configure` with the most recently used flags, or append FLAGS " ++ "to the most recently used configuration. " - ++ "Accepts the same flags as `" ++ pname ++ " configure'. " + ++ "Accepts the same flags as `" ++ pname ++ " v1-configure'. " ++ "If the package has never been configured, the default flags are " ++ "used." , commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " reconfigure\n" + ++ " " ++ pname ++ " v1-reconfigure\n" ++ " Configure with the most recently used flags.\n" - ++ " " ++ pname ++ " reconfigure -w PATH\n" + ++ " " ++ pname ++ " v1-reconfigure -w PATH\n" ++ " Reconfigure with the most recently used flags,\n" ++ " but use the compiler at PATH.\n\n" - , commandUsage = usageAlternatives "reconfigure" [ "[FLAGS]" ] + , commandUsage = usageAlternatives "v1-reconfigure" [ "[FLAGS]" ] , commandDefaultFlags = mempty } @@ -650,12 +745,26 @@ buildCommand :: CommandUI (BuildFlags, BuildExFlags) buildCommand = parent { + commandName = "build", + commandDescription = Just $ \_ -> wrapText $ + "Components encompass executables, tests, and benchmarks.\n" + ++ "\n" + ++ "Affected by configuration options, see `v1-configure`.\n", commandDefaultFlags = (commandDefaultFlags parent, mempty), + commandUsage = usageAlternatives "v1-build" $ + [ "[FLAGS]", "COMPONENTS [FLAGS]" ], commandOptions = \showOrParseArgs -> liftOptions fst setFst (commandOptions parent showOrParseArgs) ++ liftOptions snd setSnd (buildExOptions showOrParseArgs) + , commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v1-build " + ++ " All the components in the package\n" + ++ " " ++ pname ++ " v1-build foo " + ++ " A component (i.e. lib, exe, test suite)\n\n" + ++ Cabal.programFlagsDescription defaultProgramDb } where setFst a (_,b) = (a,b) @@ -676,12 +785,40 @@ replCommand :: CommandUI (ReplFlags, BuildExFlags) replCommand = parent { + commandName = "repl", + commandDescription = Just $ \pname -> wrapText $ + "If the current directory contains no package, ignores COMPONENT " + ++ "parameters and opens an interactive interpreter session; if a " + ++ "sandbox is present, its package database will be used.\n" + ++ "\n" + ++ "Otherwise, (re)configures with the given or default flags, and " + ++ "loads the interpreter with the relevant modules. For executables, " + ++ "tests and benchmarks, loads the main module (and its " + ++ "dependencies); for libraries all exposed/other modules.\n" + ++ "\n" + ++ "The default component is the library itself, or the executable " + ++ "if that is the only component.\n" + ++ "\n" + ++ "Support for loading specific modules is planned but not " + ++ "implemented yet. For certain scenarios, `" ++ pname + ++ " v1-exec -- ghci :l Foo` may be used instead. Note that `v1-exec` will " + ++ "not (re)configure and you will have to specify the location of " + ++ "other modules, if required.\n", + commandUsage = \pname -> "Usage: " ++ pname ++ " v1-repl [COMPONENT] [FLAGS]\n", commandDefaultFlags = (commandDefaultFlags parent, mempty), commandOptions = \showOrParseArgs -> liftOptions fst setFst (commandOptions parent showOrParseArgs) ++ - liftOptions snd setSnd (buildExOptions showOrParseArgs) + liftOptions snd setSnd (buildExOptions showOrParseArgs), + commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v1-repl " + ++ " The first component in the package\n" + ++ " " ++ pname ++ " v1-repl foo " + ++ " A named component (i.e. lib, exe, test suite)\n" + ++ " " ++ pname ++ " v1-repl --ghc-options=\"-lstdc++\"" + ++ " Specifying flags for interpreter\n" } where setFst a (_,b) = (a,b) @@ -695,6 +832,19 @@ testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags) testCommand = parent { + commandName = "test", + commandDescription = Just $ \pname -> wrapText $ + "If necessary (re)configures with `--enable-tests` flag and builds" + ++ " the test suite.\n" + ++ "\n" + ++ "Remember that the tests' dependencies must be installed if there" + ++ " are additional ones; e.g. with `" ++ pname + ++ " v1-install --only-dependencies --enable-tests`.\n" + ++ "\n" + ++ "By defining UserHooks in a custom Setup.hs, the package can" + ++ " define actions to be executed before and after running tests.\n", + commandUsage = usageAlternatives "v1-test" + [ "[FLAGS]", "TESTCOMPONENTS [FLAGS]" ], commandDefaultFlags = (commandDefaultFlags parent, Cabal.defaultBuildFlags, mempty), commandOptions = @@ -720,6 +870,20 @@ benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags) benchmarkCommand = parent { + commandName = "bench", + commandUsage = usageAlternatives "v1-bench" + [ "[FLAGS]", "BENCHCOMPONENTS [FLAGS]" ], + commandDescription = Just $ \pname -> wrapText $ + "If necessary (re)configures with `--enable-benchmarks` flag and" + ++ " builds the benchmarks.\n" + ++ "\n" + ++ "Remember that the benchmarks' dependencies must be installed if" + ++ " there are additional ones; e.g. with `" ++ pname + ++ " v1-install --only-dependencies --enable-benchmarks`.\n" + ++ "\n" + ++ "By defining UserHooks in a custom Setup.hs, the package can" + ++ " define actions to be executed before and after running" + ++ " benchmarks.\n", commandDefaultFlags = (commandDefaultFlags parent, Cabal.defaultBuildFlags, mempty), commandOptions = @@ -967,6 +1131,7 @@ outdatedVerbosity :: Flag Verbosity, outdatedFreezeFile :: Flag Bool, outdatedNewFreezeFile :: Flag Bool, + outdatedProjectFile :: Flag FilePath, outdatedSimpleOutput :: Flag Bool, outdatedExitCode :: Flag Bool, outdatedQuiet :: Flag Bool, @@ -979,6 +1144,7 @@ outdatedVerbosity = toFlag normal, outdatedFreezeFile = mempty, outdatedNewFreezeFile = mempty, + outdatedProjectFile = mempty, outdatedSimpleOutput = mempty, outdatedExitCode = mempty, outdatedQuiet = mempty, @@ -1000,16 +1166,21 @@ optionVerbosity outdatedVerbosity (\v flags -> flags { outdatedVerbosity = v }) - ,option [] ["freeze-file"] + ,option [] ["freeze-file", "v1-freeze-file"] "Act on the freeze file" outdatedFreezeFile (\v flags -> flags { outdatedFreezeFile = v }) trueArg - ,option [] ["new-freeze-file"] - "Act on the new-style freeze file" + ,option [] ["new-freeze-file", "v2-freeze-file"] + "Act on the new-style freeze file (default: cabal.project.freeze)" outdatedNewFreezeFile (\v flags -> flags { outdatedNewFreezeFile = v }) trueArg + ,option [] ["project-file"] + "Act on the new-style freeze file named PROJECTFILE.freeze rather than the default cabal.project.freeze" + outdatedProjectFile (\v flags -> flags { outdatedProjectFile = v }) + (reqArgFlag "PROJECTFILE") + ,option [] ["simple-output"] "Only print names of outdated dependencies, one per line" outdatedSimpleOutput (\v flags -> flags { outdatedSimpleOutput = v }) @@ -1080,7 +1251,7 @@ relevantConfigValuesText ["remote-repo" ,"remote-repo-cache" ,"local-repo"], - commandUsage = usageFlags "update", + commandUsage = usageFlags "v1-update", commandDefaultFlags = defaultUpdateFlags, commandOptions = \_ -> [ optionVerbosity updateVerbosity (\v flags -> flags { updateVerbosity = v }), @@ -1112,16 +1283,11 @@ commandOptions = commandOptions installCommand } -{- -cleanCommand :: CommandUI () -cleanCommand = makeCommand name shortDesc longDesc emptyFlags options - where - name = "clean" - shortDesc = "Removes downloaded files" - longDesc = Nothing - emptyFlags = () - options _ = [] --} +cleanCommand :: CommandUI CleanFlags +cleanCommand = Cabal.cleanCommand + { commandUsage = \pname -> + "Usage: " ++ pname ++ " v1-clean [FLAGS]\n" + } checkCommand :: CommandUI (Flag Verbosity) checkCommand = CommandUI { @@ -1134,9 +1300,9 @@ ++ "If no errors and warnings are reported, Hackage will accept this " ++ "package.\n", commandNotes = Nothing, - commandUsage = \pname -> "Usage: " ++ pname ++ " check\n", + commandUsage = usageFlags "check", commandDefaultFlags = toFlag normal, - commandOptions = \_ -> [] + commandOptions = \_ -> [optionVerbosity id const] } formatCommand :: CommandUI (Flag Verbosity) @@ -1182,15 +1348,15 @@ ++ "specified, but the package contains just one executable, that one " ++ "is built and executed.\n" ++ "\n" - ++ "Use `" ++ pname ++ " test --show-details=streaming` to run a " + ++ "Use `" ++ pname ++ " v1-test --show-details=streaming` to run a " ++ "test-suite and get its full output.\n", commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " run\n" + ++ " " ++ pname ++ " v1-run\n" ++ " Run the only executable in the current package;\n" - ++ " " ++ pname ++ " run foo -- --fooflag\n" + ++ " " ++ pname ++ " v1-run foo -- --fooflag\n" ++ " Works similar to `./foo --fooflag`.\n", - commandUsage = usageAlternatives "run" + commandUsage = usageAlternatives "v1-run" ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"], commandDefaultFlags = mempty, commandOptions = @@ -1568,7 +1734,7 @@ installCommand = CommandUI { commandName = "install", commandSynopsis = "Install packages.", - commandUsage = usageAlternatives "install" [ "[FLAGS]" + commandUsage = usageAlternatives "v1-install" [ "[FLAGS]" , "[FLAGS] PACKAGES" ], commandDescription = Just $ \_ -> wrapText $ @@ -1581,12 +1747,12 @@ ++ " dependencies) (there must be exactly one .cabal file in the current" ++ " directory).\n" ++ "\n" - ++ "When using a sandbox, the flags for `install` only affect the" + ++ "When using a sandbox, the flags for `v1-install` only affect the" ++ " current command and have no effect on future commands. (To achieve" - ++ " that, `configure` must be used.)\n" - ++ " In contrast, without a sandbox, the flags to `install` are saved and" - ++ " affect future commands such as `build` and `repl`. See the help for" - ++ " `configure` for a list of commands being affected.\n" + ++ " that, `v1-configure` must be used.)\n" + ++ " In contrast, without a sandbox, the flags to `v1-install` are saved and" + ++ " affect future commands such as `v1-build` and `v1-repl`. See the help for" + ++ " `v1-configure` for a list of commands being affected.\n" ++ "\n" ++ "Installed executables will by default (and without a sandbox)" ++ " be put into `~/.cabal/bin/`." @@ -1605,15 +1771,15 @@ Nothing -> "" ) ++ "Examples:\n" - ++ " " ++ pname ++ " install " + ++ " " ++ pname ++ " v1-install " ++ " Package in the current directory\n" - ++ " " ++ pname ++ " install foo " + ++ " " ++ pname ++ " v1-install foo " ++ " Package from the hackage server\n" - ++ " " ++ pname ++ " install foo-1.0 " + ++ " " ++ pname ++ " v1-install foo-1.0 " ++ " Specific version of a package\n" - ++ " " ++ pname ++ " install 'foo < 2' " + ++ " " ++ pname ++ " v1-install 'foo < 2' " ++ " Constrained package version\n" - ++ " " ++ pname ++ " install haddock --bindir=$HOME/hask-bin/ --datadir=$HOME/hask-data/\n" + ++ " " ++ pname ++ " v1-install haddock --bindir=$HOME/hask-bin/ --datadir=$HOME/hask-data/\n" ++ " " ++ (map (const ' ') pname) ++ " " ++ " Change installation destination\n", @@ -1642,6 +1808,36 @@ get3 (_,_,c,_) = c; set3 c (a,b,_,d) = (a,b,c,d) get4 (_,_,_,d) = d; set4 d (a,b,c,_) = (a,b,c,d) +haddockCommand :: CommandUI HaddockFlags +haddockCommand = Cabal.haddockCommand + { commandUsage = usageAlternatives "v1-haddock" $ + [ "[FLAGS]", "COMPONENTS [FLAGS]" ] + } + +filterHaddockArgs :: [String] -> Version -> [String] +filterHaddockArgs args cabalLibVersion + | cabalLibVersion >= mkVersion [2,3,0] = args_latest + | cabalLibVersion < mkVersion [2,3,0] = args_2_3_0 + | otherwise = args_latest + where + args_latest = args + + -- Cabal < 2.3 doesn't know about per-component haddock + args_2_3_0 = [] + +filterHaddockFlags :: HaddockFlags -> Version -> HaddockFlags +filterHaddockFlags flags cabalLibVersion + | cabalLibVersion >= mkVersion [2,3,0] = flags_latest + | cabalLibVersion < mkVersion [2,3,0] = flags_2_3_0 + | otherwise = flags_latest + where + flags_latest = flags + + flags_2_3_0 = flags_latest { + -- Cabal < 2.3 doesn't know about per-component haddock + haddockArgs = [] + } + haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags] haddockOptions showOrParseArgs = [ opt { optionName = "haddock-" ++ name, @@ -1651,7 +1847,7 @@ , let name = optionName opt , name `elem` ["hoogle", "html", "html-location" ,"executables", "tests", "benchmarks", "all", "internal", "css" - ,"hyperlink-source", "hscolour-css" + ,"hyperlink-source", "quickjump", "hscolour-css" ,"contents-location", "for-hackage"] ] where @@ -1956,7 +2152,7 @@ IT.overwrite (\v flags -> flags { IT.overwrite = v }) trueArg - , option [] ["package-dir"] + , option [] ["package-dir", "packagedir"] "Root directory of the package (default = current directory)." IT.packageDir (\v flags -> flags { IT.packageDir = v }) (reqArgFlag "DIRECTORY") @@ -2075,7 +2271,7 @@ ((Just . (:[])) `fmap` parse)) (maybe [] (fmap display))) - , option [] ["source-dir"] + , option [] ["source-dir", "sourcedir"] "Directory containing package source." IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v }) (reqArg' "DIR" (Just . (:[])) @@ -2112,6 +2308,8 @@ sdistCommand :: CommandUI (SDistFlags, SDistExFlags) sdistCommand = Cabal.sdistCommand { + commandUsage = \pname -> + "Usage: " ++ pname ++ " v1-sdist [FLAGS]\n", commandDefaultFlags = (commandDefaultFlags Cabal.sdistCommand, defaultSDistExFlags), commandOptions = \showOrParseArgs -> liftOptions fst setFst (commandOptions Cabal.sdistCommand showOrParseArgs) @@ -2139,6 +2337,30 @@ instance Semigroup SDistExFlags where (<>) = gmappend +-- + +doctestCommand :: CommandUI DoctestFlags +doctestCommand = Cabal.doctestCommand + { commandUsage = \pname -> "Usage: " ++ pname ++ " v1-doctest [FLAGS]\n" } + +copyCommand :: CommandUI CopyFlags +copyCommand = Cabal.copyCommand + { commandNotes = Just $ \pname -> + "Examples:\n" + ++ " " ++ pname ++ " v1-copy " + ++ " All the components in the package\n" + ++ " " ++ pname ++ " v1-copy foo " + ++ " A component (i.e. lib, exe, test suite)" + , commandUsage = usageAlternatives "v1-copy" $ + [ "[FLAGS]" + , "COMPONENTS [FLAGS]" + ] + } + +registerCommand :: CommandUI RegisterFlags +registerCommand = Cabal.registerCommand + { commandUsage = \pname -> "Usage: " ++ pname ++ " v1-register [FLAGS]\n" } + -- ------------------------------------------------------------ -- * Win32SelfUpgrade flags -- ------------------------------------------------------------ @@ -2244,11 +2466,11 @@ ++ " packages are installed in the same database (i.e. the user's" ++ " database in the home directory)." , paragraph $ "A sandbox in the current directory (created by" - ++ " `sandbox init`) will be used instead of the user's database for" - ++ " commands such as `install` and `build`. Note that (a directly" + ++ " `v1-sandbox init`) will be used instead of the user's database for" + ++ " commands such as `v1-install` and `v1-build`. Note that (a directly" ++ " invoked) GHC will not automatically be aware of sandboxes;" ++ " only if called via appropriate " ++ pname - ++ " commands, e.g. `repl`, `build`, `exec`." + ++ " commands, e.g. `v1-repl`, `v1-build`, `v1-exec`." , paragraph $ "Currently, " ++ pname ++ " will not search for a sandbox" ++ " in folders above the current one, so cabal will not see the sandbox" ++ " if you are in a subfolder of a sandbox." @@ -2274,16 +2496,16 @@ , indentParagraph $ "Remove an add-source dependency; however, this will" ++ " not delete the package(s) that have been installed in the sandbox" ++ " from this dependency. You can either unregister the package(s) via" - ++ " `" ++ pname ++ " sandbox hc-pkg unregister` or re-create the" - ++ " sandbox (`sandbox delete; sandbox init`)." + ++ " `" ++ pname ++ " v1-sandbox hc-pkg unregister` or re-create the" + ++ " sandbox (`v1-sandbox delete; v1-sandbox init`)." , headLine "list-sources:" , indentParagraph $ "List the directories of local packages made" - ++ " available via `" ++ pname ++ " add-source`." + ++ " available via `" ++ pname ++ " v1-sandbox add-source`." , headLine "hc-pkg:" , indentParagraph $ "Similar to `ghc-pkg`, but for the sandbox package" ++ " database. Can be used to list specific/all packages that are" ++ " installed in the sandbox. For subcommands, see the help for" - ++ " ghc-pkg. Affected by the compiler version specified by `configure`." + ++ " ghc-pkg. Affected by the compiler version specified by `v1-configure`." ], commandNotes = Just $ \pname -> relevantConfigValuesText ["require-sandbox" @@ -2291,18 +2513,18 @@ ++ "\n" ++ "Examples:\n" ++ " Set up a sandbox with one local dependency, located at ../foo:\n" - ++ " " ++ pname ++ " sandbox init\n" - ++ " " ++ pname ++ " sandbox add-source ../foo\n" - ++ " " ++ pname ++ " install --only-dependencies\n" + ++ " " ++ pname ++ " v1-sandbox init\n" + ++ " " ++ pname ++ " v1-sandbox add-source ../foo\n" + ++ " " ++ pname ++ " v1-install --only-dependencies\n" ++ " Reset the sandbox:\n" - ++ " " ++ pname ++ " sandbox delete\n" - ++ " " ++ pname ++ " sandbox init\n" - ++ " " ++ pname ++ " install --only-dependencies\n" + ++ " " ++ pname ++ " v1-sandbox delete\n" + ++ " " ++ pname ++ " v1-sandbox init\n" + ++ " " ++ pname ++ " v1-install --only-dependencies\n" ++ " List the packages in the sandbox:\n" - ++ " " ++ pname ++ " sandbox hc-pkg list\n" + ++ " " ++ pname ++ " v1-sandbox hc-pkg list\n" ++ " Unregister the `broken` package from the sandbox:\n" - ++ " " ++ pname ++ " sandbox hc-pkg -- --force unregister broken\n", - commandUsage = usageAlternatives "sandbox" + ++ " " ++ pname ++ " v1-sandbox hc-pkg -- --force unregister broken\n", + commandUsage = usageAlternatives "v1-sandbox" [ "init [FLAGS]" , "delete [FLAGS]" , "add-source [FLAGS] PATHS" @@ -2358,7 +2580,7 @@ -- TODO: this is too GHC-focused for my liking.. "A directly invoked GHC will not automatically be aware of any" ++ " sandboxes: the GHC_PACKAGE_PATH environment variable controls what" - ++ " GHC uses. `" ++ pname ++ " exec` can be used to modify this variable:" + ++ " GHC uses. `" ++ pname ++ " v1-exec` can be used to modify this variable:" ++ " COMMAND will be executed in a modified environment and thereby uses" ++ " the sandbox package database.\n" ++ "\n" @@ -2366,26 +2588,26 @@ ++ "\n" ++ "Note that other " ++ pname ++ " commands change the environment" ++ " variable appropriately already, so there is no need to wrap those" - ++ " in `" ++ pname ++ " exec`. But with `" ++ pname ++ " exec`, the user" + ++ " in `" ++ pname ++ " v1-exec`. But with `" ++ pname ++ " v1-exec`, the user" ++ " has more control and can, for example, execute custom scripts which" ++ " indirectly execute GHC.\n" ++ "\n" - ++ "Note that `" ++ pname ++ " repl` is different from `" ++ pname - ++ " exec -- ghci` as the latter will not forward any additional flags" + ++ "Note that `" ++ pname ++ " v1-repl` is different from `" ++ pname + ++ " v1-exec -- ghci` as the latter will not forward any additional flags" ++ " being defined in the local package to ghci.\n" ++ "\n" ++ "See `" ++ pname ++ " sandbox`.\n", commandNotes = Just $ \pname -> "Examples:\n" - ++ " " ++ pname ++ " exec -- ghci -Wall\n" + ++ " " ++ pname ++ " v1-exec -- ghci -Wall\n" ++ " Start a repl session with sandbox packages and all warnings;\n" - ++ " " ++ pname ++ " exec gitit -- -f gitit.cnf\n" + ++ " " ++ pname ++ " v1-exec gitit -- -f gitit.cnf\n" ++ " Give gitit access to the sandbox packages, and pass it a flag;\n" - ++ " " ++ pname ++ " exec runghc Foo.hs\n" + ++ " " ++ pname ++ " v1-exec runghc Foo.hs\n" ++ " Execute runghc on Foo.hs with runghc configured to use the\n" ++ " sandbox package database (if a sandbox is being used).\n", commandUsage = \pname -> - "Usage: " ++ pname ++ " exec [FLAGS] [--] COMMAND [--] [ARGS]\n", + "Usage: " ++ pname ++ " v1-exec [FLAGS] [--] COMMAND [--] [ARGS]\n", commandDefaultFlags = defaultExecFlags, commandOptions = \showOrParseArgs -> diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs --- a/Distribution/Client/SetupWrapper.hs +++ b/Distribution/Client/SetupWrapper.hs @@ -33,7 +33,8 @@ , withinRange ) import qualified Distribution.Backpack as Backpack import Distribution.Package - ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId, PackageId, mkPackageName + ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId + , PackageId, mkPackageName , PackageIdentifier(..), packageVersion, packageName ) import Distribution.Types.Dependency import Distribution.PackageDescription @@ -57,7 +58,8 @@ , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram , ghcjsProgram ) import Distribution.Simple.Program.Find - ( programSearchPathAsPATHVar, ProgramSearchPathEntry(ProgramSearchPathDir) ) + ( programSearchPathAsPATHVar + , ProgramSearchPathEntry(ProgramSearchPathDir) ) import Distribution.Simple.Program.Run ( getEffectiveEnvironment ) import qualified Distribution.Simple.Program.Strip as Strip @@ -73,7 +75,7 @@ import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Client.Types import Distribution.Client.Config - ( defaultCabalDir ) + ( getCabalDir ) import Distribution.Client.IndexUtils ( getInstalledPackages ) import Distribution.Client.JobControl @@ -81,7 +83,8 @@ import Distribution.Simple.Setup ( Flag(..) ) import Distribution.Simple.Utils - ( die', debug, info, infoNoWrap, cabalVersion, tryFindPackageDesc, comparing + ( die', debug, info, infoNoWrap + , cabalVersion, tryFindPackageDesc, comparing , createDirectoryIfMissingVerbose, installExecutableFile , copyFileVerbose, rewriteFileEx ) import Distribution.Client.Utils @@ -389,7 +392,7 @@ runSetupCommand :: Verbosity -> Setup -> CommandUI flags -- ^ command definition -> flags -- ^ command flags - -> [String] -- ^ extra command-line arguments + -> [String] -- ^ extra command-line arguments -> IO () runSetupCommand verbosity setup cmd flags extraArgs = do let args = commandName cmd : commandShowOptions cmd flags ++ extraArgs @@ -403,11 +406,13 @@ -> CommandUI flags -> (Version -> flags) -- ^ produce command flags given the Cabal library version - -> [String] + -> (Version -> [String]) -> IO () setupWrapper verbosity options mpkg cmd flags extraArgs = do setup <- getSetup verbosity options mpkg - runSetupCommand verbosity setup cmd (flags $ setupVersion setup) extraArgs + runSetupCommand verbosity setup + cmd (flags $ setupVersion setup) + (extraArgs $ setupVersion setup) -- ------------------------------------------------------------ -- * Internal SetupMethod @@ -537,7 +542,7 @@ doInvoke moveOutOfTheWay tmpDir path' = do - let newPath = tmpDir "setup" <.> exeExtension + let newPath = tmpDir "setup" <.> exeExtension buildPlatform Win32.moveFile path' newPath return newPath @@ -589,7 +594,7 @@ setupDir = workingDir options useDistPref options "setup" setupVersionFile = setupDir "setup" <.> "version" setupHs = setupDir "setup" <.> "hs" - setupProgFile = setupDir "setup" <.> exeExtension + setupProgFile = setupDir "setup" <.> exeExtension buildPlatform platform = fromMaybe buildPlatform (usePlatform options) useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make) @@ -634,8 +639,8 @@ case savedVer of Just version | version `withinRange` useCabalVersion options -> do updateSetupScript version bt - -- Does the previously compiled setup executable still exist - -- and is it up-to date? + -- Does the previously compiled setup executable + -- still exist and is it up-to date? useExisting <- canUseExistingSetup version if useExisting then return (version, Nothing, options) @@ -664,7 +669,8 @@ ,SetupScriptOptions) installedVersion = do (comp, progdb, options') <- configureCompiler options - (version, mipkgid, options'') <- installedCabalVersion options' comp progdb + (version, mipkgid, options'') <- installedCabalVersion options' + comp progdb updateSetupScript version bt writeSetupVersionFile version return (version, mipkgid, options'') @@ -713,7 +719,8 @@ return (packageVersion pkg, Nothing, options') installedCabalVersion options' compiler progdb = do index <- maybeGetInstalledPackages options' compiler progdb - let cabalDep = Dependency (mkPackageName "Cabal") (useCabalVersion options') + let cabalDep = Dependency (mkPackageName "Cabal") + (useCabalVersion options') options'' = options' { usePackageIndex = Just index } case PackageIndex.lookupDependency index cabalDep of [] -> die' verbosity $ "The package '" ++ display (packageName pkg) @@ -775,14 +782,14 @@ cachedSetupDirAndProg :: SetupScriptOptions -> Version -> IO (FilePath, FilePath) cachedSetupDirAndProg options' cabalLibVersion = do - cabalDir <- defaultCabalDir + cabalDir <- getCabalDir let setupCacheDir = cabalDir "setup-exe-cache" cachedSetupProgFile = setupCacheDir ("setup-" ++ buildTypeString ++ "-" ++ cabalVersionString ++ "-" ++ platformString ++ "-" ++ compilerVersionString) - <.> exeExtension + <.> exeExtension buildPlatform return (setupCacheDir, cachedSetupProgFile) where buildTypeString = show bt @@ -823,7 +830,7 @@ cachedSetupProgFile return cachedSetupProgFile where - criticalSection' = maybe id criticalSection $ setupCacheLock options' + criticalSection' = maybe id criticalSection $ setupCacheLock options' -- | If the Setup.hs is out of date wrt the executable then recompile it. -- Currently this is GHC/GHCJS only. It should really be generalised. @@ -860,16 +867,19 @@ selectedDeps | useDependenciesExclusive options' = useDependencies options' | otherwise = useDependencies options' ++ - if any (isCabalPkgId . snd) (useDependencies options') + if any (isCabalPkgId . snd) + (useDependencies options') then [] else cabalDep addRenaming (ipid, _) = -- Assert 'DefUnitId' invariant - (Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)), defaultRenaming) + (Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid)) + ,defaultRenaming) cppMacrosFile = setupDir "setup_macros.h" ghcOptions = mempty { -- Respect -v0, but don't crank up verbosity on GHC if - -- Cabal verbosity is requested. For that, use --ghc-option=-v instead! + -- Cabal verbosity is requested. For that, use + -- --ghc-option=-v instead! ghcOptVerbosity = Flag (min verbosity normal) , ghcOptMode = Flag GhcModeMake , ghcOptInputFiles = toNubListR [setupHs] @@ -886,7 +896,7 @@ , ghcOptPackages = toNubListR $ map addRenaming selectedDeps , ghcOptCppIncludes = toNubListR [ cppMacrosFile | useVersionMacros options' ] - , ghcOptExtra = toNubListR extraOpts + , ghcOptExtra = extraOpts } let ghcCmdLine = renderGhcOptions compiler platform ghcOptions when (useVersionMacros options') $ @@ -895,7 +905,8 @@ case useLoggingHandle options of Nothing -> runDbProgram verbosity program progdb ghcCmdLine - -- If build logging is enabled, redirect compiler output to the log file. + -- If build logging is enabled, redirect compiler output to + -- the log file. (Just logHandle) -> do output <- getDbProgramOutput verbosity program progdb ghcCmdLine hPutStr logHandle output diff --git a/Distribution/Client/SrcDist.hs b/Distribution/Client/SrcDist.hs --- a/Distribution/Client/SrcDist.hs +++ b/Distribution/Client/SrcDist.hs @@ -69,7 +69,7 @@ -- Run 'setup sdist --output-directory=tmpDir' (or -- '--list-source'/'--output-directory=someOtherDir') in case we were passed -- those options. - setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags') [] + setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags') (const []) -- Unless we were given --list-sources or --output-directory ourselves, -- create an archive. @@ -176,7 +176,7 @@ doListSources :: IO [FilePath] doListSources = do - setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags) [] + setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags) (const []) fmap lines . readFile $ file onFailedListSources :: IOException -> IO () diff --git a/Distribution/Client/TargetSelector.hs b/Distribution/Client/TargetSelector.hs --- a/Distribution/Client/TargetSelector.hs +++ b/Distribution/Client/TargetSelector.hs @@ -27,7 +27,7 @@ TargetSelectorProblem(..), reportTargetSelectorProblems, showTargetSelector, - TargetString, + TargetString(..), showTargetString, parseTargetString, -- ** non-IO @@ -84,7 +84,8 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Control.Arrow ((&&&)) -import Control.Monad +import Control.Monad + hiding ( mfilter ) import qualified Distribution.Compat.ReadP as Parse import Distribution.Compat.ReadP ( (+++), (<++) ) @@ -201,20 +202,27 @@ -- the available packages (and their locations). -- readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))] + -> Maybe ComponentKindFilter + -- ^ This parameter is used when there are ambiguous selectors. + -- If it is 'Just', then we attempt to resolve ambiguitiy + -- by applying it, since otherwise there is no way to allow + -- contextually valid yet syntactically ambiguous selectors. + -- (#4676, #5461) -> [String] -> IO (Either [TargetSelectorProblem] [TargetSelector]) readTargetSelectors = readTargetSelectorsWith defaultDirActions readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m -> [PackageSpecifier (SourcePackage (PackageLocation a))] + -> Maybe ComponentKindFilter -> [String] -> m (Either [TargetSelectorProblem] [TargetSelector]) -readTargetSelectorsWith dirActions@DirActions{..} pkgs targetStrs = +readTargetSelectorsWith dirActions@DirActions{..} pkgs mfilter targetStrs = case parseTargetStrings targetStrs of ([], usertargets) -> do usertargets' <- mapM (getTargetStringFileStatus dirActions) usertargets knowntargets <- getKnownTargets dirActions pkgs - case resolveTargetSelectors knowntargets usertargets' of + case resolveTargetSelectors knowntargets usertargets' mfilter of ([], btargets) -> return (Right btargets) (problems, _) -> return (Left problems) (strs, _) -> return (Left (map TargetSelectorUnrecognised strs)) @@ -435,29 +443,31 @@ -- resolveTargetSelectors :: KnownTargets -> [TargetStringFileStatus] + -> Maybe ComponentKindFilter -> ([TargetSelectorProblem], [TargetSelector]) -- default local dir target if there's no given target: -resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] = +resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] _ = ([TargetSelectorNoTargetsInProject], []) -resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] = +resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] _ = ([TargetSelectorNoTargetsInCwd], []) -resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] = +resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ = ([], [TargetPackage TargetImplicitCwd pkgids Nothing]) where pkgids = [ pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary ] -resolveTargetSelectors knowntargets targetStrs = +resolveTargetSelectors knowntargets targetStrs mfilter = partitionEithers - . map (resolveTargetSelector knowntargets) + . map (resolveTargetSelector knowntargets mfilter) $ targetStrs resolveTargetSelector :: KnownTargets + -> Maybe ComponentKindFilter -> TargetStringFileStatus -> Either TargetSelectorProblem TargetSelector -resolveTargetSelector knowntargets@KnownTargets{..} targetStrStatus = +resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = case findMatch (matcher targetStrStatus) of Unambiguous _ @@ -472,6 +482,10 @@ | projectIsEmpty -> Left TargetSelectorNoTargetsInProject | otherwise -> Left (classifyMatchErrors errs) + Ambiguous _ targets + | Just kfilter <- mfilter + , [target] <- applyKindFilter kfilter targets -> Right target + Ambiguous exactMatch targets -> case disambiguateTargetSelectors matcher targetStrStatus exactMatch @@ -531,6 +545,21 @@ = innerErr (Just (kind,thing)) m innerErr c m = (c,m) + applyKindFilter :: ComponentKindFilter -> [TargetSelector] -> [TargetSelector] + applyKindFilter kfilter = filter go + where + go (TargetPackage _ _ (Just filter')) = kfilter == filter' + go (TargetPackageNamed _ (Just filter')) = kfilter == filter' + go (TargetAllPackages (Just filter')) = kfilter == filter' + go (TargetComponent _ cname _) + | CLibName <- cname = kfilter == LibKind + | CSubLibName _ <- cname = kfilter == LibKind + | CFLibName _ <- cname = kfilter == FLibKind + | CExeName _ <- cname = kfilter == ExeKind + | CTestName _ <- cname = kfilter == TestKind + | CBenchName _ <- cname = kfilter == BenchKind + go _ = True + -- | The various ways that trying to resolve a 'TargetString' to a -- 'TargetSelector' can fail. -- @@ -611,8 +640,9 @@ Left ( originalMatch , [ (forgetFileStatus rendering, matches) | rendering <- matchRenderings - , let (Match m _ matches) | m /= Inexact = + , let Match m _ matches = memoisedMatches Map.! rendering + , m /= Inexact ] ) | (originalMatch, matchRenderings) <- matchResultsRenderings ] diff --git a/Distribution/Client/Targets.hs b/Distribution/Client/Targets.hs --- a/Distribution/Client/Targets.hs +++ b/Distribution/Client/Targets.hs @@ -455,6 +455,14 @@ error "TODO: readPackageTarget RepoTarballPackage" -- For repo tarballs this info should be obtained from the index. + RemoteSourceRepoPackage _srcRepo _ -> + error "TODO: readPackageTarget RemoteSourceRepoPackage" + -- This can't happen, because it would have errored out already + -- in fetchPackage, via fetchPackageTarget before it gets to this + -- function. + -- + -- When that is corrected, this will also need to be fixed. + readTarballPackageTarget location tarballFile tarballOriginalLoc = do (filename, content) <- extractTarballPackageCabalFile tarballFile tarballOriginalLoc diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs --- a/Distribution/Client/Types.hs +++ b/Distribution/Client/Types.hs @@ -46,6 +46,8 @@ ( PackageName, mkPackageName ) import Distribution.Types.ComponentName ( ComponentName(..) ) +import Distribution.Types.SourceRepo + ( SourceRepo ) import Distribution.Solver.Types.PackageIndex ( PackageIndex ) @@ -234,7 +236,7 @@ -- | A fully specified source package. -- | SpecificSourcePackage pkg - deriving (Eq, Show, Generic) + deriving (Eq, Show, Functor, Generic) instance Binary pkg => Binary (PackageSpecifier pkg) @@ -282,9 +284,8 @@ -- locally cached copy. ie a package available from hackage | RepoTarballPackage Repo PackageId local ---TODO: --- * add support for darcs and other SCM style remote repos with a local cache --- | ScmPackage + -- | A package available from a version control system source repository + | RemoteSourceRepoPackage SourceRepo local deriving (Show, Functor, Eq, Ord, Generic, Typeable) instance Binary local => Binary (PackageLocation local) diff --git a/Distribution/Client/Upload.hs b/Distribution/Client/Upload.hs --- a/Distribution/Client/Upload.hs +++ b/Distribution/Client/Upload.hs @@ -172,7 +172,7 @@ repos = repoContextRepos repoCtxt remoteRepos = mapMaybe maybeRepoRemote repos forM_ remoteRepos $ \remoteRepo -> - do dotCabal <- defaultCabalDir + do dotCabal <- getCabalDir let srcDir = dotCabal "reports" remoteRepoName remoteRepo -- We don't want to bomb out just because we haven't built any packages -- from this repo yet. diff --git a/Distribution/Client/Utils.hs b/Distribution/Client/Utils.hs --- a/Distribution/Client/Utils.hs +++ b/Distribution/Client/Utils.hs @@ -17,7 +17,9 @@ , moreRecentFile, existsAndIsMoreRecentThan , tryFindAddSourcePackageDesc , tryFindPackageDesc - , relaxEncodingErrors) + , relaxEncodingErrors + , ProgressPhase (..) + , progressMessage) where import Prelude () @@ -28,7 +30,7 @@ import Distribution.Compat.Time ( getModTime ) import Distribution.Simple.Setup ( Flag(..) ) import Distribution.Verbosity -import Distribution.Simple.Utils ( die', findPackageDesc ) +import Distribution.Simple.Utils ( die', findPackageDesc, noticeNoWrap ) import qualified Data.ByteString.Lazy as BS import Data.Bits ( (.|.), shiftL, shiftR ) @@ -45,18 +47,14 @@ , removeFile, setCurrentDirectory ) import System.IO ( Handle, hClose, openTempFile -#if MIN_VERSION_base(4,4,0) , hGetEncoding, hSetEncoding -#endif ) import System.IO.Unsafe ( unsafePerformIO ) -#if MIN_VERSION_base(4,4,0) import GHC.IO.Encoding ( recover, TextEncoding(TextEncoding) ) import GHC.IO.Encoding.Failure ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) ) -#endif #if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3) import qualified System.Directory as Dir @@ -311,14 +309,12 @@ -- set. It's a no-op for versions of `base` less than 4.4. relaxEncodingErrors :: Handle -> IO () relaxEncodingErrors handle = do -#if MIN_VERSION_base(4,4,0) maybeEncoding <- hGetEncoding handle case maybeEncoding of Just (TextEncoding name decoder encoder) | not ("UTF" `isPrefixOf` name) -> let relax x = x { recover = recoverEncode TransliterateCodingFailure } in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder)) _ -> -#endif return () -- |Like 'tryFindPackageDesc', but with error specific to add-source deps. @@ -336,3 +332,27 @@ case errOrCabalFile of Right file -> return file Left _ -> die' verbosity err + +-- | Phase of building a dependency. Represents current status of package +-- dependency processing. See #4040 for details. +data ProgressPhase + = ProgressDownloading + | ProgressDownloaded + | ProgressStarting + | ProgressBuilding + | ProgressHaddock + | ProgressInstalling + | ProgressCompleted + +progressMessage :: Verbosity -> ProgressPhase -> String -> IO () +progressMessage verbosity phase subject = do + noticeNoWrap verbosity $ phaseStr ++ subject ++ "\n" + where + phaseStr = case phase of + ProgressDownloading -> "Downloading " + ProgressDownloaded -> "Downloaded " + ProgressStarting -> "Starting " + ProgressBuilding -> "Building " + ProgressHaddock -> "Haddock " + ProgressInstalling -> "Installing " + ProgressCompleted -> "Completed " diff --git a/Distribution/Client/VCS.hs b/Distribution/Client/VCS.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/VCS.hs @@ -0,0 +1,518 @@ +{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} +module Distribution.Client.VCS ( + -- * VCS driver type + VCS, + vcsRepoType, + vcsProgram, + -- ** Type re-exports + SourceRepo, + RepoType, + RepoKind, + Program, + ConfiguredProgram, + + -- * Selecting amongst source repos + selectPackageSourceRepo, + + -- * Validating 'SourceRepo's and configuring VCS drivers + validateSourceRepo, + validateSourceRepos, + SourceRepoProblem(..), + configureVCS, + configureVCSs, + + -- * Running the VCS driver + cloneSourceRepo, + syncSourceRepos, + + -- * The individual VCS drivers + knownVCSs, + vcsBzr, + vcsDarcs, + vcsGit, + vcsHg, + vcsSvn, + ) where + +import Prelude () +import Distribution.Client.Compat.Prelude + +import Distribution.Types.SourceRepo + ( SourceRepo(..), RepoType(..), RepoKind(..) ) +import Distribution.Client.RebuildMonad + ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence ) +import Distribution.Verbosity as Verbosity + ( Verbosity, normal ) +import Distribution.Simple.Program + ( Program(programFindVersion) + , ConfiguredProgram(programVersion) + , simpleProgram, findProgramVersion + , ProgramInvocation(..), programInvocation, runProgramInvocation + , emptyProgramDb, requireProgram ) +import Distribution.Version + ( mkVersion ) + +import Control.Monad + ( mapM_ ) +import Control.Monad.Trans + ( liftIO ) +import qualified Data.Char as Char +import qualified Data.Map as Map +import Data.Ord + ( comparing ) +import Data.Either + ( partitionEithers ) +import System.FilePath + ( takeDirectory ) +import System.Directory + ( doesDirectoryExist ) + + +-- | A driver for a version control system, e.g. git, darcs etc. +-- +data VCS program = VCS { + -- | The type of repository this driver is for. + vcsRepoType :: RepoType, + + -- | The vcs program itself. + -- This is used at type 'Program' and 'ConfiguredProgram'. + vcsProgram :: program, + + -- | The program invocation(s) to get\/clone a repository into a fresh + -- local directory. + vcsCloneRepo :: Verbosity + -> ConfiguredProgram + -> SourceRepo + -> FilePath -- Source URI + -> FilePath -- Destination directory + -> [ProgramInvocation], + + -- | The program invocation(s) to synchronise a whole set of /related/ + -- repositories with corresponding local directories. Also returns the + -- files that the command depends on, for change monitoring. + vcsSyncRepos :: Verbosity + -> ConfiguredProgram + -> [(SourceRepo, FilePath)] + -> IO [MonitorFilePath] + } + + +-- ------------------------------------------------------------ +-- * Selecting repos and drivers +-- ------------------------------------------------------------ + +-- | Pick the 'SourceRepo' to use to get the package sources from. +-- +-- Note that this does /not/ depend on what 'VCS' drivers we are able to +-- successfully configure. It is based only on the 'SourceRepo's declared +-- in the package, and optionally on a preferred 'RepoKind'. +-- +selectPackageSourceRepo :: Maybe RepoKind + -> [SourceRepo] + -> Maybe SourceRepo +selectPackageSourceRepo preferredRepoKind = + listToMaybe + -- Sort repositories by kind, from This to Head to Unknown. Repositories + -- with equivalent kinds are selected based on the order they appear in + -- the Cabal description file. + . sortBy (comparing thisFirst) + -- If the user has specified the repo kind, filter out the repositories + -- they're not interested in. + . filter (\repo -> maybe True (repoKind repo ==) preferredRepoKind) + where + thisFirst :: SourceRepo -> Int + thisFirst r = case repoKind r of + RepoThis -> 0 + RepoHead -> case repoTag r of + -- If the type is 'head' but the author specified a tag, they + -- probably meant to create a 'this' repository but screwed up. + Just _ -> 0 + Nothing -> 1 + RepoKindUnknown _ -> 2 + +data SourceRepoProblem = SourceRepoRepoTypeUnspecified + | SourceRepoRepoTypeUnsupported RepoType + | SourceRepoLocationUnspecified + deriving Show + +-- | Validates that the 'SourceRepo' specifies a location URI and a repository +-- type that is supported by a VCS driver. +-- +-- | It also returns the 'VCS' driver we should use to work with it. +-- +validateSourceRepo :: SourceRepo + -> Either SourceRepoProblem + (SourceRepo, String, RepoType, VCS Program) +validateSourceRepo = \repo -> do + rtype <- repoType repo ?! SourceRepoRepoTypeUnspecified + vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported rtype + uri <- repoLocation repo ?! SourceRepoLocationUnspecified + return (repo, uri, rtype, vcs) + where + a ?! e = maybe (Left e) Right a + + +-- | As 'validateSourceRepo' but for a bunch of 'SourceRepo's, and return +-- things in a convenient form to pass to 'configureVCSs', or to report +-- problems. +-- +validateSourceRepos :: [SourceRepo] + -> Either [(SourceRepo, SourceRepoProblem)] + [(SourceRepo, String, RepoType, VCS Program)] +validateSourceRepos rs = + case partitionEithers (map validateSourceRepo' rs) of + (problems@(_:_), _) -> Left problems + ([], vcss) -> Right vcss + where + validateSourceRepo' r = either (Left . (,) r) Right + (validateSourceRepo r) + + +configureVCS :: Verbosity + -> VCS Program + -> IO (VCS ConfiguredProgram) +configureVCS verbosity vcs@VCS{vcsProgram = prog} = + asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb + where + asVcsConfigured (prog', _) = vcs { vcsProgram = prog' } + +configureVCSs :: Verbosity + -> Map RepoType (VCS Program) + -> IO (Map RepoType (VCS ConfiguredProgram)) +configureVCSs verbosity = traverse (configureVCS verbosity) + + +-- ------------------------------------------------------------ +-- * Running the driver +-- ------------------------------------------------------------ + +-- | Clone a single source repo into a fresh directory, using a configured VCS. +-- +-- This is for making a new copy, not synchronising an existing copy. It will +-- fail if the destination directory already exists. +-- +-- Make sure to validate the 'SourceRepo' using 'validateSourceRepo' first. +-- +cloneSourceRepo :: Verbosity + -> VCS ConfiguredProgram + -> SourceRepo -- ^ Must have 'repoLocation' filled. + -> FilePath -- ^ Destination directory + -> IO () +cloneSourceRepo _ _ repo@SourceRepo{ repoLocation = Nothing } _ = + error $ "cloneSourceRepo: precondition violation, missing repoLocation: \"" + ++ show repo ++ "\". Validate using validateSourceRepo first." + +cloneSourceRepo verbosity vcs + repo@SourceRepo{ repoLocation = Just srcuri } destdir = + mapM_ (runProgramInvocation verbosity) invocations + where + invocations = vcsCloneRepo vcs verbosity + (vcsProgram vcs) repo + srcuri destdir + + +-- | Syncronise a set of 'SourceRepo's referring to the same repository with +-- corresponding local directories. The local directories may or may not +-- already exist. +-- +-- The 'SourceRepo' values used in a single invocation of 'syncSourceRepos', +-- or used across a series of invocations with any local directory must refer +-- to the /same/ repository. That means it must be the same location but they +-- can differ in the branch, or tag or subdir. +-- +-- The reason to allow multiple related 'SourceRepo's is to allow for the +-- network or storage to be shared between different checkouts of the repo. +-- For example if a single repo contains multiple packages in different subdirs +-- and in some project it may make sense to use a different state of the repo +-- for one subdir compared to another. +-- +syncSourceRepos :: Verbosity + -> VCS ConfiguredProgram + -> [(SourceRepo, FilePath)] + -> Rebuild () +syncSourceRepos verbosity vcs repos = do + files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos + monitorFiles files + + +-- ------------------------------------------------------------ +-- * The various VCS drivers +-- ------------------------------------------------------------ + +-- | The set of all supported VCS drivers, organised by 'RepoType'. +-- +knownVCSs :: Map RepoType (VCS Program) +knownVCSs = Map.fromList [ (vcsRepoType vcs, vcs) | vcs <- vcss ] + where + vcss = [ vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn ] + + +-- | VCS driver for Bazaar. +-- +vcsBzr :: VCS Program +vcsBzr = + VCS { + vcsRepoType = Bazaar, + vcsProgram = bzrProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity + -> ConfiguredProgram + -> SourceRepo + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo verbosity prog repo srcuri destdir = + [ programInvocation prog + ([branchCmd, srcuri, destdir] ++ tagArgs ++ verboseArg) ] + where + -- The @get@ command was deprecated in version 2.4 in favour of + -- the alias @branch@ + branchCmd | programVersion prog >= Just (mkVersion [2,4]) + = "branch" + | otherwise = "get" + + tagArgs = case repoTag repo of + Nothing -> [] + Just tag -> ["-r", "tag:" ++ tag] + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + + vcsSyncRepos :: Verbosity -> ConfiguredProgram + -> [(SourceRepo, FilePath)] -> IO [MonitorFilePath] + vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr" + +bzrProgram :: Program +bzrProgram = (simpleProgram "bzr") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "Bazaar (bzr) 2.6.0\n ... lots of extra stuff" + (_:_:ver:_) -> ver + _ -> "" + } + + +-- | VCS driver for Darcs. +-- +vcsDarcs :: VCS Program +vcsDarcs = + VCS { + vcsRepoType = Darcs, + vcsProgram = darcsProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity + -> ConfiguredProgram + -> SourceRepo + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo verbosity prog repo srcuri destdir = + [ programInvocation prog cloneArgs ] + where + cloneArgs = [cloneCmd, srcuri, destdir] ++ tagArgs ++ verboseArg + -- At some point the @clone@ command was introduced as an alias for + -- @get@, and @clone@ seems to be the recommended one now. + cloneCmd | programVersion prog >= Just (mkVersion [2,8]) + = "clone" + | otherwise = "get" + tagArgs = case repoTag repo of + Nothing -> [] + Just tag -> ["-t", tag] + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + + vcsSyncRepos :: Verbosity -> ConfiguredProgram + -> [(SourceRepo, FilePath)] -> IO [MonitorFilePath] + vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for darcs" + +darcsProgram :: Program +darcsProgram = (simpleProgram "darcs") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "2.8.5 (release)" + (ver:_) -> ver + _ -> "" + } + + +-- | VCS driver for Git. +-- +vcsGit :: VCS Program +vcsGit = + VCS { + vcsRepoType = Git, + vcsProgram = gitProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity + -> ConfiguredProgram + -> SourceRepo + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo verbosity prog repo srcuri destdir = + [ programInvocation prog cloneArgs ] + -- And if there's a tag, we have to do that in a second step: + ++ [ (programInvocation prog (checkoutArgs tag)) { + progInvokeCwd = Just destdir + } + | tag <- maybeToList (repoTag repo) ] + where + cloneArgs = ["clone", srcuri, destdir] + ++ branchArgs ++ verboseArg + branchArgs = case repoBranch repo of + Just b -> ["--branch", b] + Nothing -> [] + checkoutArgs tag = "checkout" : verboseArg ++ [tag, "--"] + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + + vcsSyncRepos :: Verbosity + -> ConfiguredProgram + -> [(SourceRepo, FilePath)] + -> IO [MonitorFilePath] + vcsSyncRepos _ _ [] = return [] + vcsSyncRepos verbosity gitProg + ((primaryRepo, primaryLocalDir) : secondaryRepos) = do + + vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing + sequence_ + [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir) + | (repo, localDir) <- secondaryRepos ] + return [ monitorDirectoryExistence dir + | dir <- (primaryLocalDir : map snd secondaryRepos) ] + + vcsSyncRepo verbosity gitProg SourceRepo{..} localDir peer = do + exists <- doesDirectoryExist localDir + if exists + then git localDir ["fetch"] + else git (takeDirectory localDir) cloneArgs + git localDir checkoutArgs + where + git :: FilePath -> [String] -> IO () + git cwd args = runProgramInvocation verbosity $ + (programInvocation gitProg args) { + progInvokeCwd = Just cwd + } + + cloneArgs = ["clone", "--no-checkout", loc, localDir] + ++ case peer of + Nothing -> [] + Just peerLocalDir -> ["--reference", peerLocalDir] + ++ verboseArg + where Just loc = repoLocation + checkoutArgs = "checkout" : verboseArg ++ ["--detach", "--force" + , checkoutTarget, "--" ] + checkoutTarget = fromMaybe "HEAD" (repoBranch `mplus` repoTag) + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + +gitProgram :: Program +gitProgram = (simpleProgram "git") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- "git version 2.5.5" + (_:_:ver:_) | all isTypical ver -> ver + + -- or annoyingly "git version 2.17.1.windows.2" yes, really + (_:_:ver:_) -> intercalate "." + . takeWhile (all isNum) + . split + $ ver + _ -> "" + } + where + isNum c = c >= '0' && c <= '9' + isTypical c = isNum c || c == '.' + split cs = case break (=='.') cs of + (chunk,[]) -> chunk : [] + (chunk,_:rest) -> chunk : split rest + +-- | VCS driver for Mercurial. +-- +vcsHg :: VCS Program +vcsHg = + VCS { + vcsRepoType = Mercurial, + vcsProgram = hgProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity + -> ConfiguredProgram + -> SourceRepo + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo verbosity prog repo srcuri destdir = + [ programInvocation prog cloneArgs ] + where + cloneArgs = ["clone", srcuri, destdir] + ++ branchArgs ++ tagArgs ++ verboseArg + branchArgs = case repoBranch repo of + Just b -> ["--branch", b] + Nothing -> [] + tagArgs = case repoTag repo of + Just t -> ["--rev", t] + Nothing -> [] + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + + vcsSyncRepos :: Verbosity + -> ConfiguredProgram + -> [(SourceRepo, FilePath)] + -> IO [MonitorFilePath] + vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg" + +hgProgram :: Program +hgProgram = (simpleProgram "hg") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- Mercurial Distributed SCM (version 3.5.2)\n ... long message + (_:_:_:_:ver:_) -> takeWhile (\c -> Char.isDigit c || c == '.') ver + _ -> "" + } + + +-- | VCS driver for Subversion. +-- +vcsSvn :: VCS Program +vcsSvn = + VCS { + vcsRepoType = SVN, + vcsProgram = svnProgram, + vcsCloneRepo, + vcsSyncRepos + } + where + vcsCloneRepo :: Verbosity + -> ConfiguredProgram + -> SourceRepo + -> FilePath + -> FilePath + -> [ProgramInvocation] + vcsCloneRepo verbosity prog _repo srcuri destdir = + [ programInvocation prog checkoutArgs ] + where + checkoutArgs = ["checkout", srcuri, destdir] ++ verboseArg + verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] + --TODO: branch or tag? + + vcsSyncRepos :: Verbosity + -> ConfiguredProgram + -> [(SourceRepo, FilePath)] + -> IO [MonitorFilePath] + vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn" + +svnProgram :: Program +svnProgram = (simpleProgram "svn") { + programFindVersion = findProgramVersion "--version" $ \str -> + case words str of + -- svn, version 1.9.4 (r1740329)\n ... long message + (_:_:ver:_) -> ver + _ -> "" + } + diff --git a/Distribution/Solver/Modular.hs b/Distribution/Solver/Modular.hs --- a/Distribution/Solver/Modular.hs +++ b/Distribution/Solver/Modular.hs @@ -10,7 +10,7 @@ -- plan. import Prelude () -import Distribution.Client.Compat.Prelude +import Distribution.Solver.Compat.Prelude import qualified Data.Map as M import Data.Set (Set) @@ -48,6 +48,7 @@ ( Platform(..) ) import Distribution.Simple.Utils ( ordNubBy ) +import Distribution.Verbosity -- | Ties the two worlds together: classic cabal-install vs. the modular @@ -58,7 +59,7 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns where -- Indices have to be converted into solver-specific uniform index. - idx = convPIs os arch cinfo (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx + idx = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx -- Constraints have to be converted into a finite map indexed by PN. gcs = M.fromListWith (++) (map pair pcs) where @@ -115,35 +116,36 @@ -> Set PN -> Progress String String (Assignment, RevDepMap) solve' sc cinfo idx pkgConfigDB pprefs gcs pns = - foldProgress Step createErrorMsg Done (runSolver sc) + foldProgress Step (uncurry createErrorMsg) Done (runSolver printFullLog sc) where - runSolver :: SolverConfig - -> Progress String SolverFailure (Assignment, RevDepMap) - runSolver sc' = - logToProgress (solverVerbosity sc') (maxBackjumps sc') $ -- convert log format into progress format + runSolver :: Bool -> SolverConfig + -> Progress String (SolverFailure, String) (Assignment, RevDepMap) + runSolver keepLog sc' = + logToProgress keepLog (solverVerbosity sc') (maxBackjumps sc') $ solve sc' cinfo idx pkgConfigDB pprefs gcs pns - createErrorMsg :: SolverFailure + createErrorMsg :: SolverFailure -> String -> Progress String String (Assignment, RevDepMap) - createErrorMsg (NoSolution cs msg) = - Fail $ rerunSolverForErrorMsg cs msg - createErrorMsg (BackjumpLimitReached msg) = + createErrorMsg (ExhaustiveSearch cs _) msg = + Fail $ rerunSolverForErrorMsg cs ++ msg + createErrorMsg BackjumpLimitReached msg = Step ("Backjump limit reached. Rerunning dependency solver to generate " ++ "a final conflict set for the search tree containing the " ++ "first backjump.") $ - foldProgress Step f Done $ - runSolver sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True } + foldProgress Step (f . fst) Done $ + runSolver printFullLog + sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True } where f :: SolverFailure -> Progress String String (Assignment, RevDepMap) - f (NoSolution cs _) = Fail $ rerunSolverForErrorMsg cs msg - f (BackjumpLimitReached _) = + f (ExhaustiveSearch cs _) = Fail $ rerunSolverForErrorMsg cs ++ msg + f BackjumpLimitReached = -- This case is possible when the number of goals involved in -- conflicts is greater than the backjump limit. Fail $ msg ++ "Failed to generate a summarized dependency solver " ++ "log due to low backjump limit." - rerunSolverForErrorMsg :: ConflictSet -> String -> String - rerunSolverForErrorMsg cs finalMsg = + rerunSolverForErrorMsg :: ConflictSet -> String + rerunSolverForErrorMsg cs = let sc' = sc { goalOrder = Just goalOrder' , maxBackjumps = Just 0 @@ -153,8 +155,9 @@ -- original goal order. goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc) - in unlines ("Could not resolve dependencies:" : messages (runSolver sc')) - ++ finalMsg + in unlines ("Could not resolve dependencies:" : messages (runSolver True sc')) + + printFullLog = solverVerbosity sc >= verbose messages :: Progress step fail done -> [step] messages = foldProgress (:) (const []) (const []) diff --git a/Distribution/Solver/Modular/Builder.hs b/Distribution/Solver/Modular/Builder.hs --- a/Distribution/Solver/Modular/Builder.hs +++ b/Distribution/Solver/Modular/Builder.hs @@ -72,7 +72,7 @@ -- the later addition will have better dependency information. go g o ((Stanza sn@(SN qpn _) t) : ngs) = go g (StanzaGoal sn t (flagGR qpn) : o) ngs - go g o ((Simple (LDep dr (Dep _ qpn _)) c) : ngs) + go g o ((Simple (LDep dr (Dep (PkgComponent qpn _) _)) c) : ngs) | qpn == qpn' = -- We currently only add a self-dependency to the graph if it is -- between a package and its setup script. The edge creates a cycle diff --git a/Distribution/Solver/Modular/ConflictSet.hs b/Distribution/Solver/Modular/ConflictSet.hs --- a/Distribution/Solver/Modular/ConflictSet.hs +++ b/Distribution/Solver/Modular/ConflictSet.hs @@ -51,7 +51,7 @@ -- kept abstract. data ConflictSet = CS { -- | The set of variables involved on the conflict - conflictSetToSet :: Set (Var QPN) + conflictSetToSet :: !(Set (Var QPN)) #ifdef DEBUG_CONFLICT_SETS -- | The origin of the conflict set diff --git a/Distribution/Solver/Modular/Dependency.hs b/Distribution/Solver/Modular/Dependency.hs --- a/Distribution/Solver/Modular/Dependency.hs +++ b/Distribution/Solver/Modular/Dependency.hs @@ -16,6 +16,8 @@ , FlaggedDep(..) , LDep(..) , Dep(..) + , PkgComponent(..) + , ExposedComponent(..) , DependencyReason(..) , showDependencyReason , flattenFlaggedDeps @@ -37,7 +39,7 @@ import Prelude () import qualified Data.Map as M import qualified Data.Set as S -import Distribution.Client.Compat.Prelude hiding (pi) +import Distribution.Solver.Compat.Prelude hiding (pi) import Language.Haskell.Extension (Extension(..), Language(..)) @@ -112,12 +114,22 @@ -- | A dependency (constraint) associates a package name with a constrained -- instance. It can also represent other types of dependencies, such as -- dependencies on language extensions. -data Dep qpn = Dep (Maybe UnqualComponentName) qpn CI -- ^ dependency on a package (possibly for executable) - | Ext Extension -- ^ dependency on a language extension - | Lang Language -- ^ dependency on a language version - | Pkg PkgconfigName VR -- ^ dependency on a pkg-config package +data Dep qpn = Dep (PkgComponent qpn) CI -- ^ dependency on a package component + | Ext Extension -- ^ dependency on a language extension + | Lang Language -- ^ dependency on a language version + | Pkg PkgconfigName VR -- ^ dependency on a pkg-config package deriving Functor +-- | An exposed component within a package. This type is used to represent +-- build-depends and build-tool-depends dependencies. +data PkgComponent qpn = PkgComponent qpn ExposedComponent + deriving (Eq, Ord, Functor, Show) + +-- | A component that can be depended upon by another package, i.e., a library +-- or an executable. +data ExposedComponent = ExposedLib | ExposedExe UnqualComponentName + deriving (Eq, Ord, Show) + -- | The reason that a dependency is active. It identifies the package and any -- flag and stanza choices that introduced the dependency. It contains -- everything needed for creating ConflictSets or describing conflicts in solver @@ -169,7 +181,7 @@ -- Suppose package B has a setup dependency on package A. -- This will be recorded as something like -- - -- > LDep (DependencyReason "B") (Dep Nothing "A" (Constrained AnyVersion)) + -- > LDep (DependencyReason "B") (Dep (PkgComponent "A" ExposedLib) (Constrained AnyVersion)) -- -- Observe that when we qualify this dependency, we need to turn that -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier @@ -181,11 +193,12 @@ goD (Ext ext) _ = Ext ext goD (Lang lang) _ = Lang lang goD (Pkg pkn vr) _ = Pkg pkn vr - goD (Dep mExe dep ci) comp - | isJust mExe = Dep mExe (Q (PackagePath ns (QualExe pn dep)) dep) ci - | qBase dep = Dep mExe (Q (PackagePath ns (QualBase pn )) dep) ci - | qSetup comp = Dep mExe (Q (PackagePath ns (QualSetup pn )) dep) ci - | otherwise = Dep mExe (Q (PackagePath ns inheritedQ ) dep) ci + goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ = + Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci + goD (Dep dep@(PkgComponent qpn ExposedLib) ci) comp + | qBase qpn = Dep (Q (PackagePath ns (QualBase pn)) <$> dep) ci + | qSetup comp = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci + | otherwise = Dep (Q (PackagePath ns inheritedQ ) <$> dep) ci -- If P has a setup dependency on Q, and Q has a regular dependency on R, then -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup diff --git a/Distribution/Solver/Modular/Explore.hs b/Distribution/Solver/Modular/Explore.hs --- a/Distribution/Solver/Modular/Explore.hs +++ b/Distribution/Solver/Modular/Explore.hs @@ -5,9 +5,11 @@ , backjumpAndExplore ) where +import qualified Distribution.Solver.Types.Progress as P + import Data.Foldable as F import Data.List as L (foldl') -import Data.Map as M +import Data.Map.Strict as M import Distribution.Solver.Modular.Assignment import Distribution.Solver.Modular.Dependency @@ -43,34 +45,61 @@ -- with the (virtual) option not to choose anything for the current -- variable. See also the comments for 'avoidSet'. -- -backjump :: EnableBackjumping -> Var QPN - -> ConflictSet -> W.WeightedPSQ w k (ConflictMap -> ConflictSetLog a) - -> ConflictMap -> ConflictSetLog a -backjump (EnableBackjumping enableBj) var lastCS xs = +backjump :: Maybe Int -> EnableBackjumping -> Var QPN + -> ConflictSet -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a) + -> ExploreState -> ConflictSetLog a +backjump mbj (EnableBackjumping enableBj) var lastCS xs = F.foldr combine avoidGoal xs CS.empty where - combine :: forall a . (ConflictMap -> ConflictSetLog a) - -> (ConflictSet -> ConflictMap -> ConflictSetLog a) - -> ConflictSet -> ConflictMap -> ConflictSetLog a - combine x f csAcc cm = retry (x cm) next + combine :: forall a . (ExploreState -> ConflictSetLog a) + -> (ConflictSet -> ExploreState -> ConflictSetLog a) + -> ConflictSet -> ExploreState -> ConflictSetLog a + combine x f csAcc es = retry (x es) next where - next :: (ConflictSet, ConflictMap) -> ConflictSetLog a - next (cs, cm') - | enableBj && not (var `CS.member` cs) = logBackjump cs cm' - | otherwise = f (csAcc `CS.union` cs) cm' + next :: IntermediateFailure -> ConflictSetLog a + next BackjumpLimit = fromProgress (P.Fail BackjumpLimit) + next (NoSolution !cs es') + | enableBj && not (var `CS.member` cs) = skipLoggingBackjump cs es' + | otherwise = f (csAcc `CS.union` cs) es' -- This function represents the option to not choose a value for this goal. - avoidGoal :: ConflictSet -> ConflictMap -> ConflictSetLog a - avoidGoal cs !cm = logBackjump (cs `CS.union` lastCS) (updateCM lastCS cm) - -- 'lastCS' instead of 'cs' here ---^ - -- since we do not want to double-count the - -- additionally accumulated conflicts. + avoidGoal :: ConflictSet -> ExploreState -> ConflictSetLog a + avoidGoal cs !es = + logBackjump (cs `CS.union` lastCS) $ - logBackjump :: ConflictSet -> ConflictMap -> ConflictSetLog a - logBackjump cs cm = failWith (Failure cs Backjump) (cs, cm) + -- Use 'lastCS' below instead of 'cs' since we do not want to + -- double-count the additionally accumulated conflicts. + es { esConflictMap = updateCM lastCS (esConflictMap es) } -type ConflictSetLog = RetryLog Message (ConflictSet, ConflictMap) + logBackjump :: ConflictSet -> ExploreState -> ConflictSetLog a + logBackjump cs es = + failWith (Failure cs Backjump) $ + if reachedBjLimit (esBackjumps es) + then BackjumpLimit + else NoSolution cs es { esBackjumps = esBackjumps es + 1 } + where + reachedBjLimit = case mbj of + Nothing -> const False + Just limit -> (== limit) + -- The solver does not count or log backjumps at levels where the conflict + -- set does not contain the current variable. Otherwise, there would be many + -- consecutive log messages about backjumping with the same conflict set. + skipLoggingBackjump :: ConflictSet -> ExploreState -> ConflictSetLog a + skipLoggingBackjump cs es = fromProgress $ P.Fail (NoSolution cs es) + +-- | The state that is read and written while exploring the search tree. +data ExploreState = ES { + esConflictMap :: !ConflictMap + , esBackjumps :: !Int + } + +data IntermediateFailure = + NoSolution ConflictSet ExploreState + | BackjumpLimit + +type ConflictSetLog = RetryLog Message IntermediateFailure + getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a) getBestGoal cm = P.maximumBy @@ -86,10 +115,7 @@ updateCM :: ConflictSet -> ConflictMap -> ConflictMap updateCM cs cm = - L.foldl' (\ cmc k -> M.alter inc k cmc) cm (CS.toList cs) - where - inc Nothing = Just 1 - inc (Just n) = Just $! n + 1 + L.foldl' (\ cmc k -> M.insertWith (+) k 1 cmc) cm (CS.toList cs) -- | Record complete assignments on 'Done' nodes. assign :: Tree d c -> Tree Assignment c @@ -109,39 +135,46 @@ -- | A tree traversal that simultaneously propagates conflict sets up -- the tree from the leaves and creates a log. -exploreLog :: EnableBackjumping -> CountConflicts -> Tree Assignment QGoalReason +exploreLog :: Maybe Int -> EnableBackjumping -> CountConflicts + -> Tree Assignment QGoalReason -> ConflictSetLog (Assignment, RevDepMap) -exploreLog enableBj (CountConflicts countConflicts) t = cata go t M.empty +exploreLog mbj enableBj (CountConflicts countConflicts) t = cata go t initES where getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a) getBestGoal' | countConflicts = \ ts cm -> getBestGoal cm ts | otherwise = \ ts _ -> getFirstGoal ts - go :: TreeF Assignment QGoalReason (ConflictMap -> ConflictSetLog (Assignment, RevDepMap)) - -> (ConflictMap -> ConflictSetLog (Assignment, RevDepMap)) - go (FailF c fr) = \ !cm -> failWith (Failure c fr) - (c, updateCM c cm) + go :: TreeF Assignment QGoalReason (ExploreState -> ConflictSetLog (Assignment, RevDepMap)) + -> (ExploreState -> ConflictSetLog (Assignment, RevDepMap)) + go (FailF c fr) = \ !es -> + let es' = es { esConflictMap = updateCM c (esConflictMap es) } + in failWith (Failure c fr) (NoSolution c es') go (DoneF rdm a) = \ _ -> succeedWith Success (a, rdm) go (PChoiceF qpn _ gr ts) = - backjump enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r cm -> tryWith (TryP qpn k) (r cm)) + backjump mbj enableBj (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r es -> tryWith (TryP qpn k) (r es)) ts go (FChoiceF qfn _ gr _ _ _ ts) = - backjump enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r cm -> tryWith (TryF qfn k) (r cm)) + backjump mbj enableBj (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r es -> tryWith (TryF qfn k) (r es)) ts go (SChoiceF qsn _ gr _ ts) = - backjump enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, - W.mapWithKey -- when descending ... - (\ k r cm -> tryWith (TryS qsn k) (r cm)) + backjump mbj enableBj (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, + W.mapWithKey -- when descending ... + (\ k r es -> tryWith (TryS qsn k) (r es)) ts - go (GoalChoiceF _ ts) = \ cm -> - let (k, v) = getBestGoal' ts cm - in continueWith (Next k) (v cm) + go (GoalChoiceF _ ts) = \ es -> + let (k, v) = getBestGoal' ts (esConflictMap es) + in continueWith (Next k) (v es) + initES = ES { + esConflictMap = M.empty + , esBackjumps = 0 + } + -- | Build a conflict set corresponding to the (virtual) option not to -- choose a solution for a goal at all. -- @@ -171,8 +204,17 @@ CS.union (CS.singleton var) (goalReasonToCS gr) -- | Interface. -backjumpAndExplore :: EnableBackjumping +-- +-- Takes as an argument a limit on allowed backjumps. If the limit is 'Nothing', +-- then infinitely many backjumps are allowed. If the limit is 'Just 0', +-- backtracking is completely disabled. +backjumpAndExplore :: Maybe Int + -> EnableBackjumping -> CountConflicts - -> Tree d QGoalReason -> Log Message (Assignment, RevDepMap) -backjumpAndExplore enableBj countConflicts = - toProgress . exploreLog enableBj countConflicts . assign + -> Tree d QGoalReason + -> RetryLog Message SolverFailure (Assignment, RevDepMap) +backjumpAndExplore mbj enableBj countConflicts = + mapFailure convertFailure . exploreLog mbj enableBj countConflicts . assign + where + convertFailure (NoSolution cs es) = ExhaustiveSearch cs (esConflictMap es) + convertFailure BackjumpLimit = BackjumpLimitReached diff --git a/Distribution/Solver/Modular/Index.hs b/Distribution/Solver/Modular/Index.hs --- a/Distribution/Solver/Modular/Index.hs +++ b/Distribution/Solver/Modular/Index.hs @@ -1,6 +1,7 @@ module Distribution.Solver.Modular.Index ( Index , PInfo(..) + , IsBuildable(..) , defaultQualifyOptions , mkIndex ) where @@ -13,7 +14,6 @@ import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree -import Distribution.Types.UnqualComponentName -- | An index contains information about package instances. This is a nested -- dictionary. Package names are mapped to instances, which in turn is mapped @@ -21,13 +21,18 @@ type Index = Map PN (Map I PInfo) -- | Info associated with a package instance. --- Currently, dependencies, executable names, flags and failure reasons. +-- Currently, dependencies, component names, flags and failure reasons. +-- The component map records whether any components are unbuildable in the +-- current environment (compiler, os, arch, and global flag constraints). -- Packages that have a failure reason recorded for them are disabled -- globally, for reasons external to the solver. We currently use this -- for shadowing which essentially is a GHC limitation, and for -- installed packages that are broken. -data PInfo = PInfo (FlaggedDeps PN) [UnqualComponentName] FlagInfo (Maybe FailReason) +data PInfo = PInfo (FlaggedDeps PN) (Map ExposedComponent IsBuildable) FlagInfo (Maybe FailReason) +-- | Whether a component is made unbuildable by a "buildable: False" field. +newtype IsBuildable = IsBuildable Bool + mkIndex :: [(PN, I, PInfo)] -> Index mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) @@ -40,9 +45,9 @@ | -- Find all versions of base .. Just is <- [M.lookup base idx] -- .. which are installed .. - , (I _ver (Inst _), PInfo deps _exes _flagNfo _fr) <- M.toList is + , (I _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is -- .. and flatten all their dependencies .. - , (LDep _ (Dep _is_exe dep _ci), _comp) <- flattenFlaggedDeps deps + , (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps ] , qoSetupIndependent = True } diff --git a/Distribution/Solver/Modular/IndexConversion.hs b/Distribution/Solver/Modular/IndexConversion.hs --- a/Distribution/Solver/Modular/IndexConversion.hs +++ b/Distribution/Solver/Modular/IndexConversion.hs @@ -3,8 +3,8 @@ ) where import Data.List as L -import Distribution.Compat.Map.Strict (Map) -import qualified Distribution.Compat.Map.Strict as M +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid as Mon import Data.Set as S @@ -30,7 +30,9 @@ import Distribution.Solver.Types.ComponentDeps ( Component(..), componentNameToComponent ) import Distribution.Solver.Types.Flag +import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza +import Distribution.Solver.Types.PackageConstraint import qualified Distribution.Solver.Types.PackageIndex as CI import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SourcePackage @@ -53,10 +55,13 @@ -- resolving these situations. However, the right thing to do is to -- fix the problem there, so for now, shadowing is only activated if -- explicitly requested. -convPIs :: OS -> Arch -> CompilerInfo -> ShadowPkgs -> StrongFlags -> SolveExecutables -> - SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> Index -convPIs os arch comp sip strfl solveExes iidx sidx = - mkIndex (convIPI' sip iidx ++ convSPI' os arch comp strfl solveExes sidx) +convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] + -> ShadowPkgs -> StrongFlags -> SolveExecutables + -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) + -> Index +convPIs os arch comp constraints sip strfl solveExes iidx sidx = + mkIndex $ + convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx -- | Convert a Cabal installed package index to the simpler, -- more uniform index format of the solver. @@ -72,7 +77,8 @@ where -- shadowing is recorded in the package info - shadow (pn, i, PInfo fdeps exes fds _) | sip = (pn, i, PInfo fdeps exes fds (Just Shadowed)) + shadow (pn, i, PInfo fdeps comps fds _) + | sip = (pn, i, PInfo fdeps comps fds (Just Shadowed)) shadow x = x -- | Extract/recover the the package ID from an installed package info, and convert it to a solver's I. @@ -86,8 +92,10 @@ convIP :: SI.InstalledPackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) convIP idx ipi = case mapM (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of - Nothing -> (pn, i, PInfo [] [] M.empty (Just Broken)) - Just fds -> (pn, i, PInfo fds [] M.empty Nothing) + Nothing -> (pn, i, PInfo [] M.empty M.empty (Just Broken)) + Just fds -> ( pn + , i + , PInfo fds (M.singleton ExposedLib (IsBuildable True)) M.empty Nothing) where (pn, i) = convId ipi -- 'sourceLibName' is unreliable, but for now we only really use this for @@ -133,30 +141,35 @@ case SI.lookupUnitId idx ipid of Nothing -> Nothing Just ipi -> let (pn, i) = convId ipi - in Just (D.Simple (LDep dr (Dep Nothing pn (Fixed i))) comp) + in Just (D.Simple (LDep dr (Dep (PkgComponent pn ExposedLib) (Fixed i))) comp) -- NB: something we pick up from the -- InstalledPackageIndex is NEVER an executable -- | Convert a cabal-install source package index to the simpler, -- more uniform index format of the solver. -convSPI' :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> - CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)] -convSPI' os arch cinfo strfl solveExes = L.map (convSP os arch cinfo strfl solveExes) . CI.allPackages +convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] + -> StrongFlags -> SolveExecutables + -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)] +convSPI' os arch cinfo constraints strfl solveExes = + L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages -- | Convert a single source package into the solver-specific format. -convSP :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo) -convSP os arch cinfo strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = +convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] + -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo) +convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = let i = I pv InRepo - in (pn, i, convGPD os arch cinfo strfl solveExes pn gpd) + pkgConstraints = fromMaybe [] $ M.lookup pn constraints + in (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd) -- We do not use 'flattenPackageDescription' or 'finalizePD' -- from 'Distribution.PackageDescription.Configuration' here, because we -- want to keep the condition tree, but simplify much of the test. -- | Convert a generic package description to a solver-specific 'PInfo'. -convGPD :: OS -> Arch -> CompilerInfo -> StrongFlags -> SolveExecutables -> - PN -> GenericPackageDescription -> PInfo -convGPD os arch cinfo strfl solveExes pn +convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] + -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription + -> PInfo +convGPD os arch cinfo constraints strfl solveExes pn (GenericPackageDescription pkg flags mlib sub_libs flibs exes tests benchs) = let fds = flagInfo strfl flags @@ -222,9 +235,82 @@ -- forced to, emit a meaningful solver error message). fr | reqSpecVer > maxSpecVer = Just (UnsupportedSpecVer reqSpecVer) | otherwise = Nothing - in - PInfo flagged_deps (L.map fst exes) fds fr + components :: Map ExposedComponent IsBuildable + components = M.fromList $ libComps ++ exeComps + where + libComps = [ (ExposedLib, IsBuildable $ isBuildable libBuildInfo lib) + | lib <- maybeToList mlib ] + exeComps = [ (ExposedExe name, IsBuildable $ isBuildable buildInfo exe) + | (name, exe) <- exes ] + isBuildable = isBuildableComponent os arch cinfo constraints + + in PInfo flagged_deps components fds fr + +-- | Returns true if the component is buildable in the given environment. +-- This function can give false-positives. For example, it only considers flags +-- that are set by unqualified flag constraints, and it doesn't check whether +-- the intra-package dependencies of a component are buildable. It is also +-- possible for the solver to later assign a value to an automatic flag that +-- makes the component unbuildable. +isBuildableComponent :: OS + -> Arch + -> CompilerInfo + -> [LabeledPackageConstraint] + -> (a -> BuildInfo) + -> CondTree ConfVar [Dependency] a + -> Bool +isBuildableComponent os arch cinfo constraints getInfo tree = + case simplifyCondition $ extractCondition (buildable . getInfo) tree of + Lit False -> False + _ -> True + where + flagAssignment :: [(FlagName, Bool)] + flagAssignment = + mconcat [ unFlagAssignment fa + | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa) + <- L.map unlabelPackageConstraint constraints] + + -- Simplify the condition, using the current environment. Most of this + -- function was copied from convBranch and + -- Distribution.Types.Condition.simplifyCondition. + simplifyCondition :: Condition ConfVar -> Condition ConfVar + simplifyCondition (Var (OS os')) = Lit (os == os') + simplifyCondition (Var (Arch arch')) = Lit (arch == arch') + simplifyCondition (Var (Impl cf cvr)) + | matchImpl (compilerInfoId cinfo) || + -- fixme: Nothing should be treated as unknown, rather than empty + -- list. This code should eventually be changed to either + -- support partial resolution of compiler flags or to + -- complain about incompletely configured compilers. + any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = Lit True + | otherwise = Lit False + where + matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv + simplifyCondition (Var (Flag f)) + | Just b <- L.lookup f flagAssignment = Lit b + simplifyCondition (Var v) = Var v + simplifyCondition (Lit b) = Lit b + simplifyCondition (CNot c) = + case simplifyCondition c of + Lit True -> Lit False + Lit False -> Lit True + c' -> CNot c' + simplifyCondition (COr c d) = + case (simplifyCondition c, simplifyCondition d) of + (Lit False, d') -> d' + (Lit True, _) -> Lit True + (c', Lit False) -> c' + (_, Lit True) -> Lit True + (c', d') -> COr c' d' + simplifyCondition (CAnd c d) = + case (simplifyCondition c, simplifyCondition d) of + (Lit False, _) -> Lit False + (Lit True, d') -> d' + (_, Lit False) -> Lit False + (c', Lit True) -> c' + (c', d') -> CAnd c' d' + -- | Create a flagged dependency tree from a list @fds@ of flagged -- dependencies, using @f@ to form the tree node (@f@ will be -- something like @Stanza sn@). @@ -289,7 +375,7 @@ bi = getInfo info data SimpleFlaggedDepKey qpn = - SimpleFlaggedDepKey (Maybe UnqualComponentName) qpn Component + SimpleFlaggedDepKey (PkgComponent qpn) Component deriving (Eq, Ord) data SimpleFlaggedDepValue qpn = SimpleFlaggedDepValue (DependencyReason qpn) VR @@ -320,9 +406,9 @@ => (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) -> FlaggedDep qpn -> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) - f (merged', unmerged') (D.Simple (LDep dr (Dep mExe qpn (Constrained vr))) comp) = + f (merged', unmerged') (D.Simple (LDep dr (Dep dep (Constrained vr))) comp) = ( M.insertWith mergeValues - (SimpleFlaggedDepKey mExe qpn comp) + (SimpleFlaggedDepKey dep comp) (SimpleFlaggedDepValue dr vr) merged' , unmerged') @@ -337,8 +423,8 @@ toFlaggedDep :: SimpleFlaggedDepKey qpn -> SimpleFlaggedDepValue qpn -> FlaggedDep qpn - toFlaggedDep (SimpleFlaggedDepKey mExe qpn comp) (SimpleFlaggedDepValue dr vr) = - D.Simple (LDep dr (Dep mExe qpn (Constrained vr))) comp + toFlaggedDep (SimpleFlaggedDepKey dep comp) (SimpleFlaggedDepValue dr vr) = + D.Simple (LDep dr (Dep dep (Constrained vr))) comp -- | Branch interpreter. Mutually recursive with 'convCondTree'. -- @@ -463,11 +549,10 @@ -- Union the DependencyReasons, because the extracted dependency can be -- avoided by removing the dependency from either side of the -- conditional. - [ D.Simple (LDep (unionDRs vs1 vs2) (Dep mExe1 pn1 (Constrained $ vr1 .||. vr2))) comp - | D.Simple (LDep vs1 (Dep mExe1 pn1 (Constrained vr1))) _ <- ps - , D.Simple (LDep vs2 (Dep mExe2 pn2 (Constrained vr2))) _ <- ps' - , pn1 == pn2 - , mExe1 == mExe2 + [ D.Simple (LDep (unionDRs vs1 vs2) (Dep dep1 (Constrained $ vr1 .||. vr2))) comp + | D.Simple (LDep vs1 (Dep dep1 (Constrained vr1))) _ <- ps + , D.Simple (LDep vs2 (Dep dep2 (Constrained vr2))) _ <- ps' + , dep1 == dep2 ] -- | Merge DependencyReasons by unioning their variables. @@ -477,11 +562,11 @@ -- | Convert a Cabal dependency on a library to a solver-specific dependency. convLibDep :: DependencyReason PN -> Dependency -> LDep PN -convLibDep dr (Dependency pn vr) = LDep dr $ Dep Nothing pn (Constrained vr) +convLibDep dr (Dependency pn vr) = LDep dr $ Dep (PkgComponent pn ExposedLib) (Constrained vr) -- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency. convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN -convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (Just exe) pn (Constrained vr) +convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (PkgComponent pn (ExposedExe exe)) (Constrained vr) -- | Convert setup dependencies convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN diff --git a/Distribution/Solver/Modular/Linking.hs b/Distribution/Solver/Modular/Linking.hs --- a/Distribution/Solver/Modular/Linking.hs +++ b/Distribution/Solver/Modular/Linking.hs @@ -245,7 +245,7 @@ go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState () go1 dep rdep = case (dep, rdep) of - (Simple (LDep dr1 (Dep _ qpn _)) _, ~(Simple (LDep dr2 (Dep _ qpn' _)) _)) -> do + (Simple (LDep dr1 (Dep (PkgComponent qpn _) _)) _, ~(Simple (LDep dr2 (Dep (PkgComponent qpn' _) _)) _)) -> do vs <- get let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs diff --git a/Distribution/Solver/Modular/Log.hs b/Distribution/Solver/Modular/Log.hs --- a/Distribution/Solver/Modular/Log.hs +++ b/Distribution/Solver/Modular/Log.hs @@ -1,6 +1,5 @@ module Distribution.Solver.Modular.Log - ( Log - , logToProgress + ( logToProgress , SolverFailure(..) ) where @@ -11,63 +10,47 @@ import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Message -import Distribution.Solver.Modular.Tree (FailReason(..)) import qualified Distribution.Solver.Modular.ConflictSet as CS +import Distribution.Solver.Modular.RetryLog import Distribution.Verbosity --- | The 'Log' datatype. --- --- Represents the progress of a computation lazily. --- --- Parameterized over the type of actual messages and the final result. -type Log m a = Progress m (ConflictSet, ConflictMap) a - -data Exhaustiveness = Exhaustive | BackjumpLimit - --- | Information about a dependency solver failure. It includes an error message --- and a final conflict set, if available. +-- | Information about a dependency solver failure. data SolverFailure = - NoSolution ConflictSet String - | BackjumpLimitReached String + ExhaustiveSearch ConflictSet ConflictMap + | BackjumpLimitReached --- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps. --- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the --- limit is 'Just 0', backtracking is completely disabled. -logToProgress :: Verbosity -> Maybe Int -> Log Message a -> Progress String SolverFailure a -logToProgress verbosity mbj l = - let ms = proc mbj l - mapFailure f = foldProgress Step (Fail . f) Done - in mapFailure finalError (showMessages ms) -- run with backjump limit applied +-- | Postprocesses a log file. When the dependency solver fails to find a +-- solution, the log ends with a SolverFailure and a message describing the +-- failure. This function discards all log messages and avoids calling +-- 'showMessages' if the log isn't needed (specified by 'keepLog'), for +-- efficiency. +logToProgress :: Bool + -> Verbosity + -> Maybe Int + -> RetryLog Message SolverFailure a + -> Progress String (SolverFailure, String) a +logToProgress keepLog verbosity mbj lg = + if keepLog + then showMessages progress + else foldProgress (const id) Fail Done progress where - -- Proc takes the allowed number of backjumps and a 'Progress' and explores the - -- messages until the maximum number of backjumps has been reached. It filters out - -- and ignores repeated backjumps. If proc reaches the backjump limit, it truncates - -- the 'Progress' and ends it with the last conflict set. Otherwise, it leaves the - -- original result. - proc :: Maybe Int -> Log Message b -> Progress Message (Exhaustiveness, ConflictSet, ConflictMap) b - proc _ (Done x) = Done x - proc _ (Fail (cs, cm)) = Fail (Exhaustive, cs, cm) - proc mbj' (Step x@(Failure cs Backjump) xs@(Step Leave (Step (Failure cs' Backjump) _))) - | cs == cs' = Step x (proc mbj' xs) -- repeated backjumps count as one - proc (Just 0) (Step (Failure cs Backjump) _) = Fail (BackjumpLimit, cs, mempty) -- No final conflict map available - proc (Just n) (Step x@(Failure _ Backjump) xs) = Step x (proc (Just (n - 1)) xs) - proc mbj' (Step x xs) = Step x (proc mbj' xs) + progress = + -- Convert the RetryLog to a Progress (with toProgress) as late as + -- possible, to take advantage of efficient updates at failures. + toProgress $ + mapFailure (\failure -> (failure, finalErrorMsg failure)) lg - finalError :: (Exhaustiveness, ConflictSet, ConflictMap) -> SolverFailure - finalError (exh, cs, cm) = - case exh of - Exhaustive -> - NoSolution cs $ - "After searching the rest of the dependency tree exhaustively, " - ++ "these were the goals I've had most trouble fulfilling: " - ++ showCS cm cs - where - showCS = if verbosity > normal - then CS.showCSWithFrequency - else CS.showCSSortedByFrequency - BackjumpLimit -> - BackjumpLimitReached $ - "Backjump limit reached (" ++ currlimit mbj ++ - "change with --max-backjumps or try to run with --reorder-goals).\n" - where currlimit (Just n) = "currently " ++ show n ++ ", " - currlimit Nothing = "" + finalErrorMsg :: SolverFailure -> String + finalErrorMsg (ExhaustiveSearch cs cm) = + "After searching the rest of the dependency tree exhaustively, " + ++ "these were the goals I've had most trouble fulfilling: " + ++ showCS cm cs + where + showCS = if verbosity > normal + then CS.showCSWithFrequency + else CS.showCSSortedByFrequency + finalErrorMsg BackjumpLimitReached = + "Backjump limit reached (" ++ currlimit mbj ++ + "change with --max-backjumps or try to run with --reorder-goals).\n" + where currlimit (Just n) = "currently " ++ show n ++ ", " + currlimit Nothing = "" diff --git a/Distribution/Solver/Modular/Message.hs b/Distribution/Solver/Modular/Message.hs --- a/Distribution/Solver/Modular/Message.hs +++ b/Distribution/Solver/Modular/Message.hs @@ -53,16 +53,10 @@ (atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms) go !l (Step (Next (Goal (P _ ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) = (atLevel l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms) - go !l (Step (Next (Goal (P qpn) gr)) ms@(Fail _)) = - (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms - -- the previous case potentially arises in the error output, because we remove the backjump itself - -- if we cut the log after the first error go !l (Step (Next (Goal (P qpn) gr)) ms@(Step (Failure _c Backjump) _)) = (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure c fr) ms)) = (atLevel l $ showPackageGoal qpn gr) $ (atLevel l $ showFailure c fr) (go l ms) - go !l (Step (Failure c Backjump) ms@(Step Leave (Step (Failure c' Backjump) _))) - | c == c' = go l ms -- standard display go !l (Step Enter ms) = go (l+1) ms go !l (Step Leave ms) = go (l-1) ms @@ -115,8 +109,10 @@ showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ display pn ++ display vr ++ ", not found in the pkg-config database)" showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")" showFR _ (ConflictingConstraints d1 d2) = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")" -showFR _ (NewPackageIsMissingRequiredExe exe dr) = " (does not contain executable " ++ unUnqualComponentName exe ++ ", which is required by " ++ showDependencyReason dr ++ ")" -showFR _ (PackageRequiresMissingExe qpn exe) = " (requires executable " ++ unUnqualComponentName exe ++ " from " ++ showQPN qpn ++ ", but the executable does not exist)" +showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")" +showFR _ (NewPackageHasUnbuildableRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is not buildable in the current environment, but it is required by " ++ showDependencyReason dr ++ ")" +showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component does not exist)" +showFR _ (PackageRequiresUnbuildableComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is not buildable in the current environment)" showFR _ CannotInstall = " (only already installed instances can be used)" showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" showFR _ Shadowed = " (shadowed by another installed package with same version)" @@ -138,17 +134,21 @@ showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")" showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" +showExposedComponent :: ExposedComponent -> String +showExposedComponent ExposedLib = "library" +showExposedComponent (ExposedExe name) = "executable '" ++ unUnqualComponentName name ++ "'" + constraintSource :: ConstraintSource -> String constraintSource src = "constraint from " ++ showConstraintSource src showConflictingDep :: ConflictingDep -> String -showConflictingDep (ConflictingDep dr mExe qpn ci) = +showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) = let DependencyReason qpn' _ _ = dr - exeStr = case mExe of - Just exe -> " (exe " ++ unUnqualComponentName exe ++ ")" - Nothing -> "" + componentStr = case comp of + ExposedExe exe -> " (exe " ++ unUnqualComponentName exe ++ ")" + ExposedLib -> "" in case ci of Fixed i -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++ - showQPN qpn ++ exeStr ++ "==" ++ showI i + showQPN qpn ++ componentStr ++ "==" ++ showI i Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++ - exeStr ++ showVR vr + componentStr ++ showVR vr diff --git a/Distribution/Solver/Modular/Solver.hs b/Distribution/Solver/Modular/Solver.hs --- a/Distribution/Solver/Modular/Solver.hs +++ b/Distribution/Solver/Modular/Solver.hs @@ -36,6 +36,7 @@ import Distribution.Solver.Modular.Validate import Distribution.Solver.Modular.Linking import Distribution.Solver.Modular.PSQ (PSQ) +import Distribution.Solver.Modular.RetryLog import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.PSQ as PSQ @@ -89,7 +90,7 @@ -> (PN -> PackagePreferences) -- ^ preferences -> Map PN [LabeledPackageConstraint] -- ^ global constraints -> Set PN -- ^ global goals - -> Log Message (Assignment, RevDepMap) + -> RetryLog Message SolverFailure (Assignment, RevDepMap) solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = explorePhase $ detectCycles $ @@ -99,7 +100,9 @@ prunePhase $ buildPhase where - explorePhase = backjumpAndExplore (enableBackjumping sc) (countConflicts sc) + explorePhase = backjumpAndExplore (maxBackjumps sc) + (enableBackjumping sc) + (countConflicts sc) detectCycles = traceTree "cycles.json" id . detectCyclesPhase heuristicsPhase = let heuristicsTree = traceTree "heuristics.json" id diff --git a/Distribution/Solver/Modular/Tree.hs b/Distribution/Solver/Modular/Tree.hs --- a/Distribution/Solver/Modular/Tree.hs +++ b/Distribution/Solver/Modular/Tree.hs @@ -31,7 +31,6 @@ import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.Flag import Distribution.Solver.Types.PackagePath -import Distribution.Types.UnqualComponentName import Language.Haskell.Extension (Extension, Language) type Weight = Double @@ -101,8 +100,10 @@ | MissingPkgconfigPackage PkgconfigName VR | NewPackageDoesNotMatchExistingConstraint ConflictingDep | ConflictingConstraints ConflictingDep ConflictingDep - | NewPackageIsMissingRequiredExe UnqualComponentName (DependencyReason QPN) - | PackageRequiresMissingExe QPN UnqualComponentName + | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN) + | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN) + | PackageRequiresMissingComponent QPN ExposedComponent + | PackageRequiresUnbuildableComponent QPN ExposedComponent | CannotInstall | CannotReinstall | Shadowed @@ -123,7 +124,7 @@ deriving (Eq, Show) -- | Information about a dependency involved in a conflict, for error messages. -data ConflictingDep = ConflictingDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI +data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI deriving (Eq, Show) -- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' diff --git a/Distribution/Solver/Modular/Validate.hs b/Distribution/Solver/Modular/Validate.hs --- a/Distribution/Solver/Modular/Validate.hs +++ b/Distribution/Solver/Modular/Validate.hs @@ -22,7 +22,7 @@ import Language.Haskell.Extension (Extension, Language) -import Distribution.Compat.Map.Strict as M +import Data.Map.Strict as M import Distribution.Compiler (CompilerInfo(..)) import Distribution.Solver.Modular.Assignment @@ -37,7 +37,6 @@ import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) -import Distribution.Types.UnqualComponentName #ifdef DEBUG_CONFLICT_SETS import GHC.Stack (CallStack) @@ -95,28 +94,28 @@ -- | The state needed during validation. data ValidateState = VS { - supportedExt :: Extension -> Bool, - supportedLang :: Language -> Bool, - presentPkgs :: PkgconfigName -> VR -> Bool, - index :: Index, + supportedExt :: Extension -> Bool, + supportedLang :: Language -> Bool, + presentPkgs :: PkgconfigName -> VR -> Bool, + index :: Index, -- Saved, scoped, dependencies. Every time 'validate' makes a package choice, -- it qualifies the package's dependencies and saves them in this map. Then -- the qualified dependencies are available for subsequent flag and stanza -- choices for the same package. - saved :: Map QPN (FlaggedDeps QPN), + saved :: Map QPN (FlaggedDeps QPN), - pa :: PreAssignment, + pa :: PreAssignment, - -- Map from package name to the executables that are provided by the chosen - -- instance of that package. - availableExes :: Map QPN [UnqualComponentName], + -- Map from package name to the components that are provided by the chosen + -- instance of that package, and whether those components are buildable. + availableComponents :: Map QPN (Map ExposedComponent IsBuildable), - -- Map from package name to the executables that are required from that + -- Map from package name to the components that are required from that -- package. - requiredExes :: Map QPN ExeDeps, + requiredComponents :: Map QPN ComponentDependencyReasons, - qualifyOptions :: QualifyOptions + qualifyOptions :: QualifyOptions } newtype Validate a = Validate (Reader ValidateState a) @@ -133,12 +132,12 @@ -- are associated with MergedPkgDeps. type PPreAssignment = Map QPN MergedPkgDep --- | A dependency on a package, including its DependencyReason. -data PkgDep = PkgDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI +-- | A dependency on a component, including its DependencyReason. +data PkgDep = PkgDep (DependencyReason QPN) (PkgComponent QPN) CI --- | Map from executable name to one of the reasons that the executable is +-- | Map from component name to one of the reasons that the component is -- required. -type ExeDeps = Map UnqualComponentName (DependencyReason QPN) +type ComponentDependencyReasons = Map ExposedComponent (DependencyReason QPN) -- | MergedPkgDep records constraints about the instances that can still be -- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a @@ -146,15 +145,15 @@ -- them. It also records whether a package is a build-tool dependency, for each -- reason that it was introduced. -- --- It is important to store the executable name with the version constraint, for +-- It is important to store the component name with the version constraint, for -- error messages, because whether something is a build-tool dependency affects -- its qualifier, which affects which constraint is applied. data MergedPkgDep = - MergedDepFixed (Maybe UnqualComponentName) (DependencyReason QPN) I + MergedDepFixed ExposedComponent (DependencyReason QPN) I | MergedDepConstrained [VROrigin] -- | Version ranges paired with origins. -type VROrigin = (VR, Maybe UnqualComponentName, DependencyReason QPN) +type VROrigin = (VR, ExposedComponent, DependencyReason QPN) -- | The information needed to create a 'Fail' node. type Conflict = (ConflictSet, FailReason) @@ -204,11 +203,11 @@ pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs idx <- asks index -- obtain the index svd <- asks saved -- obtain saved dependencies - aExes <- asks availableExes - rExes <- asks requiredExes + aComps <- asks availableComponents + rComps <- asks requiredComponents qo <- asks qualifyOptions -- obtain dependencies and index-dictated exclusions introduced by the choice - let (PInfo deps exes _ mfr) = idx ! pn ! i + let (PInfo deps comps _ mfr) = idx ! pn ! i -- qualify the deps in the current scope let qdeps = qualifyDeps qo qpn deps -- the new active constraints are given by the instance we have chosen, @@ -223,21 +222,21 @@ Just fr -> -- The index marks this as an invalid choice. We can stop. return (Fail (varToConflictSet (P qpn)) fr) Nothing -> - let newDeps :: Either Conflict (PPreAssignment, Map QPN ExeDeps) + let newDeps :: Either Conflict (PPreAssignment, Map QPN ComponentDependencyReasons) newDeps = do nppa <- mnppa - rExes' <- extendRequiredExes aExes rExes newactives - checkExesInNewPackage rExes qpn exes - return (nppa, rExes') + rComps' <- extendRequiredComponents aComps rComps newactives + checkComponentsInNewPackage (M.findWithDefault M.empty qpn rComps) qpn comps + return (nppa, rComps') in case newDeps of - Left (c, fr) -> -- We have an inconsistency. We can stop. - return (Fail c fr) - Right (nppa, rExes') -> -- We have an updated partial assignment for the recursive validation. - local (\ s -> s { pa = PA nppa pfa psa - , saved = nsvd - , availableExes = M.insert qpn exes aExes - , requiredExes = rExes' - }) r + Left (c, fr) -> -- We have an inconsistency. We can stop. + return (Fail c fr) + Right (nppa, rComps') -> -- We have an updated partial assignment for the recursive validation. + local (\ s -> s { pa = PA nppa pfa psa + , saved = nsvd + , availableComponents = M.insert qpn comps aComps + , requiredComponents = rComps' + }) r -- What to do for flag nodes ... goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) @@ -247,8 +246,8 @@ langSupported <- asks supportedLang -- obtain the supported languages pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs svd <- asks saved -- obtain saved dependencies - aExes <- asks availableExes - rExes <- asks requiredExes + aComps <- asks availableComponents + rComps <- asks requiredComponents -- Note that there should be saved dependencies for the package in question, -- because while building, we do not choose flags before we see the packages -- that define them. @@ -261,13 +260,13 @@ -- We now try to get the new active dependencies we might learn about because -- we have chosen a new flag. let newactives = extractNewDeps (F qfn) b npfa psa qdeps - mNewRequiredExes = extendRequiredExes aExes rExes newactives + mNewRequiredComps = extendRequiredComponents aComps rComps newactives -- As in the package case, we try to extend the partial assignment. let mnppa = extend extSupported langSupported pkgPresent newactives ppa - case liftM2 (,) mnppa mNewRequiredExes of + case liftM2 (,) mnppa mNewRequiredComps of Left (c, fr) -> return (Fail c fr) -- inconsistency found - Right (nppa, rExes') -> - local (\ s -> s { pa = PA nppa npfa psa, requiredExes = rExes' }) r + Right (nppa, rComps') -> + local (\ s -> s { pa = PA nppa npfa psa, requiredComponents = rComps' }) r -- What to do for stanza nodes (similar to flag nodes) ... goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) @@ -277,8 +276,8 @@ langSupported <- asks supportedLang -- obtain the supported languages pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs svd <- asks saved -- obtain saved dependencies - aExes <- asks availableExes - rExes <- asks requiredExes + aComps <- asks availableComponents + rComps <- asks requiredComponents -- Note that there should be saved dependencies for the package in question, -- because while building, we do not choose flags before we see the packages -- that define them. @@ -291,26 +290,40 @@ -- We now try to get the new active dependencies we might learn about because -- we have chosen a new flag. let newactives = extractNewDeps (S qsn) b pfa npsa qdeps - mNewRequiredExes = extendRequiredExes aExes rExes newactives + mNewRequiredComps = extendRequiredComponents aComps rComps newactives -- As in the package case, we try to extend the partial assignment. let mnppa = extend extSupported langSupported pkgPresent newactives ppa - case liftM2 (,) mnppa mNewRequiredExes of + case liftM2 (,) mnppa mNewRequiredComps of Left (c, fr) -> return (Fail c fr) -- inconsistency found - Right (nppa, rExes') -> - local (\ s -> s { pa = PA nppa pfa npsa, requiredExes = rExes' }) r + Right (nppa, rComps') -> + local (\ s -> s { pa = PA nppa pfa npsa, requiredComponents = rComps' }) r --- | Check that a newly chosen package instance contains all executables that --- are required from that package so far. -checkExesInNewPackage :: Map QPN ExeDeps - -> QPN - -> [UnqualComponentName] - -> Either Conflict () -checkExesInNewPackage required qpn providedExes = - case M.toList $ deleteKeys providedExes (M.findWithDefault M.empty qpn required) of - (missingExe, dr) : _ -> let cs = CS.insert (P qpn) $ dependencyReasonToCS dr - in Left (cs, NewPackageIsMissingRequiredExe missingExe dr) - [] -> Right () +-- | Check that a newly chosen package instance contains all components that +-- are required from that package so far. The components must also be buildable. +checkComponentsInNewPackage :: ComponentDependencyReasons + -> QPN + -> Map ExposedComponent IsBuildable + -> Either Conflict () +checkComponentsInNewPackage required qpn providedComps = + case M.toList $ deleteKeys (M.keys providedComps) required of + (missingComp, dr) : _ -> + Left $ mkConflict missingComp dr NewPackageIsMissingRequiredComponent + [] -> + case M.toList $ deleteKeys buildableProvidedComps required of + (unbuildableComp, dr) : _ -> + Left $ mkConflict unbuildableComp dr NewPackageHasUnbuildableRequiredComponent + [] -> Right () where + mkConflict :: ExposedComponent + -> DependencyReason QPN + -> (ExposedComponent -> DependencyReason QPN -> FailReason) + -> Conflict + mkConflict comp dr mkFailure = + (CS.insert (P qpn) (dependencyReasonToCS dr), mkFailure comp dr) + + buildableProvidedComps :: [ExposedComponent] + buildableProvidedComps = [comp | (comp, IsBuildable True) <- M.toList providedComps] + deleteKeys :: Ord k => [k] -> Map k v -> Map k v deleteKeys ks m = L.foldr M.delete m ks @@ -386,18 +399,23 @@ extendSingle a (LDep dr (Pkg pn vr)) = if pkgPresent pn vr then Right a else Left (dependencyReasonToCS dr, MissingPkgconfigPackage pn vr) - extendSingle a (LDep dr (Dep mExe qpn ci)) = + extendSingle a (LDep dr (Dep dep@(PkgComponent qpn _) ci)) = let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a - in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr mExe qpn ci) of + in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr dep ci) of Left (c, (d, d')) -> Left (c, ConflictingConstraints d d') Right x -> Right x -- | Extend a package preassignment with a package choice. For example, when -- the solver chooses foo-2.0, it tries to add the constraint foo==2.0. +-- +-- TODO: The new constraint is implemented as a dependency from foo to foo's +-- library. That isn't correct, because foo might only be needed as a build +-- tool dependency. The implemention may need to change when we support +-- component-based dependency solving. extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment extendWithPackageChoice (PI qpn i) ppa = let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa - newChoice = PkgDep (DependencyReason qpn M.empty S.empty) Nothing qpn (Fixed i) + newChoice = PkgDep (DependencyReason qpn M.empty S.empty) (PkgComponent qpn ExposedLib) (Fixed i) in case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of Left (c, (d, _d')) -> -- Don't include the package choice in the -- FailReason, because it is redundant. @@ -426,76 +444,93 @@ (?loc :: CallStack) => #endif MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep -merge (MergedDepFixed mExe1 vs1 i1) (PkgDep vs2 mExe2 p ci@(Fixed i2)) - | i1 == i2 = Right $ MergedDepFixed mExe1 vs1 i1 +merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i2)) + | i1 == i2 = Right $ MergedDepFixed comp1 vs1 i1 | otherwise = Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 - , ( ConflictingDep vs1 mExe1 p (Fixed i1) - , ConflictingDep vs2 mExe2 p ci ) ) + , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1) + , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) -merge (MergedDepFixed mExe1 vs1 i@(I v _)) (PkgDep vs2 mExe2 p ci@(Constrained vr)) - | checkVR vr v = Right $ MergedDepFixed mExe1 vs1 i +merge (MergedDepFixed comp1 vs1 i@(I v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr)) + | checkVR vr v = Right $ MergedDepFixed comp1 vs1 i | otherwise = Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 - , ( ConflictingDep vs1 mExe1 p (Fixed i) - , ConflictingDep vs2 mExe2 p ci ) ) + , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i) + , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) -merge (MergedDepConstrained vrOrigins) (PkgDep vs2 mExe2 p ci@(Fixed i@(I v _))) = +merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I v _))) = go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ... where go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep - go [] = Right (MergedDepFixed mExe2 vs2 i) - go ((vr, mExe1, vs1) : vros) + go [] = Right (MergedDepFixed comp2 vs2 i) + go ((vr, comp1, vs1) : vros) | checkVR vr v = go vros | otherwise = Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2 - , ( ConflictingDep vs1 mExe1 p (Constrained vr) - , ConflictingDep vs2 mExe2 p ci ) ) + , ( ConflictingDep vs1 (PkgComponent p comp1) (Constrained vr) + , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) -merge (MergedDepConstrained vrOrigins) (PkgDep vs2 mExe2 _ (Constrained vr)) = +merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent _ comp2) (Constrained vr)) = Right (MergedDepConstrained $ -- TODO: This line appends the new version range, to preserve the order used -- before a refactoring. Consider prepending the version range, if there is -- no negative performance impact. - vrOrigins ++ [(vr, mExe2, vs2)]) + vrOrigins ++ [(vr, comp2, vs2)]) -- | Takes a list of new dependencies and uses it to try to update the map of --- known executable dependencies. It returns a failure when a new dependency --- requires an executable that is missing from one of the previously chosen +-- known component dependencies. It returns a failure when a new dependency +-- requires a component that is missing or unbuildable in a previously chosen -- packages. -extendRequiredExes :: Map QPN [UnqualComponentName] - -> Map QPN ExeDeps - -> [LDep QPN] - -> Either Conflict (Map QPN ExeDeps) -extendRequiredExes available = foldM extendSingle +extendRequiredComponents :: Map QPN (Map ExposedComponent IsBuildable) + -> Map QPN ComponentDependencyReasons + -> [LDep QPN] + -> Either Conflict (Map QPN ComponentDependencyReasons) +extendRequiredComponents available = foldM extendSingle where - extendSingle :: Map QPN ExeDeps -> LDep QPN -> Either Conflict (Map QPN ExeDeps) - extendSingle required (LDep dr (Dep (Just exe) qpn _)) = - let exeDeps = M.findWithDefault M.empty qpn required - in -- Only check for the existence of the exe if its package has already - -- been chosen. + extendSingle :: Map QPN ComponentDependencyReasons + -> LDep QPN + -> Either Conflict (Map QPN ComponentDependencyReasons) + extendSingle required (LDep dr (Dep (PkgComponent qpn comp) _)) = + let compDeps = M.findWithDefault M.empty qpn required + in -- Only check for the existence of the component if its package has + -- already been chosen. case M.lookup qpn available of - Just exes - | L.notElem exe exes -> let cs = CS.insert (P qpn) (dependencyReasonToCS dr) - in Left (cs, PackageRequiresMissingExe qpn exe) - _ -> Right $ M.insertWith M.union qpn (M.insert exe dr exeDeps) required - extendSingle required _ = Right required + Just comps + | M.notMember comp comps -> + Left $ mkConflict qpn comp dr PackageRequiresMissingComponent + | L.notElem comp (buildableComps comps) -> + Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent + _ -> + Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required + extendSingle required _ = Right required + mkConflict :: QPN + -> ExposedComponent + -> DependencyReason QPN + -> (QPN -> ExposedComponent -> FailReason) + -> Conflict + mkConflict qpn comp dr mkFailure = + (CS.insert (P qpn) (dependencyReasonToCS dr), mkFailure qpn comp) + + buildableComps :: Map comp IsBuildable -> [comp] + buildableComps comps = [comp | (comp, IsBuildable True) <- M.toList comps] + + -- | Interface. validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS { - supportedExt = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported - (\ es -> let s = S.fromList es in \ x -> S.member x s) - (compilerInfoExtensions cinfo) - , supportedLang = maybe (const True) - (flip L.elem) -- use list lookup because language list is small and no Ord instance - (compilerInfoLanguages cinfo) - , presentPkgs = pkgConfigPkgIsPresent pkgConfigDb - , index = idx - , saved = M.empty - , pa = PA M.empty M.empty M.empty - , availableExes = M.empty - , requiredExes = M.empty - , qualifyOptions = defaultQualifyOptions idx + supportedExt = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported + (\ es -> let s = S.fromList es in \ x -> S.member x s) + (compilerInfoExtensions cinfo) + , supportedLang = maybe (const True) + (flip L.elem) -- use list lookup because language list is small and no Ord instance + (compilerInfoLanguages cinfo) + , presentPkgs = pkgConfigPkgIsPresent pkgConfigDb + , index = idx + , saved = M.empty + , pa = PA M.empty M.empty M.empty + , availableComponents = M.empty + , requiredComponents = M.empty + , qualifyOptions = defaultQualifyOptions idx } diff --git a/bootstrap.sh b/bootstrap.sh --- a/bootstrap.sh +++ b/bootstrap.sh @@ -213,26 +213,26 @@ # >= 3.1 && < 3.2 DEEPSEQ_VER="1.4.3.0"; DEEPSEQ_VER_REGEXP="1\.[1-9]\." # >= 1.1 && < 2 -BINARY_VER="0.8.3.0"; BINARY_VER_REGEXP="[0]\.[78]\." +BINARY_VER="0.8.5.1"; BINARY_VER_REGEXP="[0]\.[78]\." # >= 0.7 && < 0.9 TEXT_VER="1.2.3.0"; TEXT_VER_REGEXP="[1]\.[2]\." # >= 1.2 && < 1.3 NETWORK_URI_VER="2.6.1.0"; NETWORK_URI_VER_REGEXP="2\.6\.(0\.[2-9]|[1-9])" # >= 2.6.0.2 && < 2.7 -NETWORK_VER="2.6.3.4"; NETWORK_VER_REGEXP="2\.[0-6]\." +NETWORK_VER="2.7.0.0"; NETWORK_VER_REGEXP="2\.[0-7]\." # >= 2.0 && < 2.7 -CABAL_VER="2.2.0.1"; CABAL_VER_REGEXP="2\.2\.[0-9]" - # >= 2.2 && < 2.3 +CABAL_VER="2.4.0.1"; CABAL_VER_REGEXP="2\.4\.[0-9]" + # >= 2.4 && < 2.5 TRANS_VER="0.5.5.0"; TRANS_VER_REGEXP="0\.[45]\." # >= 0.2.* && < 0.6 MTL_VER="2.2.2"; MTL_VER_REGEXP="[2]\." # >= 2.0 && < 3 -HTTP_VER="4000.3.11"; HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)" +HTTP_VER="4000.3.12"; HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)" # >= 4000.2.5 < 4000.4 ZLIB_VER="0.6.2"; ZLIB_VER_REGEXP="(0\.5\.([3-9]|1[0-9])|0\.6)" # >= 0.5.3 && <= 0.7 -TIME_VER="1.8.0.3" TIME_VER_REGEXP="1\.[1-8]\.?" - # >= 1.1 && < 1.9 +TIME_VER="1.9.1" TIME_VER_REGEXP="1\.[1-9]\.?" + # >= 1.1 && < 1.10 RANDOM_VER="1.1" RANDOM_VER_REGEXP="1\.[01]\.?" # >= 1 && < 1.2 STM_VER="2.4.5.0"; STM_VER_REGEXP="2\." @@ -249,7 +249,7 @@ # 0.11.* RESOLV_VER="0.1.1.1"; RESOLV_VER_REGEXP="0\.1\.[1-9]" # >= 0.1.1 && < 0.2 -MINTTY_VER="0.1.1"; MINTTY_VER_REGEXP="0\.1\.?" +MINTTY_VER="0.1.2"; MINTTY_VER_REGEXP="0\.1\.?" # 0.1.* ECHO_VER="0.1.3"; ECHO_VER_REGEXP="0\.1\.[3-9]" # >= 0.1.3 && < 0.2 @@ -261,6 +261,10 @@ # >= 0.5.2 && < 0.6 TAR_VER="0.5.1.0"; TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.[3-9]|0\.1[0-9])\.?" # >= 0.5.0.3 && < 0.6 +DIGEST_VER="0.0.1.2"; DIGEST_REGEXP="0\.0\.(1\.[2-9]|[2-9]\.?)" + # >= 0.0.1.2 && < 0.1 +ZIP_ARCHIVE_VER="0.3.3"; ZIP_ARCHIVE_REGEXP="0\.3\.[3-9]" + # >= 0.3.3 && < 0.4 HACKAGE_URL="https://hackage.haskell.org/package" @@ -452,6 +456,8 @@ info_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP} info_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP} info_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP} +info_pkg "digest" ${DIGEST_VER} ${DIGEST_REGEXP} +info_pkg "zip-archive" ${ZIP_ARCHIVE_VER} ${ZIP_ARCHIVE_REGEXP} info_pkg "hackage-security" ${HACKAGE_SECURITY_VER} \ ${HACKAGE_SECURITY_VER_REGEXP} @@ -488,6 +494,8 @@ do_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP} do_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP} do_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP} +do_pkg "digest" ${DIGEST_VER} ${DIGEST_REGEXP} +do_pkg "zip-archive" ${ZIP_ARCHIVE_VER} ${ZIP_ARCHIVE_REGEXP} do_pkg "hackage-security" ${HACKAGE_SECURITY_VER} \ ${HACKAGE_SECURITY_VER_REGEXP} diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -1,13 +1,15 @@ +Cabal-Version: >= 1.10 +-- NOTE: This file is autogenerated from 'cabal-install.cabal.pp'. +-- DO NOT EDIT MANUALLY. +-- To update this file, edit 'cabal-install.cabal.pp' and run +-- 'make cabal-install-prod' in the project's root folder. Name: cabal-install -Version: 2.2.0.0 +Version: 2.4.0.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing Haskell software by automating the fetching, configuration, compilation and installation of Haskell libraries and programs. - . - This package only provides an executable and cannot be used as a - library (ignore the module listing below.) homepage: http://www.haskell.org/cabal/ bug-reports: https://github.com/haskell/cabal/issues License: BSD3 @@ -17,7 +19,6 @@ Copyright: 2003-2018, Cabal Development Team Category: Distribution Build-type: Custom -Cabal-Version: >= 1.10 Extra-Source-Files: README.md bash-completion/cabal bootstrap.sh changelog tests/README.md @@ -30,6 +31,9 @@ tests/IntegrationTests2/build/keep-going/p/p.cabal tests/IntegrationTests2/build/keep-going/q/Q.hs tests/IntegrationTests2/build/keep-going/q/q.cabal + tests/IntegrationTests2/build/local-tarball/cabal.project + tests/IntegrationTests2/build/local-tarball/q/Q.hs + tests/IntegrationTests2/build/local-tarball/q/q.cabal tests/IntegrationTests2/build/setup-custom1/A.hs tests/IntegrationTests2/build/setup-custom1/Setup.hs tests/IntegrationTests2/build/setup-custom1/a.cabal @@ -89,6 +93,10 @@ tests/IntegrationTests2/targets/variety/p.cabal -- END gen-extra-source-files + -- Additional manual extra-source-files: + tests/IntegrationTests2/build/local-tarball/p-0.1.tar.gz + + source-repository head type: git location: https://github.com/haskell/cabal/ @@ -114,32 +122,30 @@ default: False manual: True -flag lib - description: Build cabal-install as a library. Please only use this if you are a cabal-install developer. - Default: False - manual: True - --- Build everything (including the test binaries) as a single static binary --- instead of 5 discrete binaries. --- This is useful for CI where we build our binaries on one machine, and then --- ship them to another machine for testing. Since the test binaries are --- statically linked (making deployment easier), if we build five executables, --- that means we need to ship ALL 5 binaries (with 5 versions of all the --- statically linked libraries) to the test machines. This reduces that to one --- binary and one set of linked libraries. -flag monolithic - description: Build cabal-install also with all of its test and support code. Used by our continuous integration. - default: False - manual: True +custom-setup + setup-depends: + Cabal >= 2.2, + base, + process >= 1.1.0.1 && < 1.7, + filepath >= 1.3 && < 1.5 -library +executable cabal + main-is: Main.hs + hs-source-dirs: main + default-language: Haskell2010 ghc-options: -Wall -fwarn-tabs if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances - exposed-modules: + ghc-options: -rtsopts -threaded + + -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a + if os(aix) + extra-libraries: bsd + hs-source-dirs: . + other-modules: Distribution.Client.BuildReports.Anonymous Distribution.Client.BuildReports.Storage Distribution.Client.BuildReports.Types @@ -147,6 +153,7 @@ Distribution.Client.Check Distribution.Client.CmdBench Distribution.Client.CmdBuild + Distribution.Client.CmdClean Distribution.Client.CmdConfigure Distribution.Client.CmdUpdate Distribution.Client.CmdErrorMessages @@ -157,6 +164,8 @@ Distribution.Client.CmdRepl Distribution.Client.CmdRun Distribution.Client.CmdTest + Distribution.Client.CmdLegacy + Distribution.Client.CmdSdist Distribution.Client.Compat.Directory Distribution.Client.Compat.ExecutablePath Distribution.Client.Compat.FileLock @@ -234,6 +243,7 @@ Distribution.Client.Utils Distribution.Client.Utils.Assertion Distribution.Client.Utils.Json + Distribution.Client.VCS Distribution.Client.Win32SelfUpgrade Distribution.Client.World Distribution.Solver.Compat.Prelude @@ -286,17 +296,15 @@ Distribution.Solver.Types.Variable Paths_cabal_install - -- NOTE: when updating build-depends, don't forget to update version regexps - -- in bootstrap.sh. build-depends: async >= 2.0 && < 3, array >= 0.4 && < 0.6, - base >= 4.5 && < 5, + base >= 4.6 && < 5, base16-bytestring >= 0.1.1 && < 0.2, binary >= 0.7 && < 0.9, bytestring >= 0.10.2 && < 1, - Cabal >= 2.2 && < 2.3, - containers >= 0.4 && < 0.6, + Cabal == 2.4.*, + containers >= 0.5 && < 0.7, cryptohash-sha256 >= 0.11 && < 0.12, deepseq >= 1.3 && < 1.5, directory >= 1.2.2.0 && < 1.4, @@ -307,15 +315,18 @@ HTTP >= 4000.1.5 && < 4000.4, mtl >= 2.0 && < 3, network-uri >= 2.6.0.2 && < 2.7, - network >= 2.6 && < 2.7, + network >= 2.6 && < 2.8, pretty >= 1.1 && < 1.2, process >= 1.1.0.2 && < 1.7, random >= 1 && < 1.2, stm >= 2.0 && < 3, tar >= 0.5.0.3 && < 0.6, - time >= 1.4 && < 1.9, + time >= 1.4 && < 1.10, zlib >= 0.5.3 && < 0.7, - hackage-security >= 0.5.2.2 && < 0.6 + hackage-security >= 0.5.2.2 && < 0.6, + text >= 1.2.3 && < 1.3, + zip-archive >= 0.3.2.5 && < 0.4, + parsec >= 3.1.13.0 && < 3.2 if flag(native-dns) if os(windows) @@ -326,7 +337,7 @@ if os(windows) build-depends: Win32 >= 2 && < 3 else - build-depends: unix >= 2.5 && < 2.8 + build-depends: unix >= 2.5 && < 2.9 if flag(debug-expensive-assertions) cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS @@ -338,446 +349,3 @@ if flag(debug-tracetree) cpp-options: -DDEBUG_TRACETREE build-depends: tracetree >= 0.1 && < 0.2 - - if !flag(lib) - buildable: False - - default-language: Haskell2010 - -executable cabal - main-is: Main.hs - hs-source-dirs: main - - ghc-options: -Wall -fwarn-tabs -rtsopts - if impl(ghc >= 8.0) - ghc-options: -Wcompat - -Wnoncanonical-monad-instances - -Wnoncanonical-monadfail-instances - - other-modules: Paths_cabal_install - - if flag(lib) - build-depends: - cabal-install, - Cabal >= 2.2 && < 2.3, - base, - directory, - filepath - else - hs-source-dirs: . - build-depends: - async >= 2.0 && < 3, - array >= 0.4 && < 0.6, - base >= 4.5 && < 5, - base16-bytestring >= 0.1.1 && < 0.2, - binary >= 0.7 && < 0.9, - bytestring >= 0.10.2 && < 1, - Cabal >= 2.2 && < 2.3, - containers >= 0.4 && < 0.6, - cryptohash-sha256 >= 0.11 && < 0.12, - deepseq >= 1.3 && < 1.5, - directory >= 1.2.2.0 && < 1.4, - echo >= 0.1.3 && < 0.2, - edit-distance >= 0.2.2 && < 0.3, - filepath >= 1.3 && < 1.5, - hashable >= 1.0 && < 2, - HTTP >= 4000.1.5 && < 4000.4, - mtl >= 2.0 && < 3, - network >= 2.6 && < 2.7, - network-uri >= 2.6 && < 2.7, - pretty >= 1.1 && < 1.2, - process >= 1.2 && < 1.7, - random >= 1 && < 1.2, - stm >= 2.0 && < 3, - tar >= 0.5.0.3 && < 0.6, - time >= 1.4 && < 1.9, - zlib >= 0.5.3 && < 0.7, - hackage-security >= 0.5.2.2 && < 0.6 - - other-modules: - Distribution.Client.BuildReports.Anonymous - Distribution.Client.BuildReports.Storage - Distribution.Client.BuildReports.Types - Distribution.Client.BuildReports.Upload - Distribution.Client.Check - Distribution.Client.CmdBench - Distribution.Client.CmdBuild - Distribution.Client.CmdConfigure - Distribution.Client.CmdUpdate - Distribution.Client.CmdErrorMessages - Distribution.Client.CmdExec - Distribution.Client.CmdFreeze - Distribution.Client.CmdHaddock - Distribution.Client.CmdInstall - Distribution.Client.CmdRepl - Distribution.Client.CmdRun - Distribution.Client.CmdTest - Distribution.Client.Compat.Directory - Distribution.Client.Compat.ExecutablePath - Distribution.Client.Compat.FileLock - Distribution.Client.Compat.FilePerms - Distribution.Client.Compat.Prelude - Distribution.Client.Compat.Process - Distribution.Client.Compat.Semaphore - Distribution.Client.Config - Distribution.Client.Configure - Distribution.Client.Dependency - Distribution.Client.Dependency.Types - Distribution.Client.DistDirLayout - Distribution.Client.Exec - Distribution.Client.Fetch - Distribution.Client.FetchUtils - Distribution.Client.FileMonitor - Distribution.Client.Freeze - Distribution.Client.GZipUtils - Distribution.Client.GenBounds - Distribution.Client.Get - Distribution.Client.Glob - Distribution.Client.GlobalFlags - Distribution.Client.Haddock - Distribution.Client.HttpUtils - Distribution.Client.IndexUtils - Distribution.Client.IndexUtils.Timestamp - Distribution.Client.Init - Distribution.Client.Init.Heuristics - Distribution.Client.Init.Licenses - Distribution.Client.Init.Types - Distribution.Client.Install - Distribution.Client.InstallPlan - Distribution.Client.InstallSymlink - Distribution.Client.JobControl - Distribution.Client.List - Distribution.Client.Manpage - Distribution.Client.Nix - Distribution.Client.Outdated - Distribution.Client.PackageHash - Distribution.Client.PackageUtils - Distribution.Client.ParseUtils - Distribution.Client.ProjectBuilding - Distribution.Client.ProjectBuilding.Types - Distribution.Client.ProjectConfig - Distribution.Client.ProjectConfig.Legacy - Distribution.Client.ProjectConfig.Types - Distribution.Client.ProjectOrchestration - Distribution.Client.ProjectPlanOutput - Distribution.Client.ProjectPlanning - Distribution.Client.ProjectPlanning.Types - Distribution.Client.RebuildMonad - Distribution.Client.Reconfigure - Distribution.Client.Run - Distribution.Client.Sandbox - Distribution.Client.Sandbox.Index - Distribution.Client.Sandbox.PackageEnvironment - Distribution.Client.Sandbox.Timestamp - Distribution.Client.Sandbox.Types - Distribution.Client.SavedFlags - Distribution.Client.Security.DNS - Distribution.Client.Security.HTTP - Distribution.Client.Setup - Distribution.Client.SetupWrapper - Distribution.Client.SolverInstallPlan - Distribution.Client.SourceFiles - Distribution.Client.SourceRepoParse - Distribution.Client.SrcDist - Distribution.Client.Store - Distribution.Client.Tar - Distribution.Client.TargetSelector - Distribution.Client.Targets - Distribution.Client.Types - Distribution.Client.Update - Distribution.Client.Upload - Distribution.Client.Utils - Distribution.Client.Utils.Assertion - Distribution.Client.Utils.Json - Distribution.Client.Win32SelfUpgrade - Distribution.Client.World - Distribution.Solver.Compat.Prelude - Distribution.Solver.Modular - Distribution.Solver.Modular.Assignment - Distribution.Solver.Modular.Builder - Distribution.Solver.Modular.Configured - Distribution.Solver.Modular.ConfiguredConversion - Distribution.Solver.Modular.ConflictSet - Distribution.Solver.Modular.Cycles - Distribution.Solver.Modular.Dependency - Distribution.Solver.Modular.Explore - Distribution.Solver.Modular.Flag - Distribution.Solver.Modular.Index - Distribution.Solver.Modular.IndexConversion - Distribution.Solver.Modular.LabeledGraph - Distribution.Solver.Modular.Linking - Distribution.Solver.Modular.Log - Distribution.Solver.Modular.Message - Distribution.Solver.Modular.PSQ - Distribution.Solver.Modular.Package - Distribution.Solver.Modular.Preference - Distribution.Solver.Modular.RetryLog - Distribution.Solver.Modular.Solver - Distribution.Solver.Modular.Tree - Distribution.Solver.Modular.Validate - Distribution.Solver.Modular.Var - Distribution.Solver.Modular.Version - Distribution.Solver.Modular.WeightedPSQ - Distribution.Solver.Types.ComponentDeps - Distribution.Solver.Types.ConstraintSource - Distribution.Solver.Types.DependencyResolver - Distribution.Solver.Types.Flag - Distribution.Solver.Types.InstSolverPackage - Distribution.Solver.Types.InstalledPreference - Distribution.Solver.Types.LabeledPackageConstraint - Distribution.Solver.Types.OptionalStanza - Distribution.Solver.Types.PackageConstraint - Distribution.Solver.Types.PackageFixedDeps - Distribution.Solver.Types.PackageIndex - Distribution.Solver.Types.PackagePath - Distribution.Solver.Types.PackagePreferences - Distribution.Solver.Types.PkgConfigDb - Distribution.Solver.Types.Progress - Distribution.Solver.Types.ResolverPackage - Distribution.Solver.Types.Settings - Distribution.Solver.Types.SolverId - Distribution.Solver.Types.SolverPackage - Distribution.Solver.Types.SourcePackage - Distribution.Solver.Types.Variable - - if flag(native-dns) - if os(windows) - build-depends: windns >= 0.1.0 && < 0.2 - else - build-depends: resolv >= 0.1.1 && < 0.2 - - if os(windows) - build-depends: Win32 >= 2 && < 3 - else - build-depends: unix >= 2.5 && < 2.8 - - if flag(debug-expensive-assertions) - cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS - - if flag(debug-conflict-sets) - cpp-options: -DDEBUG_CONFLICT_SETS - build-depends: base >= 4.8 - - if flag(debug-tracetree) - cpp-options: -DDEBUG_TRACETREE - build-depends: tracetree >= 0.1 && < 0.2 - - if flag(monolithic) - hs-source-dirs: tests - other-modules: - UnitTests - MemoryUsageTests - SolverQuickCheck - IntegrationTests2 - - UnitTests.Distribution.Client.ArbitraryInstances - UnitTests.Distribution.Client.FileMonitor - UnitTests.Distribution.Client.GZipUtils - UnitTests.Distribution.Client.Glob - UnitTests.Distribution.Client.IndexUtils.Timestamp - UnitTests.Distribution.Client.InstallPlan - UnitTests.Distribution.Client.JobControl - UnitTests.Distribution.Client.ProjectConfig - UnitTests.Distribution.Client.Sandbox - UnitTests.Distribution.Client.Sandbox.Timestamp - UnitTests.Distribution.Client.Store - UnitTests.Distribution.Client.Tar - UnitTests.Distribution.Client.Targets - UnitTests.Distribution.Client.UserConfig - UnitTests.Distribution.Solver.Modular.Builder - UnitTests.Distribution.Solver.Modular.DSL - UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils - UnitTests.Distribution.Solver.Modular.MemoryUsage - UnitTests.Distribution.Solver.Modular.QuickCheck - UnitTests.Distribution.Solver.Modular.QuickCheck.Utils - UnitTests.Distribution.Solver.Modular.RetryLog - UnitTests.Distribution.Solver.Modular.Solver - UnitTests.Distribution.Solver.Modular.WeightedPSQ - UnitTests.Options - - cpp-options: -DMONOLITHIC - build-depends: - Cabal >= 2.2 && < 2.3, - QuickCheck >= 2.8.2, - array, - async, - bytestring, - containers, - deepseq, - directory, - edit-distance, - filepath, - hashable, - mtl, - network, - network-uri, - pretty-show >= 1.6.15, - random, - tagged, - tar, - tasty >= 1.0 && < 1.1, - tasty-hunit >= 0.10, - tasty-quickcheck, - time, - zlib - - ghc-options: -threaded - - -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a - if os(aix) - extra-libraries: bsd - - default-language: Haskell2010 - --- Small, fast running tests. -Test-Suite unit-tests - type: exitcode-stdio-1.0 - main-is: UnitTests.hs - hs-source-dirs: tests - ghc-options: -Wall -fwarn-tabs -main-is UnitTests - other-modules: - UnitTests.Distribution.Client.ArbitraryInstances - UnitTests.Distribution.Client.Targets - UnitTests.Distribution.Client.FileMonitor - UnitTests.Distribution.Client.Glob - UnitTests.Distribution.Client.GZipUtils - UnitTests.Distribution.Client.Sandbox - UnitTests.Distribution.Client.Sandbox.Timestamp - UnitTests.Distribution.Client.Store - UnitTests.Distribution.Client.Tar - UnitTests.Distribution.Client.UserConfig - UnitTests.Distribution.Client.ProjectConfig - UnitTests.Distribution.Client.JobControl - UnitTests.Distribution.Client.IndexUtils.Timestamp - UnitTests.Distribution.Client.InstallPlan - UnitTests.Distribution.Solver.Modular.Builder - UnitTests.Distribution.Solver.Modular.RetryLog - UnitTests.Distribution.Solver.Modular.Solver - UnitTests.Distribution.Solver.Modular.DSL - UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils - UnitTests.Distribution.Solver.Modular.WeightedPSQ - UnitTests.Options - build-depends: - array, - base, - async, - bytestring, - cabal-install, - Cabal, - containers, - deepseq, - mtl, - random, - directory, - filepath, - tar, - time, - zlib, - network-uri, - network, - tasty >= 1.0 && < 1.1, - tasty-hunit >= 0.10, - tasty-quickcheck, - tagged, - QuickCheck >= 2.8.2 - - ghc-options: -threaded - - if !flag(lib) - buildable: False - - default-language: Haskell2010 - --- Tests to run with a limited stack and heap size -Test-Suite memory-usage-tests - type: exitcode-stdio-1.0 - main-is: MemoryUsageTests.hs - hs-source-dirs: tests - ghc-options: -Wall -fwarn-tabs "-with-rtsopts=-M4M -K1K" -main-is MemoryUsageTests - other-modules: - UnitTests.Distribution.Solver.Modular.DSL - UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils - UnitTests.Distribution.Solver.Modular.MemoryUsage - UnitTests.Options - build-depends: - base, - async, - Cabal, - cabal-install, - containers, - deepseq, - tagged, - tasty >= 1.0 && < 1.1, - tasty-hunit >= 0.10 - - ghc-options: -threaded - - if !flag(lib) - buildable: False - - default-language: Haskell2010 - --- Slow solver tests -Test-Suite solver-quickcheck - type: exitcode-stdio-1.0 - main-is: SolverQuickCheck.hs - hs-source-dirs: tests - ghc-options: -Wall -fwarn-tabs -main-is SolverQuickCheck - other-modules: - UnitTests.Distribution.Solver.Modular.DSL - UnitTests.Distribution.Solver.Modular.QuickCheck - UnitTests.Distribution.Solver.Modular.QuickCheck.Utils - build-depends: - base, - async, - Cabal, - cabal-install, - containers, - deepseq >= 1.2, - hashable, - random, - tagged, - tasty >= 1.0 && <1.1, - tasty-quickcheck, - QuickCheck >= 2.8.2, - pretty-show >= 1.6.15 - - ghc-options: -threaded - - if !flag(lib) - buildable: False - - default-language: Haskell2010 - --- Integration tests that use the cabal-install code directly --- but still build whole projects -test-suite integration-tests2 - type: exitcode-stdio-1.0 - main-is: IntegrationTests2.hs - hs-source-dirs: tests - ghc-options: -Wall -fwarn-tabs -main-is IntegrationTests2 - other-modules: - build-depends: - base, - Cabal, - cabal-install, - containers, - deepseq, - directory, - edit-distance, - filepath, - tasty >= 1.0 && < 1.1, - tasty-hunit >= 0.10, - tagged - - if !flag(lib) - buildable: False - - ghc-options: -threaded - default-language: Haskell2010 - -custom-setup - setup-depends: Cabal >= 2.2, - base, - process >= 1.1.0.1 && < 1.7, - filepath >= 1.3 && < 1.5 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,7 +1,58 @@ -*-change-log-*- +2.4.0.0 Mikhail Glushenkov September 2018 + * Bugfix: "cabal new-build --ghc-option '--bogus' --ghc-option '-O1'" + no longer ignores all arguments except the last one (#5512). + * Add the following option aliases for '-dir'-suffixed options: + 'storedir', 'logsdir', 'packagedir', 'sourcedir', 'outputdir' (#5484). + * 'new-run' now allows the user to run scripts that use a special block + to define their requirements (as in the executable stanza) in place + of a target. This also allows the use of 'cabal' as an interpreter + in a shebang line. + * Add aliases for the "new-" commands that won't change when they + lose their prefix or are eventually replaced by a third UI + paradigm in the future. (#5429) + * 'outdated' now accepts '--project-file FILE', which will look for bounds + from the new-style freeze file named FILE.freeze. This is only + available when `--new-freeze-file` has been passed. + * 'new-repl' now accepts a '--build-depends' flag which accepts the + same syntax as is used in .cabal files to add additional dependencies + to the environment when developing in the REPL. It is now usable outside + of projects. (#5425, #5454) + * 'new-build' now treats Haddock errors non-fatally. In addition, + it attempts to avoid trying to generate Haddocks when there is + nothing to generate them from. (#5232, #5459) + * 'new-run', 'new-test', and 'new-bench' now will attempt to resolve + ambiguous selectors by filtering out selectors that would be invalid. + (#4679, #5461) + * 'new-install' now supports installing libraries and local + components. (#5399) + * Drop support for GHC 7.4, since it is out of our support window + (and has been for over a year!). + * 'new-update' now works outside of projects. (#5096) + * Extend `plan.json` with `pkg-src` provenance information. (#5487) + * Add 'new-sdist' command (#5389). Creates stable archives based on + cabal projects in '.zip' and '.tar.gz' formats. + * Add '--repl-options' flag to 'cabal repl' and 'cabal new-repl' + commands. Passes its arguments to the invoked repl, bypassing the + new-build's cached configurations. This assures they don't trigger + useless rebuilds and are always applied within the repl. (#4247, #5287) + * Add 'v1-' prefixes for the commands that will be replaced in the + new-build universe, in preparation for it becoming the default. + (#5358) + * 'outdated' accepts '--v1-freeze-file' and '--v2-freeze-file' + in the same spirit. + * Completed the 'new-clean' command (#5357). The functionality is + equivalent to old-style clean, but for nix-style builds. + * Ensure that each package selected for a build-depends dependency + contains a library (#5304). + * Support packages from local tarballs in the cabal.project file. + * Default changelog generated by 'cabal init' is now named + 'CHANGELOG.md' (#5441). + * Align output of 'new-build' command phases (#4040). + 2.2.0.0 Mikhail Glushenkov March 2018 - * '--with-PROG' and '--PROG-options' are applied to all packages + * '--with-PROG' and '--PROG-options' are applied to all packages and not local packages only (#5019). * Completed the 'new-update' command (#4809), which respects nix-style cabal.project(.local) files and allows to update from @@ -66,9 +117,8 @@ * Paths_ autogen modules now compile when `RebindableSyntax` or `OverloadedStrings` is used in `default-extensions`. [stack#3789](https://github.com/commercialhaskell/stack/issues/3789) - * getDataDir` and other `Paths_autogen` functions now work - correctly when compiling a custom `Setup.hs` script using - `new-build` (#5164). + * getDataDir` and other `Paths_autogen` functions now work correctly + when compiling a custom `Setup.hs` script using `new-build` (#5164). 2.0.0.1 Mikhail Glushenkov December 2017 * Support for GHC's numeric -g debug levels (#4673). diff --git a/main/Main.hs b/main/Main.hs --- a/main/Main.hs +++ b/main/Main.hs @@ -47,16 +47,21 @@ , UserConfigFlags(..), userConfigCommand , reportCommand , manpageCommand + , haddockCommand + , cleanCommand + , doctestCommand + , copyCommand + , registerCommand ) import Distribution.Simple.Setup ( HaddockTarget(..) - , DoctestFlags(..), doctestCommand - , HaddockFlags(..), haddockCommand, defaultHaddockFlags + , DoctestFlags(..) + , HaddockFlags(..), defaultHaddockFlags , HscolourFlags(..), hscolourCommand , ReplFlags(..) - , CopyFlags(..), copyCommand - , RegisterFlags(..), registerCommand - , CleanFlags(..), cleanCommand + , CopyFlags(..) + , RegisterFlags(..) + , CleanFlags(..) , TestFlags(..), BenchmarkFlags(..) , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag , configAbsolutePaths @@ -87,6 +92,9 @@ import qualified Distribution.Client.CmdTest as CmdTest import qualified Distribution.Client.CmdBench as CmdBench import qualified Distribution.Client.CmdExec as CmdExec +import qualified Distribution.Client.CmdClean as CmdClean +import qualified Distribution.Client.CmdSdist as CmdSdist +import Distribution.Client.CmdLegacy import Distribution.Client.Install (install) import Distribution.Client.Configure (configure, writeConfigFlags) @@ -232,24 +240,32 @@ getArgs >>= mainWorker mainWorker :: [String] -> IO () -mainWorker args = topHandler $ - case commandsRun (globalCommand commands) commands args of - CommandHelp help -> printGlobalHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (globalFlags, commandParse) -> - case commandParse of - _ | fromFlagOrDefault False (globalVersion globalFlags) - -> printVersion - | fromFlagOrDefault False (globalNumericVersion globalFlags) - -> printNumericVersion - CommandHelp help -> printCommandHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> do - globalFlags' <- updateSandboxConfigFileFlag globalFlags - action globalFlags' +mainWorker args = do + validScript <- + if null args + then return False + else doesFileExist (last args) + topHandler $ + case commandsRun (globalCommand commands) commands args of + CommandHelp help -> printGlobalHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (globalFlags, commandParse) -> + case commandParse of + _ | fromFlagOrDefault False (globalVersion globalFlags) + -> printVersion + | fromFlagOrDefault False (globalNumericVersion globalFlags) + -> printNumericVersion + CommandHelp help -> printCommandHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs + | validScript -> CmdRun.handleShebang (last args) + | otherwise -> printErrors errs + CommandReadyToGo action -> do + globalFlags' <- updateSandboxConfigFileFlag globalFlags + action globalFlags' + where printCommandHelp help = do pname <- getProgName @@ -275,37 +291,19 @@ commands = map commandFromSpec commandSpecs commandSpecs = - [ regularCmd installCommand installAction - , regularCmd updateCommand updateAction - , regularCmd listCommand listAction + [ regularCmd listCommand listAction , regularCmd infoCommand infoAction , regularCmd fetchCommand fetchAction - , regularCmd freezeCommand freezeAction , regularCmd getCommand getAction , hiddenCmd unpackCommand unpackAction , regularCmd checkCommand checkAction - , regularCmd sdistCommand sdistAction , regularCmd uploadCommand uploadAction , regularCmd reportCommand reportAction - , regularCmd runCommand runAction , regularCmd initCommand initAction - , regularCmd configureExCommand configureAction - , regularCmd reconfigureCommand reconfigureAction - , regularCmd buildCommand buildAction - , regularCmd replCommand replAction - , regularCmd sandboxCommand sandboxAction - , regularCmd doctestCommand doctestAction - , regularCmd haddockCommand haddockAction - , regularCmd execCommand execAction , regularCmd userConfigCommand userConfigAction - , regularCmd cleanCommand cleanAction , regularCmd genBoundsCommand genBoundsAction , regularCmd outdatedCommand outdatedAction - , wrapperCmd copyCommand copyVerbosity copyDistPref , wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref - , wrapperCmd registerCommand regVerbosity regDistPref - , regularCmd testCommand testAction - , regularCmd benchmarkCommand benchmarkAction , hiddenCmd uninstallCommand uninstallAction , hiddenCmd formatCommand formatAction , hiddenCmd upgradeCommand upgradeAction @@ -313,21 +311,45 @@ , hiddenCmd actAsSetupCommand actAsSetupAction , hiddenCmd manpageCommand (manpageAction commandSpecs) - , regularCmd CmdConfigure.configureCommand CmdConfigure.configureAction - , regularCmd CmdUpdate.updateCommand CmdUpdate.updateAction - , regularCmd CmdBuild.buildCommand CmdBuild.buildAction - , regularCmd CmdRepl.replCommand CmdRepl.replAction - , regularCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction - , regularCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction - , regularCmd CmdInstall.installCommand CmdInstall.installAction - , regularCmd CmdRun.runCommand CmdRun.runAction - , regularCmd CmdTest.testCommand CmdTest.testAction - , regularCmd CmdBench.benchCommand CmdBench.benchAction - , regularCmd CmdExec.execCommand CmdExec.execAction + ] ++ concat + [ newCmd CmdConfigure.configureCommand CmdConfigure.configureAction + , newCmd CmdUpdate.updateCommand CmdUpdate.updateAction + , newCmd CmdBuild.buildCommand CmdBuild.buildAction + , newCmd CmdRepl.replCommand CmdRepl.replAction + , newCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction + , newCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction + , newCmd CmdInstall.installCommand CmdInstall.installAction + , newCmd CmdRun.runCommand CmdRun.runAction + , newCmd CmdTest.testCommand CmdTest.testAction + , newCmd CmdBench.benchCommand CmdBench.benchAction + , newCmd CmdExec.execCommand CmdExec.execAction + , newCmd CmdClean.cleanCommand CmdClean.cleanAction + , newCmd CmdSdist.sdistCommand CmdSdist.sdistAction + + , legacyCmd configureExCommand configureAction + , legacyCmd updateCommand updateAction + , legacyCmd buildCommand buildAction + , legacyCmd replCommand replAction + , legacyCmd freezeCommand freezeAction + , legacyCmd haddockCommand haddockAction + , legacyCmd installCommand installAction + , legacyCmd runCommand runAction + , legacyCmd testCommand testAction + , legacyCmd benchmarkCommand benchmarkAction + , legacyCmd execCommand execAction + , legacyCmd cleanCommand cleanAction + , legacyCmd sdistCommand sdistAction + , legacyCmd doctestCommand doctestAction + , legacyWrapperCmd copyCommand copyVerbosity copyDistPref + , legacyWrapperCmd registerCommand regVerbosity regDistPref + , legacyCmd reconfigureCommand reconfigureAction + , legacyCmd sandboxCommand sandboxAction ] type Action = GlobalFlags -> IO () +-- Duplicated in Distribution.Client.CmdLegacy. Any changes must be +-- reflected there, as well. regularCmd :: CommandUI flags -> (flags -> [String] -> action) -> CommandSpec action regularCmd ui action = @@ -358,7 +380,7 @@ distPref <- findSavedDistPref config (distPrefFlag flags) let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } setupWrapper verbosity setupScriptOptions Nothing - command (const flags) extraArgs + command (const flags) (const extraArgs) configureAction :: (ConfigFlags, ConfigExFlags) -> [String] -> Action @@ -455,7 +477,7 @@ build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO () build verbosity config distPref buildFlags extraArgs = setupWrapper verbosity setupOptions Nothing - (Cabal.buildCommand progDb) mkBuildFlags extraArgs + (Cabal.buildCommand progDb) mkBuildFlags (const extraArgs) where progDb = defaultProgramDb setupOptions = defaultSetupScriptOptions { useDistPref = distPref } @@ -521,7 +543,7 @@ nixShell verbosity distPref globalFlags config $ do maybeWithSandboxDirOnSearchPath useSandbox $ setupWrapper verbosity setupOptions Nothing - (Cabal.replCommand progDb) (const replFlags') extraArgs + (Cabal.replCommand progDb) (const replFlags') (const extraArgs) -- No .cabal file in the current directory: just start the REPL (possibly -- using the sandbox package DB). @@ -549,7 +571,7 @@ nixShellIfSandboxed verb dist globalFlags config useSandbox $ setupWrapper verb setupOpts Nothing - installCommand (const mempty) [] + installCommand (const mempty) (const []) installAction (configFlags, configExFlags, installFlags, haddockFlags) @@ -679,7 +701,7 @@ maybeWithSandboxDirOnSearchPath useSandbox $ setupWrapper verbosity setupOptions Nothing - Cabal.testCommand (const testFlags') extraArgs' + Cabal.testCommand (const testFlags') (const extraArgs') data ComponentNames = ComponentNamesUnknown | ComponentNames [LBI.ComponentName] @@ -762,7 +784,7 @@ maybeWithSandboxDirOnSearchPath useSandbox $ setupWrapper verbosity setupOptions Nothing - Cabal.benchmarkCommand (const benchmarkFlags') extraArgs' + Cabal.benchmarkCommand (const benchmarkFlags') (const extraArgs') haddockAction :: HaddockFlags -> [String] -> Action haddockAction haddockFlags extraArgs globalFlags = do @@ -780,7 +802,7 @@ setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref } setupWrapper verbosity setupScriptOptions Nothing - haddockCommand (const haddockFlags') extraArgs + haddockCommand (const haddockFlags') (const extraArgs) when (haddockForHackage haddockFlags == Flag ForHackage) $ do pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref) let dest = distPref name <.> "tar.gz" @@ -794,7 +816,7 @@ let verbosity = fromFlag (doctestVerbosity doctestFlags) setupWrapper verbosity defaultSetupScriptOptions Nothing - doctestCommand (const doctestFlags) extraArgs + doctestCommand (const doctestFlags) (const extraArgs) cleanAction :: CleanFlags -> [String] -> Action cleanAction cleanFlags extraArgs globalFlags = do @@ -807,7 +829,7 @@ } cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref } setupWrapper verbosity setupScriptOptions Nothing - cleanCommand (const cleanFlags') extraArgs + cleanCommand (const cleanFlags') (const extraArgs) where verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags) diff --git a/tests/IntegrationTests2.hs b/tests/IntegrationTests2.hs deleted file mode 100644 --- a/tests/IntegrationTests2.hs +++ /dev/null @@ -1,1699 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE OverloadedStrings #-} - --- For the handy instance IsString PackageIdentifier -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module IntegrationTests2 where - -import Distribution.Client.DistDirLayout -import Distribution.Client.ProjectConfig -import Distribution.Client.Config (defaultCabalDir) -import Distribution.Client.TargetSelector hiding (DirActions(..)) -import qualified Distribution.Client.TargetSelector as TS (DirActions(..)) -import Distribution.Client.ProjectPlanning -import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.ProjectBuilding -import Distribution.Client.ProjectOrchestration - ( resolveTargets, TargetProblemCommon(..), distinctTargetComponents ) -import Distribution.Client.Types - ( PackageLocation(..), UnresolvedSourcePackage - , PackageSpecifier(..) ) -import Distribution.Client.Targets - ( UserConstraint(..), UserConstraintScope(UserAnyQualifier) ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Solver.Types.SourcePackage as SP -import Distribution.Solver.Types.ConstraintSource - ( ConstraintSource(ConstraintSourceUnknown) ) -import Distribution.Solver.Types.PackageConstraint - ( PackageProperty(PackagePropertySource) ) - -import qualified Distribution.Client.CmdBuild as CmdBuild -import qualified Distribution.Client.CmdRepl as CmdRepl -import qualified Distribution.Client.CmdRun as CmdRun -import qualified Distribution.Client.CmdTest as CmdTest -import qualified Distribution.Client.CmdBench as CmdBench -import qualified Distribution.Client.CmdHaddock as CmdHaddock - -import Distribution.Package -import Distribution.PackageDescription -import qualified Distribution.Types.GenericPackageDescription as GPG -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import Distribution.Simple.Setup (toFlag, HaddockFlags(..), defaultHaddockFlags) -import Distribution.Simple.Compiler -import Distribution.System -import Distribution.Version -import Distribution.ModuleName (ModuleName) -import Distribution.Verbosity -import Distribution.Text - -import Data.Monoid -import Data.List (sort) -import Data.String (IsString(..)) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Control.Monad -import Control.Exception hiding (assert) -import System.FilePath -import System.Directory - -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.Options -import Data.Tagged (Tagged(..)) -import Data.Proxy (Proxy(..)) -import Data.Typeable (Typeable) - - -main :: IO () -main = - defaultMainWithIngredients - (defaultIngredients ++ [includingOptions projectConfigOptionDescriptions]) - (withProjectConfig $ \config -> - testGroup "Integration tests (internal)" - (tests config)) - - -tests :: ProjectConfig -> [TestTree] -tests config = - --TODO: tests for: - -- * normal success - -- * dry-run tests with changes - [ testGroup "Discovery and planning" $ - [ testCase "find root" testFindProjectRoot - , testCase "find root fail" testExceptionFindProjectRoot - , testCase "no package" (testExceptionInFindingPackage config) - , testCase "no package2" (testExceptionInFindingPackage2 config) - , testCase "proj conf1" (testExceptionInProjectConfig config) - ] - , testGroup "Target selectors" $ - [ testCaseSteps "valid" testTargetSelectors - , testCase "bad syntax" testTargetSelectorBadSyntax - , testCaseSteps "ambiguous syntax" testTargetSelectorAmbiguous - , testCase "no current pkg" testTargetSelectorNoCurrentPackage - , testCase "no targets" testTargetSelectorNoTargets - , testCase "project empty" testTargetSelectorProjectEmpty - , testCase "problems (common)" (testTargetProblemsCommon config) - , testCaseSteps "problems (build)" (testTargetProblemsBuild config) - , testCaseSteps "problems (repl)" (testTargetProblemsRepl config) - , testCaseSteps "problems (run)" (testTargetProblemsRun config) - , testCaseSteps "problems (test)" (testTargetProblemsTest config) - , testCaseSteps "problems (bench)" (testTargetProblemsBench config) - , testCaseSteps "problems (haddock)" (testTargetProblemsHaddock config) - ] - , testGroup "Exceptions during building (local inplace)" $ - [ testCase "configure" (testExceptionInConfigureStep config) - , testCase "build" (testExceptionInBuildStep config) --- , testCase "register" testExceptionInRegisterStep - ] - --TODO: need to repeat for packages for the store - --TODO: need to check we can build sub-libs, foreign libs and exes - -- components for non-local packages / packages in the store. - - , testGroup "Successful builds" $ - [ testCaseSteps "Setup script styles" (testSetupScriptStyles config) - , testCase "keep-going" (testBuildKeepGoing config) - ] - - , testGroup "Regression tests" $ - [ testCase "issue #3324" (testRegressionIssue3324 config) - ] - ] - - -testFindProjectRoot :: Assertion -testFindProjectRoot = do - Left (BadProjectRootExplicitFile file) <- findProjectRoot (Just testdir) - (Just testfile) - file @?= testfile - where - testdir = basedir "exception" "no-pkg2" - testfile = "bklNI8O1OpOUuDu3F4Ij4nv3oAqN" - - -testExceptionFindProjectRoot :: Assertion -testExceptionFindProjectRoot = do - Right (ProjectRootExplicit dir _) <- findProjectRoot (Just testdir) Nothing - cwd <- getCurrentDirectory - dir @?= cwd testdir - where - testdir = basedir "exception" "no-pkg2" - - -testTargetSelectors :: (String -> IO ()) -> Assertion -testTargetSelectors reportSubCase = do - (_, _, _, localPackages, _) <- configureProject testdir config - let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir) - localPackages - - reportSubCase "cwd" - do Right ts <- readTargetSelectors' [] - ts @?= [TargetPackage TargetImplicitCwd ["p-0.1"] Nothing] - - reportSubCase "all" - do Right ts <- readTargetSelectors' - ["all", ":all"] - ts @?= replicate 2 (TargetAllPackages Nothing) - - reportSubCase "filter" - do Right ts <- readTargetSelectors' - [ "libs", ":cwd:libs" - , "flibs", ":cwd:flibs" - , "exes", ":cwd:exes" - , "tests", ":cwd:tests" - , "benchmarks", ":cwd:benchmarks"] - zipWithM_ (@?=) ts - [ TargetPackage TargetImplicitCwd ["p-0.1"] (Just kind) - | kind <- concatMap (replicate 2) [LibKind .. ] - ] - - reportSubCase "all:filter" - do Right ts <- readTargetSelectors' - [ "all:libs", ":all:libs" - , "all:flibs", ":all:flibs" - , "all:exes", ":all:exes" - , "all:tests", ":all:tests" - , "all:benchmarks", ":all:benchmarks"] - zipWithM_ (@?=) ts - [ TargetAllPackages (Just kind) - | kind <- concatMap (replicate 2) [LibKind .. ] - ] - - reportSubCase "pkg" - do Right ts <- readTargetSelectors' - [ ":pkg:p", ".", "./", "p.cabal" - , "q", ":pkg:q", "q/", "./q/", "q/q.cabal"] - ts @?= replicate 4 (mkTargetPackage "p-0.1") - ++ replicate 5 (mkTargetPackage "q-0.1") - - reportSubCase "pkg:filter" - do Right ts <- readTargetSelectors' - [ "p:libs", ".:libs", ":pkg:p:libs" - , "p:flibs", ".:flibs", ":pkg:p:flibs" - , "p:exes", ".:exes", ":pkg:p:exes" - , "p:tests", ".:tests", ":pkg:p:tests" - , "p:benchmarks", ".:benchmarks", ":pkg:p:benchmarks" - , "q:libs", "q/:libs", ":pkg:q:libs" - , "q:flibs", "q/:flibs", ":pkg:q:flibs" - , "q:exes", "q/:exes", ":pkg:q:exes" - , "q:tests", "q/:tests", ":pkg:q:tests" - , "q:benchmarks", "q/:benchmarks", ":pkg:q:benchmarks"] - zipWithM_ (@?=) ts $ - [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just kind) - | kind <- concatMap (replicate 3) [LibKind .. ] - ] ++ - [ TargetPackage TargetExplicitNamed ["q-0.1"] (Just kind) - | kind <- concatMap (replicate 3) [LibKind .. ] - ] - - reportSubCase "component" - do Right ts <- readTargetSelectors' - [ "p", "lib:p", "p:lib:p", ":pkg:p:lib:p" - , "lib:q", "q:lib:q", ":pkg:q:lib:q" ] - ts @?= replicate 4 (TargetComponent "p-0.1" CLibName WholeComponent) - ++ replicate 3 (TargetComponent "q-0.1" CLibName WholeComponent) - - reportSubCase "module" - do Right ts <- readTargetSelectors' - [ "P", "lib:p:P", "p:p:P", ":pkg:p:lib:p:module:P" - , "QQ", "lib:q:QQ", "q:q:QQ", ":pkg:q:lib:q:module:QQ" - , "pexe:PMain" -- p:P or q:QQ would be ambiguous here - , "qexe:QMain" -- package p vs component p - ] - ts @?= replicate 4 (TargetComponent "p-0.1" CLibName (ModuleTarget "P")) - ++ replicate 4 (TargetComponent "q-0.1" CLibName (ModuleTarget "QQ")) - ++ [ TargetComponent "p-0.1" (CExeName "pexe") (ModuleTarget "PMain") - , TargetComponent "q-0.1" (CExeName "qexe") (ModuleTarget "QMain") - ] - - reportSubCase "file" - do Right ts <- readTargetSelectors' - [ "./P.hs", "p:P.lhs", "lib:p:P.hsc", "p:p:P.hsc", - ":pkg:p:lib:p:file:P.y" - , "q/QQ.hs", "q:QQ.lhs", "lib:q:QQ.hsc", "q:q:QQ.hsc", - ":pkg:q:lib:q:file:QQ.y" - ] - ts @?= replicate 5 (TargetComponent "p-0.1" CLibName (FileTarget "P")) - ++ replicate 5 (TargetComponent "q-0.1" CLibName (FileTarget "QQ")) - -- Note there's a bit of an inconsistency here: for the single-part - -- syntax the target has to point to a file that exists, whereas for - -- all the other forms we don't require that. - - cleanProject testdir - where - testdir = "targets/simple" - config = mempty - - -testTargetSelectorBadSyntax :: Assertion -testTargetSelectorBadSyntax = do - (_, _, _, localPackages, _) <- configureProject testdir config - let targets = [ "foo bar", " foo" - , "foo:", "foo::bar" - , "foo: ", "foo: :bar" - , "a:b:c:d:e:f", "a:b:c:d:e:f:g:h" ] - Left errs <- readTargetSelectors localPackages targets - zipWithM_ (@?=) errs (map TargetSelectorUnrecognised targets) - cleanProject testdir - where - testdir = "targets/empty" - config = mempty - - -testTargetSelectorAmbiguous :: (String -> IO ()) -> Assertion -testTargetSelectorAmbiguous reportSubCase = do - - -- 'all' is ambiguous with packages and cwd components - reportSubCase "ambiguous: all vs pkg" - assertAmbiguous "all" - [mkTargetPackage "all", mkTargetAllPackages] - [mkpkg "all" []] - - reportSubCase "ambiguous: all vs cwd component" - assertAmbiguous "all" - [mkTargetComponent "other" (CExeName "all"), mkTargetAllPackages] - [mkpkg "other" [mkexe "all"]] - - -- but 'all' is not ambiguous with non-cwd components, modules or files - reportSubCase "unambiguous: all vs non-cwd comp, mod, file" - assertUnambiguous "All" - mkTargetAllPackages - [ mkpkgAt "foo" [mkexe "All"] "foo" - , mkpkg "bar" [ mkexe "bar" `withModules` ["All"] - , mkexe "baz" `withCFiles` ["All"] ] - ] - - -- filters 'libs', 'exes' etc are ambiguous with packages and - -- local components - reportSubCase "ambiguous: cwd-pkg filter vs pkg" - assertAmbiguous "libs" - [ mkTargetPackage "libs" - , TargetPackage TargetImplicitCwd ["libs"] (Just LibKind) ] - [mkpkg "libs" []] - - reportSubCase "ambiguous: filter vs cwd component" - assertAmbiguous "exes" - [ mkTargetComponent "other" (CExeName "exes") - , TargetPackage TargetImplicitCwd ["other"] (Just ExeKind) ] - [mkpkg "other" [mkexe "exes"]] - - -- but filters are not ambiguous with non-cwd components, modules or files - reportSubCase "unambiguous: filter vs non-cwd comp, mod, file" - assertUnambiguous "Libs" - (TargetPackage TargetImplicitCwd ["bar"] (Just LibKind)) - [ mkpkgAt "foo" [mkexe "Libs"] "foo" - , mkpkg "bar" [ mkexe "bar" `withModules` ["Libs"] - , mkexe "baz" `withCFiles` ["Libs"] ] - ] - - -- local components shadow packages and other components - reportSubCase "unambiguous: cwd comp vs pkg, non-cwd comp" - assertUnambiguous "foo" - (mkTargetComponent "other" (CExeName "foo")) - [ mkpkg "other" [mkexe "foo"] - , mkpkgAt "other2" [mkexe "foo"] "other2" -- shadows non-local foo - , mkpkg "foo" [] ] -- shadows package foo - - -- local components shadow modules and files - reportSubCase "unambiguous: cwd comp vs module, file" - assertUnambiguous "Foo" - (mkTargetComponent "bar" (CExeName "Foo")) - [ mkpkg "bar" [mkexe "Foo"] - , mkpkg "other" [ mkexe "other" `withModules` ["Foo"] - , mkexe "other2" `withCFiles` ["Foo"] ] - ] - - -- packages shadow non-local components - reportSubCase "unambiguous: pkg vs non-cwd comp" - assertUnambiguous "foo" - (mkTargetPackage "foo") - [ mkpkg "foo" [] - , mkpkgAt "other" [mkexe "foo"] "other" -- shadows non-local foo - ] - - -- packages shadow modules and files - reportSubCase "unambiguous: pkg vs module, file" - assertUnambiguous "Foo" - (mkTargetPackage "Foo") - [ mkpkgAt "Foo" [] "foo" - , mkpkg "other" [ mkexe "other" `withModules` ["Foo"] - , mkexe "other2" `withCFiles` ["Foo"] ] - ] - - -- non-exact case packages and components are ambiguous - reportSubCase "ambiguous: non-exact-case pkg names" - assertAmbiguous "Foo" - [ mkTargetPackage "foo", mkTargetPackage "FOO" ] - [ mkpkg "foo" [], mkpkg "FOO" [] ] - reportSubCase "ambiguous: non-exact-case comp names" - assertAmbiguous "Foo" - [ mkTargetComponent "bar" (CExeName "foo") - , mkTargetComponent "bar" (CExeName "FOO") ] - [ mkpkg "bar" [mkexe "foo", mkexe "FOO"] ] - - -- exact-case Module or File over non-exact case package or component - reportSubCase "unambiguous: module vs non-exact-case pkg, comp" - assertUnambiguous "Baz" - (mkTargetModule "other" (CExeName "other") "Baz") - [ mkpkg "baz" [mkexe "BAZ"] - , mkpkg "other" [ mkexe "other" `withModules` ["Baz"] ] - ] - reportSubCase "unambiguous: file vs non-exact-case pkg, comp" - assertUnambiguous "Baz" - (mkTargetFile "other" (CExeName "other") "Baz") - [ mkpkg "baz" [mkexe "BAZ"] - , mkpkg "other" [ mkexe "other" `withCFiles` ["Baz"] ] - ] - where - assertAmbiguous :: String - -> [TargetSelector] - -> [SourcePackage (PackageLocation a)] - -> Assertion - assertAmbiguous str tss pkgs = do - res <- readTargetSelectorsWith - fakeDirActions - (map SpecificSourcePackage pkgs) - [str] - case res of - Left [TargetSelectorAmbiguous _ tss'] -> - sort (map snd tss') @?= sort tss - _ -> assertFailure $ "expected Left [TargetSelectorAmbiguous _ _], " - ++ "got " ++ show res - - assertUnambiguous :: String - -> TargetSelector - -> [SourcePackage (PackageLocation a)] - -> Assertion - assertUnambiguous str ts pkgs = do - res <- readTargetSelectorsWith - fakeDirActions - (map SpecificSourcePackage pkgs) - [str] - case res of - Right [ts'] -> ts' @?= ts - _ -> assertFailure $ "expected Right [Target...], " - ++ "got " ++ show res - - fakeDirActions = TS.DirActions { - TS.doesFileExist = \_p -> return True, - TS.doesDirectoryExist = \_p -> return True, - TS.canonicalizePath = \p -> return ("/" p), -- FilePath.Unix. ? - TS.getCurrentDirectory = return "/" - } - - mkpkg :: String -> [Executable] -> SourcePackage (PackageLocation a) - mkpkg pkgidstr exes = mkpkgAt pkgidstr exes "" - - mkpkgAt :: String -> [Executable] -> FilePath - -> SourcePackage (PackageLocation a) - mkpkgAt pkgidstr exes loc = - SourcePackage { - packageInfoId = pkgid, - packageSource = LocalUnpackedPackage loc, - packageDescrOverride = Nothing, - SP.packageDescription = GenericPackageDescription { - GPG.packageDescription = emptyPackageDescription { package = pkgid }, - genPackageFlags = [], - condLibrary = Nothing, - condSubLibraries = [], - condForeignLibs = [], - condExecutables = [ ( exeName exe, CondNode exe [] [] ) - | exe <- exes ], - condTestSuites = [], - condBenchmarks = [] - } - } - where - Just pkgid = simpleParse pkgidstr - - mkexe :: String -> Executable - mkexe name = mempty { exeName = fromString name } - - withModules :: Executable -> [String] -> Executable - withModules exe mods = - exe { buildInfo = (buildInfo exe) { otherModules = map fromString mods } } - - withCFiles :: Executable -> [FilePath] -> Executable - withCFiles exe files = - exe { buildInfo = (buildInfo exe) { cSources = files } } - - -mkTargetPackage :: PackageId -> TargetSelector -mkTargetPackage pkgid = - TargetPackage TargetExplicitNamed [pkgid] Nothing - -mkTargetComponent :: PackageId -> ComponentName -> TargetSelector -mkTargetComponent pkgid cname = - TargetComponent pkgid cname WholeComponent - -mkTargetModule :: PackageId -> ComponentName -> ModuleName -> TargetSelector -mkTargetModule pkgid cname mname = - TargetComponent pkgid cname (ModuleTarget mname) - -mkTargetFile :: PackageId -> ComponentName -> String -> TargetSelector -mkTargetFile pkgid cname fname = - TargetComponent pkgid cname (FileTarget fname) - -mkTargetAllPackages :: TargetSelector -mkTargetAllPackages = TargetAllPackages Nothing - -instance IsString PackageIdentifier where - fromString pkgidstr = pkgid - where Just pkgid = simpleParse pkgidstr - - -testTargetSelectorNoCurrentPackage :: Assertion -testTargetSelectorNoCurrentPackage = do - (_, _, _, localPackages, _) <- configureProject testdir config - let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir) - localPackages - targets = [ "libs", ":cwd:libs" - , "flibs", ":cwd:flibs" - , "exes", ":cwd:exes" - , "tests", ":cwd:tests" - , "benchmarks", ":cwd:benchmarks"] - Left errs <- readTargetSelectors' targets - zipWithM_ (@?=) errs - [ TargetSelectorNoCurrentPackage ts - | target <- targets - , let Just ts = parseTargetString target - ] - cleanProject testdir - where - testdir = "targets/complex" - config = mempty - - -testTargetSelectorNoTargets :: Assertion -testTargetSelectorNoTargets = do - (_, _, _, localPackages, _) <- configureProject testdir config - Left errs <- readTargetSelectors localPackages [] - errs @?= [TargetSelectorNoTargetsInCwd] - cleanProject testdir - where - testdir = "targets/complex" - config = mempty - - -testTargetSelectorProjectEmpty :: Assertion -testTargetSelectorProjectEmpty = do - (_, _, _, localPackages, _) <- configureProject testdir config - Left errs <- readTargetSelectors localPackages [] - errs @?= [TargetSelectorNoTargetsInProject] - cleanProject testdir - where - testdir = "targets/empty" - config = mempty - - -testTargetProblemsCommon :: ProjectConfig -> Assertion -testTargetProblemsCommon config0 = do - (_,elaboratedPlan,_) <- planProject testdir config - - let pkgIdMap :: Map.Map PackageName PackageId - pkgIdMap = Map.fromList - [ (packageName p, packageId p) - | p <- InstallPlan.toList elaboratedPlan ] - - cases :: [( TargetSelector -> CmdBuild.TargetProblem - , TargetSelector - )] - cases = - [ -- Cannot resolve packages outside of the project - ( \_ -> CmdBuild.TargetProblemCommon $ - TargetProblemNoSuchPackage "foobar" - , mkTargetPackage "foobar" ) - - -- We cannot currently build components like testsuites or - -- benchmarks from packages that are not local to the project - , ( \_ -> CmdBuild.TargetProblemCommon $ - TargetComponentNotProjectLocal - (pkgIdMap Map.! "filepath") (CTestName "filepath-tests") - WholeComponent - , mkTargetComponent (pkgIdMap Map.! "filepath") - (CTestName "filepath-tests") ) - - -- Components can be explicitly @buildable: False@ - , ( \_ -> CmdBuild.TargetProblemCommon $ - TargetComponentNotBuildable "q-0.1" (CExeName "buildable-false") WholeComponent - , mkTargetComponent "q-0.1" (CExeName "buildable-false") ) - - -- Testsuites and benchmarks can be disabled by the solver if it - -- cannot satisfy deps - , ( \_ -> CmdBuild.TargetProblemCommon $ - TargetOptionalStanzaDisabledBySolver "q-0.1" (CTestName "solver-disabled") WholeComponent - , mkTargetComponent "q-0.1" (CTestName "solver-disabled") ) - - -- Testsuites and benchmarks can be disabled explicitly by the - -- user via config - , ( \_ -> CmdBuild.TargetProblemCommon $ - TargetOptionalStanzaDisabledByUser - "q-0.1" (CBenchName "user-disabled") WholeComponent - , mkTargetComponent "q-0.1" (CBenchName "user-disabled") ) - - -- An unknown package. The target selector resolution should only - -- produce known packages, so this should not happen with the - -- output from 'readTargetSelectors'. - , ( \_ -> CmdBuild.TargetProblemCommon $ - TargetProblemNoSuchPackage "foobar" - , mkTargetPackage "foobar" ) - - -- An unknown component of a known package. The target selector - -- resolution should only produce known packages, so this should - -- not happen with the output from 'readTargetSelectors'. - , ( \_ -> CmdBuild.TargetProblemCommon $ - TargetProblemNoSuchComponent "q-0.1" (CExeName "no-such") - , mkTargetComponent "q-0.1" (CExeName "no-such") ) - ] - assertTargetProblems - elaboratedPlan - CmdBuild.selectPackageTargets - CmdBuild.selectComponentTarget - CmdBuild.TargetProblemCommon - cases - where - testdir = "targets/complex" - config = config0 { - projectConfigLocalPackages = (projectConfigLocalPackages config0) { - packageConfigBenchmarks = toFlag False - } - , projectConfigShared = (projectConfigShared config0) { - projectConfigConstraints = - [( UserConstraint (UserAnyQualifier "filepath") PackagePropertySource - , ConstraintSourceUnknown )] - } - } - - -testTargetProblemsBuild :: ProjectConfig -> (String -> IO ()) -> Assertion -testTargetProblemsBuild config reportSubCase = do - - reportSubCase "empty-pkg" - assertProjectTargetProblems - "targets/empty-pkg" config - CmdBuild.selectPackageTargets - CmdBuild.selectComponentTarget - CmdBuild.TargetProblemCommon - [ ( CmdBuild.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) - ] - - reportSubCase "all-disabled" - assertProjectTargetProblems - "targets/all-disabled" - config { - projectConfigLocalPackages = (projectConfigLocalPackages config) { - packageConfigBenchmarks = toFlag False - } - } - CmdBuild.selectPackageTargets - CmdBuild.selectComponentTarget - CmdBuild.TargetProblemCommon - [ ( flip CmdBuild.TargetProblemNoneEnabled - [ AvailableTarget "p-0.1" (CBenchName "user-disabled") - TargetDisabledByUser True - , AvailableTarget "p-0.1" (CTestName "solver-disabled") - TargetDisabledBySolver True - , AvailableTarget "p-0.1" (CExeName "buildable-false") - TargetNotBuildable True - , AvailableTarget "p-0.1" CLibName - TargetNotBuildable True - ] - , mkTargetPackage "p-0.1" ) - ] - - reportSubCase "enabled component kinds" - -- When we explicitly enable all the component kinds then selecting the - -- whole package selects those component kinds too - do (_,elaboratedPlan,_) <- planProject "targets/variety" config { - projectConfigLocalPackages = (projectConfigLocalPackages config) { - packageConfigTests = toFlag True, - packageConfigBenchmarks = toFlag True - } - } - assertProjectDistinctTargets - elaboratedPlan - CmdBuild.selectPackageTargets - CmdBuild.selectComponentTarget - CmdBuild.TargetProblemCommon - [ mkTargetPackage "p-0.1" ] - [ ("p-0.1-inplace", CLibName) - , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") - , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") - , ("p-0.1-inplace-an-exe", CExeName "an-exe") - , ("p-0.1-inplace-libp", CFLibName "libp") - ] - - reportSubCase "disabled component kinds" - -- When we explicitly disable all the component kinds then selecting the - -- whole package only selects the library, foreign lib and exes - do (_,elaboratedPlan,_) <- planProject "targets/variety" config { - projectConfigLocalPackages = (projectConfigLocalPackages config) { - packageConfigTests = toFlag False, - packageConfigBenchmarks = toFlag False - } - } - assertProjectDistinctTargets - elaboratedPlan - CmdBuild.selectPackageTargets - CmdBuild.selectComponentTarget - CmdBuild.TargetProblemCommon - [ mkTargetPackage "p-0.1" ] - [ ("p-0.1-inplace", CLibName) - , ("p-0.1-inplace-an-exe", CExeName "an-exe") - , ("p-0.1-inplace-libp", CFLibName "libp") - ] - - reportSubCase "requested component kinds" - -- When we selecting the package with an explicit filter then we get those - -- components even though we did not explicitly enable tests/benchmarks - do (_,elaboratedPlan,_) <- planProject "targets/variety" config - assertProjectDistinctTargets - elaboratedPlan - CmdBuild.selectPackageTargets - CmdBuild.selectComponentTarget - CmdBuild.TargetProblemCommon - [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) - , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) - ] - [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") - , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") - ] - - -testTargetProblemsRepl :: ProjectConfig -> (String -> IO ()) -> Assertion -testTargetProblemsRepl config reportSubCase = do - - reportSubCase "multiple-libs" - assertProjectTargetProblems - "targets/multiple-libs" config - CmdRepl.selectPackageTargets - CmdRepl.selectComponentTarget - CmdRepl.TargetProblemCommon - [ ( flip CmdRepl.TargetProblemMatchesMultiple - [ AvailableTarget "p-0.1" CLibName - (TargetBuildable () TargetRequestedByDefault) True - , AvailableTarget "q-0.1" CLibName - (TargetBuildable () TargetRequestedByDefault) True - ] - , mkTargetAllPackages ) - ] - - reportSubCase "multiple-exes" - assertProjectTargetProblems - "targets/multiple-exes" config - CmdRepl.selectPackageTargets - CmdRepl.selectComponentTarget - CmdRepl.TargetProblemCommon - [ ( flip CmdRepl.TargetProblemMatchesMultiple - [ AvailableTarget "p-0.1" (CExeName "p2") - (TargetBuildable () TargetRequestedByDefault) True - , AvailableTarget "p-0.1" (CExeName "p1") - (TargetBuildable () TargetRequestedByDefault) True - ] - , mkTargetPackage "p-0.1" ) - ] - - reportSubCase "multiple-tests" - assertProjectTargetProblems - "targets/multiple-tests" config - CmdRepl.selectPackageTargets - CmdRepl.selectComponentTarget - CmdRepl.TargetProblemCommon - [ ( flip CmdRepl.TargetProblemMatchesMultiple - [ AvailableTarget "p-0.1" (CTestName "p2") - (TargetBuildable () TargetNotRequestedByDefault) True - , AvailableTarget "p-0.1" (CTestName "p1") - (TargetBuildable () TargetNotRequestedByDefault) True - ] - , TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) ) - ] - - reportSubCase "multiple targets" - do (_,elaboratedPlan,_) <- planProject "targets/multiple-exes" config - assertProjectDistinctTargets - elaboratedPlan - CmdRepl.selectPackageTargets - CmdRepl.selectComponentTarget - CmdRepl.TargetProblemCommon - [ mkTargetComponent "p-0.1" (CExeName "p1") - , mkTargetComponent "p-0.1" (CExeName "p2") - ] - [ ("p-0.1-inplace-p1", CExeName "p1") - , ("p-0.1-inplace-p2", CExeName "p2") - ] - - reportSubCase "libs-disabled" - assertProjectTargetProblems - "targets/libs-disabled" config - CmdRepl.selectPackageTargets - CmdRepl.selectComponentTarget - CmdRepl.TargetProblemCommon - [ ( flip CmdRepl.TargetProblemNoneEnabled - [ AvailableTarget "p-0.1" CLibName TargetNotBuildable True ] - , mkTargetPackage "p-0.1" ) - ] - - reportSubCase "exes-disabled" - assertProjectTargetProblems - "targets/exes-disabled" config - CmdRepl.selectPackageTargets - CmdRepl.selectComponentTarget - CmdRepl.TargetProblemCommon - [ ( flip CmdRepl.TargetProblemNoneEnabled - [ AvailableTarget "p-0.1" (CExeName "p") TargetNotBuildable True - ] - , mkTargetPackage "p-0.1" ) - ] - - reportSubCase "test-only" - assertProjectTargetProblems - "targets/test-only" config - CmdRepl.selectPackageTargets - CmdRepl.selectComponentTarget - CmdRepl.TargetProblemCommon - [ ( flip CmdRepl.TargetProblemNoneEnabled - [ AvailableTarget "p-0.1" (CTestName "pexe") - (TargetBuildable () TargetNotRequestedByDefault) True - ] - , mkTargetPackage "p-0.1" ) - ] - - reportSubCase "empty-pkg" - assertProjectTargetProblems - "targets/empty-pkg" config - CmdRepl.selectPackageTargets - CmdRepl.selectComponentTarget - CmdRepl.TargetProblemCommon - [ ( CmdRepl.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) - ] - - reportSubCase "requested component kinds" - do (_,elaboratedPlan,_) <- planProject "targets/variety" config - -- by default we only get the lib - assertProjectDistinctTargets - elaboratedPlan - CmdRepl.selectPackageTargets - CmdRepl.selectComponentTarget - CmdRepl.TargetProblemCommon - [ TargetPackage TargetExplicitNamed ["p-0.1"] Nothing ] - [ ("p-0.1-inplace", CLibName) ] - -- When we select the package with an explicit filter then we get those - -- components even though we did not explicitly enable tests/benchmarks - assertProjectDistinctTargets - elaboratedPlan - CmdRepl.selectPackageTargets - CmdRepl.selectComponentTarget - CmdRepl.TargetProblemCommon - [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) ] - [ ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") ] - assertProjectDistinctTargets - elaboratedPlan - CmdRepl.selectPackageTargets - CmdRepl.selectComponentTarget - CmdRepl.TargetProblemCommon - [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) ] - [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") ] - - -testTargetProblemsRun :: ProjectConfig -> (String -> IO ()) -> Assertion -testTargetProblemsRun config reportSubCase = do - - reportSubCase "multiple-exes" - assertProjectTargetProblems - "targets/multiple-exes" config - CmdRun.selectPackageTargets - CmdRun.selectComponentTarget - CmdRun.TargetProblemCommon - [ ( flip CmdRun.TargetProblemMatchesMultiple - [ AvailableTarget "p-0.1" (CExeName "p2") - (TargetBuildable () TargetRequestedByDefault) True - , AvailableTarget "p-0.1" (CExeName "p1") - (TargetBuildable () TargetRequestedByDefault) True - ] - , mkTargetPackage "p-0.1" ) - ] - - reportSubCase "multiple targets" - do (_,elaboratedPlan,_) <- planProject "targets/multiple-exes" config - assertProjectDistinctTargets - elaboratedPlan - CmdRun.selectPackageTargets - CmdRun.selectComponentTarget - CmdRun.TargetProblemCommon - [ mkTargetComponent "p-0.1" (CExeName "p1") - , mkTargetComponent "p-0.1" (CExeName "p2") - ] - [ ("p-0.1-inplace-p1", CExeName "p1") - , ("p-0.1-inplace-p2", CExeName "p2") - ] - - reportSubCase "exes-disabled" - assertProjectTargetProblems - "targets/exes-disabled" config - CmdRun.selectPackageTargets - CmdRun.selectComponentTarget - CmdRun.TargetProblemCommon - [ ( flip CmdRun.TargetProblemNoneEnabled - [ AvailableTarget "p-0.1" (CExeName "p") TargetNotBuildable True - ] - , mkTargetPackage "p-0.1" ) - ] - - reportSubCase "empty-pkg" - assertProjectTargetProblems - "targets/empty-pkg" config - CmdRun.selectPackageTargets - CmdRun.selectComponentTarget - CmdRun.TargetProblemCommon - [ ( CmdRun.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) - ] - - reportSubCase "lib-only" - assertProjectTargetProblems - "targets/lib-only" config - CmdRun.selectPackageTargets - CmdRun.selectComponentTarget - CmdRun.TargetProblemCommon - [ ( CmdRun.TargetProblemNoExes, mkTargetPackage "p-0.1" ) - ] - - -testTargetProblemsTest :: ProjectConfig -> (String -> IO ()) -> Assertion -testTargetProblemsTest config reportSubCase = do - - reportSubCase "disabled by config" - assertProjectTargetProblems - "targets/tests-disabled" - config { - projectConfigLocalPackages = (projectConfigLocalPackages config) { - packageConfigTests = toFlag False - } - } - CmdTest.selectPackageTargets - CmdTest.selectComponentTarget - CmdTest.TargetProblemCommon - [ ( flip CmdTest.TargetProblemNoneEnabled - [ AvailableTarget "p-0.1" (CTestName "user-disabled") - TargetDisabledByUser True - , AvailableTarget "p-0.1" (CTestName "solver-disabled") - TargetDisabledByUser True - ] - , mkTargetPackage "p-0.1" ) - ] - - reportSubCase "disabled by solver & buildable false" - assertProjectTargetProblems - "targets/tests-disabled" - config - CmdTest.selectPackageTargets - CmdTest.selectComponentTarget - CmdTest.TargetProblemCommon - [ ( flip CmdTest.TargetProblemNoneEnabled - [ AvailableTarget "p-0.1" (CTestName "user-disabled") - TargetDisabledBySolver True - , AvailableTarget "p-0.1" (CTestName "solver-disabled") - TargetDisabledBySolver True - ] - , mkTargetPackage "p-0.1" ) - - , ( flip CmdTest.TargetProblemNoneEnabled - [ AvailableTarget "q-0.1" (CTestName "buildable-false") - TargetNotBuildable True - ] - , mkTargetPackage "q-0.1" ) - ] - - reportSubCase "empty-pkg" - assertProjectTargetProblems - "targets/empty-pkg" config - CmdTest.selectPackageTargets - CmdTest.selectComponentTarget - CmdTest.TargetProblemCommon - [ ( CmdTest.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) - ] - - reportSubCase "no tests" - assertProjectTargetProblems - "targets/simple" - config - CmdTest.selectPackageTargets - CmdTest.selectComponentTarget - CmdTest.TargetProblemCommon - [ ( CmdTest.TargetProblemNoTests, mkTargetPackage "p-0.1" ) - , ( CmdTest.TargetProblemNoTests, mkTargetPackage "q-0.1" ) - ] - - reportSubCase "not a test" - assertProjectTargetProblems - "targets/variety" - config - CmdTest.selectPackageTargets - CmdTest.selectComponentTarget - CmdTest.TargetProblemCommon $ - [ ( const (CmdTest.TargetProblemComponentNotTest - "p-0.1" CLibName) - , mkTargetComponent "p-0.1" CLibName ) - - , ( const (CmdTest.TargetProblemComponentNotTest - "p-0.1" (CExeName "an-exe")) - , mkTargetComponent "p-0.1" (CExeName "an-exe") ) - - , ( const (CmdTest.TargetProblemComponentNotTest - "p-0.1" (CFLibName "libp")) - , mkTargetComponent "p-0.1" (CFLibName "libp") ) - - , ( const (CmdTest.TargetProblemComponentNotTest - "p-0.1" (CBenchName "a-benchmark")) - , mkTargetComponent "p-0.1" (CBenchName "a-benchmark") ) - ] ++ - [ ( const (CmdTest.TargetProblemIsSubComponent - "p-0.1" cname (ModuleTarget modname)) - , mkTargetModule "p-0.1" cname modname ) - | (cname, modname) <- [ (CTestName "a-testsuite", "TestModule") - , (CBenchName "a-benchmark", "BenchModule") - , (CExeName "an-exe", "ExeModule") - , (CLibName, "P") - ] - ] ++ - [ ( const (CmdTest.TargetProblemIsSubComponent - "p-0.1" cname (FileTarget fname)) - , mkTargetFile "p-0.1" cname fname) - | (cname, fname) <- [ (CTestName "a-testsuite", "Test.hs") - , (CBenchName "a-benchmark", "Bench.hs") - , (CExeName "an-exe", "Main.hs") - ] - ] - - -testTargetProblemsBench :: ProjectConfig -> (String -> IO ()) -> Assertion -testTargetProblemsBench config reportSubCase = do - - reportSubCase "disabled by config" - assertProjectTargetProblems - "targets/benchmarks-disabled" - config { - projectConfigLocalPackages = (projectConfigLocalPackages config) { - packageConfigBenchmarks = toFlag False - } - } - CmdBench.selectPackageTargets - CmdBench.selectComponentTarget - CmdBench.TargetProblemCommon - [ ( flip CmdBench.TargetProblemNoneEnabled - [ AvailableTarget "p-0.1" (CBenchName "user-disabled") - TargetDisabledByUser True - , AvailableTarget "p-0.1" (CBenchName "solver-disabled") - TargetDisabledByUser True - ] - , mkTargetPackage "p-0.1" ) - ] - - reportSubCase "disabled by solver & buildable false" - assertProjectTargetProblems - "targets/benchmarks-disabled" - config - CmdBench.selectPackageTargets - CmdBench.selectComponentTarget - CmdBench.TargetProblemCommon - [ ( flip CmdBench.TargetProblemNoneEnabled - [ AvailableTarget "p-0.1" (CBenchName "user-disabled") - TargetDisabledBySolver True - , AvailableTarget "p-0.1" (CBenchName "solver-disabled") - TargetDisabledBySolver True - ] - , mkTargetPackage "p-0.1" ) - - , ( flip CmdBench.TargetProblemNoneEnabled - [ AvailableTarget "q-0.1" (CBenchName "buildable-false") - TargetNotBuildable True - ] - , mkTargetPackage "q-0.1" ) - ] - - reportSubCase "empty-pkg" - assertProjectTargetProblems - "targets/empty-pkg" config - CmdBench.selectPackageTargets - CmdBench.selectComponentTarget - CmdBench.TargetProblemCommon - [ ( CmdBench.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) - ] - - reportSubCase "no benchmarks" - assertProjectTargetProblems - "targets/simple" - config - CmdBench.selectPackageTargets - CmdBench.selectComponentTarget - CmdBench.TargetProblemCommon - [ ( CmdBench.TargetProblemNoBenchmarks, mkTargetPackage "p-0.1" ) - , ( CmdBench.TargetProblemNoBenchmarks, mkTargetPackage "q-0.1" ) - ] - - reportSubCase "not a benchmark" - assertProjectTargetProblems - "targets/variety" - config - CmdBench.selectPackageTargets - CmdBench.selectComponentTarget - CmdBench.TargetProblemCommon $ - [ ( const (CmdBench.TargetProblemComponentNotBenchmark - "p-0.1" CLibName) - , mkTargetComponent "p-0.1" CLibName ) - - , ( const (CmdBench.TargetProblemComponentNotBenchmark - "p-0.1" (CExeName "an-exe")) - , mkTargetComponent "p-0.1" (CExeName "an-exe") ) - - , ( const (CmdBench.TargetProblemComponentNotBenchmark - "p-0.1" (CFLibName "libp")) - , mkTargetComponent "p-0.1" (CFLibName "libp") ) - - , ( const (CmdBench.TargetProblemComponentNotBenchmark - "p-0.1" (CTestName "a-testsuite")) - , mkTargetComponent "p-0.1" (CTestName "a-testsuite") ) - ] ++ - [ ( const (CmdBench.TargetProblemIsSubComponent - "p-0.1" cname (ModuleTarget modname)) - , mkTargetModule "p-0.1" cname modname ) - | (cname, modname) <- [ (CTestName "a-testsuite", "TestModule") - , (CBenchName "a-benchmark", "BenchModule") - , (CExeName "an-exe", "ExeModule") - , (CLibName, "P") - ] - ] ++ - [ ( const (CmdBench.TargetProblemIsSubComponent - "p-0.1" cname (FileTarget fname)) - , mkTargetFile "p-0.1" cname fname) - | (cname, fname) <- [ (CTestName "a-testsuite", "Test.hs") - , (CBenchName "a-benchmark", "Bench.hs") - , (CExeName "an-exe", "Main.hs") - ] - ] - - -testTargetProblemsHaddock :: ProjectConfig -> (String -> IO ()) -> Assertion -testTargetProblemsHaddock config reportSubCase = do - - reportSubCase "all-disabled" - assertProjectTargetProblems - "targets/all-disabled" - config - (let haddockFlags = mkHaddockFlags False True True False - in CmdHaddock.selectPackageTargets haddockFlags) - CmdHaddock.selectComponentTarget - CmdHaddock.TargetProblemCommon - [ ( flip CmdHaddock.TargetProblemNoneEnabled - [ AvailableTarget "p-0.1" (CBenchName "user-disabled") - TargetDisabledByUser True - , AvailableTarget "p-0.1" (CTestName "solver-disabled") - TargetDisabledBySolver True - , AvailableTarget "p-0.1" (CExeName "buildable-false") - TargetNotBuildable True - , AvailableTarget "p-0.1" CLibName - TargetNotBuildable True - ] - , mkTargetPackage "p-0.1" ) - ] - - reportSubCase "empty-pkg" - assertProjectTargetProblems - "targets/empty-pkg" config - (let haddockFlags = mkHaddockFlags False False False False - in CmdHaddock.selectPackageTargets haddockFlags) - CmdHaddock.selectComponentTarget - CmdHaddock.TargetProblemCommon - [ ( CmdHaddock.TargetProblemNoTargets, mkTargetPackage "p-0.1" ) - ] - - reportSubCase "enabled component kinds" - -- When we explicitly enable all the component kinds then selecting the - -- whole package selects those component kinds too - (_,elaboratedPlan,_) <- planProject "targets/variety" config - let haddockFlags = mkHaddockFlags True True True True - in assertProjectDistinctTargets - elaboratedPlan - (CmdHaddock.selectPackageTargets haddockFlags) - CmdHaddock.selectComponentTarget - CmdHaddock.TargetProblemCommon - [ mkTargetPackage "p-0.1" ] - [ ("p-0.1-inplace", CLibName) - , ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") - , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") - , ("p-0.1-inplace-an-exe", CExeName "an-exe") - , ("p-0.1-inplace-libp", CFLibName "libp") - ] - - reportSubCase "disabled component kinds" - -- When we explicitly disable all the component kinds then selecting the - -- whole package only selects the library - let haddockFlags = mkHaddockFlags False False False False - in assertProjectDistinctTargets - elaboratedPlan - (CmdHaddock.selectPackageTargets haddockFlags) - CmdHaddock.selectComponentTarget - CmdHaddock.TargetProblemCommon - [ mkTargetPackage "p-0.1" ] - [ ("p-0.1-inplace", CLibName) ] - - reportSubCase "requested component kinds" - -- When we selecting the package with an explicit filter then it does not - -- matter if the config was to disable all the component kinds - let haddockFlags = mkHaddockFlags False False False False - in assertProjectDistinctTargets - elaboratedPlan - (CmdHaddock.selectPackageTargets haddockFlags) - CmdHaddock.selectComponentTarget - CmdHaddock.TargetProblemCommon - [ TargetPackage TargetExplicitNamed ["p-0.1"] (Just FLibKind) - , TargetPackage TargetExplicitNamed ["p-0.1"] (Just ExeKind) - , TargetPackage TargetExplicitNamed ["p-0.1"] (Just TestKind) - , TargetPackage TargetExplicitNamed ["p-0.1"] (Just BenchKind) - ] - [ ("p-0.1-inplace-a-benchmark", CBenchName "a-benchmark") - , ("p-0.1-inplace-a-testsuite", CTestName "a-testsuite") - , ("p-0.1-inplace-an-exe", CExeName "an-exe") - , ("p-0.1-inplace-libp", CFLibName "libp") - ] - where - mkHaddockFlags flib exe test bench = - defaultHaddockFlags { - haddockForeignLibs = toFlag flib, - haddockExecutables = toFlag exe, - haddockTestSuites = toFlag test, - haddockBenchmarks = toFlag bench - } - -assertProjectDistinctTargets - :: forall err. (Eq err, Show err) => - ElaboratedInstallPlan - -> (forall k. TargetSelector -> [AvailableTarget k] -> Either err [k]) - -> (forall k. SubComponentTarget -> AvailableTarget k -> Either err k ) - -> (TargetProblemCommon -> err) - -> [TargetSelector] - -> [(UnitId, ComponentName)] - -> Assertion -assertProjectDistinctTargets elaboratedPlan - selectPackageTargets - selectComponentTarget - liftProblem - targetSelectors - expectedTargets - | Right targets <- results - = distinctTargetComponents targets @?= Set.fromList expectedTargets - - | otherwise - = assertFailure $ "assertProjectDistinctTargets: expected " - ++ "(Right targets) but got " ++ show results - where - results = resolveTargets - selectPackageTargets - selectComponentTarget - liftProblem - elaboratedPlan - targetSelectors - - -assertProjectTargetProblems - :: forall err. (Eq err, Show err) => - FilePath -> ProjectConfig - -> (forall k. TargetSelector - -> [AvailableTarget k] - -> Either err [k]) - -> (forall k. SubComponentTarget - -> AvailableTarget k - -> Either err k ) - -> (TargetProblemCommon -> err) - -> [(TargetSelector -> err, TargetSelector)] - -> Assertion -assertProjectTargetProblems testdir config - selectPackageTargets - selectComponentTarget - liftProblem - cases = do - (_,elaboratedPlan,_) <- planProject testdir config - assertTargetProblems - elaboratedPlan - selectPackageTargets - selectComponentTarget - liftProblem - cases - - -assertTargetProblems - :: forall err. (Eq err, Show err) => - ElaboratedInstallPlan - -> (forall k. TargetSelector -> [AvailableTarget k] -> Either err [k]) - -> (forall k. SubComponentTarget -> AvailableTarget k -> Either err k ) - -> (TargetProblemCommon -> err) - -> [(TargetSelector -> err, TargetSelector)] - -> Assertion -assertTargetProblems elaboratedPlan - selectPackageTargets - selectComponentTarget - liftProblem = - mapM_ (uncurry assertTargetProblem) - where - assertTargetProblem expected targetSelector = - let res = resolveTargets selectPackageTargets selectComponentTarget - liftProblem elaboratedPlan [targetSelector] in - case res of - Left [problem] -> - problem @?= expected targetSelector - - unexpected -> - assertFailure $ "expected resolveTargets result: (Left [problem]) " - ++ "but got: " ++ show unexpected - - -testExceptionInFindingPackage :: ProjectConfig -> Assertion -testExceptionInFindingPackage config = do - BadPackageLocations _ locs <- expectException "BadPackageLocations" $ - void $ planProject testdir config - case locs of - [BadLocGlobEmptyMatch "./*.cabal"] -> return () - _ -> assertFailure "expected BadLocGlobEmptyMatch" - cleanProject testdir - where - testdir = "exception/no-pkg" - - -testExceptionInFindingPackage2 :: ProjectConfig -> Assertion -testExceptionInFindingPackage2 config = do - BadPackageLocations _ locs <- expectException "BadPackageLocations" $ - void $ planProject testdir config - case locs of - [BadPackageLocationFile (BadLocDirNoCabalFile ".")] -> return () - _ -> assertFailure $ "expected BadLocDirNoCabalFile, got " ++ show locs - cleanProject testdir - where - testdir = "exception/no-pkg2" - - -testExceptionInProjectConfig :: ProjectConfig -> Assertion -testExceptionInProjectConfig config = do - BadPerPackageCompilerPaths ps <- expectException "BadPerPackageCompilerPaths" $ - void $ planProject testdir config - case ps of - [(pn,"ghc")] | "foo" == pn -> return () - _ -> assertFailure $ "expected (PackageName \"foo\",\"ghc\"), got " - ++ show ps - cleanProject testdir - where - testdir = "exception/bad-config" - - -testExceptionInConfigureStep :: ProjectConfig -> Assertion -testExceptionInConfigureStep config = do - (plan, res) <- executePlan =<< planProject testdir config - (_pkga1, failure) <- expectPackageFailed plan res pkgidA1 - case buildFailureReason failure of - ConfigureFailed _ -> return () - _ -> assertFailure $ "expected ConfigureFailed, got " ++ show failure - cleanProject testdir - where - testdir = "exception/configure" - pkgidA1 = PackageIdentifier "a" (mkVersion [1]) - - -testExceptionInBuildStep :: ProjectConfig -> Assertion -testExceptionInBuildStep config = do - (plan, res) <- executePlan =<< planProject testdir config - (_pkga1, failure) <- expectPackageFailed plan res pkgidA1 - expectBuildFailed failure - where - testdir = "exception/build" - pkgidA1 = PackageIdentifier "a" (mkVersion [1]) - -testSetupScriptStyles :: ProjectConfig -> (String -> IO ()) -> Assertion -testSetupScriptStyles config reportSubCase = do - - reportSubCase (show SetupCustomExplicitDeps) - - plan0@(_,_,sharedConfig) <- planProject testdir1 config - - let isOSX (Platform _ OSX) = True - isOSX _ = False - -- Skip the Custom tests when the shipped Cabal library is buggy - unless (isOSX (pkgConfigPlatform sharedConfig) - && compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [7,10]) $ do - - (plan1, res1) <- executePlan plan0 - (pkg1, _) <- expectPackageInstalled plan1 res1 pkgidA - elabSetupScriptStyle pkg1 @?= SetupCustomExplicitDeps - hasDefaultSetupDeps pkg1 @?= Just False - marker1 <- readFile (basedir testdir1 "marker") - marker1 @?= "ok" - removeFile (basedir testdir1 "marker") - - -- implicit deps implies 'Cabal < 2' which conflicts w/ GHC 8.2 or later - when (compilerVersion (pkgConfigCompiler sharedConfig) < mkVersion [8,2]) $ do - reportSubCase (show SetupCustomImplicitDeps) - (plan2, res2) <- executePlan =<< planProject testdir2 config - (pkg2, _) <- expectPackageInstalled plan2 res2 pkgidA - elabSetupScriptStyle pkg2 @?= SetupCustomImplicitDeps - hasDefaultSetupDeps pkg2 @?= Just True - marker2 <- readFile (basedir testdir2 "marker") - marker2 @?= "ok" - removeFile (basedir testdir2 "marker") - - reportSubCase (show SetupNonCustomInternalLib) - (plan3, res3) <- executePlan =<< planProject testdir3 config - (pkg3, _) <- expectPackageInstalled plan3 res3 pkgidA - elabSetupScriptStyle pkg3 @?= SetupNonCustomInternalLib -{- - --TODO: the SetupNonCustomExternalLib case is hard to test since it - -- requires a version of Cabal that's later than the one we're testing - -- e.g. needs a .cabal file that specifies cabal-version: >= 2.0 - -- and a corresponding Cabal package that we can use to try and build a - -- default Setup.hs. - reportSubCase (show SetupNonCustomExternalLib) - (plan4, res4) <- executePlan =<< planProject testdir4 config - (pkg4, _) <- expectPackageInstalled plan4 res4 pkgidA - pkgSetupScriptStyle pkg4 @?= SetupNonCustomExternalLib --} - where - testdir1 = "build/setup-custom1" - testdir2 = "build/setup-custom2" - testdir3 = "build/setup-simple" - pkgidA = PackageIdentifier "a" (mkVersion [0,1]) - -- The solver fills in default setup deps explicitly, but marks them as such - hasDefaultSetupDeps = fmap defaultSetupDepends - . setupBuildInfo . elabPkgDescription - --- | Test the behaviour with and without @--keep-going@ --- -testBuildKeepGoing :: ProjectConfig -> Assertion -testBuildKeepGoing config = do - -- P is expected to fail, Q does not depend on P but without - -- parallel build and without keep-going then we don't build Q yet. - (plan1, res1) <- executePlan =<< planProject testdir (config <> keepGoing False) - (_, failure1) <- expectPackageFailed plan1 res1 "p-0.1" - expectBuildFailed failure1 - _ <- expectPackageConfigured plan1 res1 "q-0.1" - - -- With keep-going then we should go on to sucessfully build Q - (plan2, res2) <- executePlan - =<< planProject testdir (config <> keepGoing True) - (_, failure2) <- expectPackageFailed plan2 res2 "p-0.1" - expectBuildFailed failure2 - _ <- expectPackageInstalled plan2 res2 "q-0.1" - return () - where - testdir = "build/keep-going" - keepGoing kg = - mempty { - projectConfigBuildOnly = mempty { - projectConfigKeepGoing = toFlag kg - } - } - --- | See --- -testRegressionIssue3324 :: ProjectConfig -> Assertion -testRegressionIssue3324 config = do - -- expected failure first time due to missing dep - (plan1, res1) <- executePlan =<< planProject testdir config - (_pkgq, failure) <- expectPackageFailed plan1 res1 "q-0.1" - expectBuildFailed failure - - -- add the missing dep, now it should work - let qcabal = basedir testdir "q" "q.cabal" - withFileFinallyRestore qcabal $ do - appendFile qcabal (" build-depends: p\n") - (plan2, res2) <- executePlan =<< planProject testdir config - _ <- expectPackageInstalled plan2 res2 "p-0.1" - _ <- expectPackageInstalled plan2 res2 "q-0.1" - return () - where - testdir = "regression/3324" - - ---------------------------------- --- Test utils to plan and build --- - -basedir :: FilePath -basedir = "tests" "IntegrationTests2" - -dirActions :: FilePath -> TS.DirActions IO -dirActions testdir = - defaultDirActions { - TS.doesFileExist = \p -> - TS.doesFileExist defaultDirActions (virtcwd p), - - TS.doesDirectoryExist = \p -> - TS.doesDirectoryExist defaultDirActions (virtcwd p), - - TS.canonicalizePath = \p -> - TS.canonicalizePath defaultDirActions (virtcwd p), - - TS.getCurrentDirectory = - TS.canonicalizePath defaultDirActions virtcwd - } - where - virtcwd = basedir testdir - -type ProjDetails = (DistDirLayout, - CabalDirLayout, - ProjectConfig, - [PackageSpecifier UnresolvedSourcePackage], - BuildTimeSettings) - -configureProject :: FilePath -> ProjectConfig -> IO ProjDetails -configureProject testdir cliConfig = do - cabalDir <- defaultCabalDir - let cabalDirLayout = defaultCabalDirLayout cabalDir - - projectRootDir <- canonicalizePath (basedir testdir) - isexplict <- doesFileExist (projectRootDir "cabal.project") - let projectRoot - | isexplict = ProjectRootExplicit projectRootDir - (projectRootDir "cabal.project") - | otherwise = ProjectRootImplicit projectRootDir - distDirLayout = defaultDistDirLayout projectRoot Nothing - - -- Clear state between test runs. The state remains if the previous run - -- ended in an exception (as we leave the files to help with debugging). - cleanProject testdir - - (projectConfig, localPackages) <- - rebuildProjectConfig verbosity - distDirLayout - cliConfig - - let buildSettings = resolveBuildTimeSettings - verbosity cabalDirLayout - projectConfig - - return (distDirLayout, - cabalDirLayout, - projectConfig, - localPackages, - buildSettings) - -type PlanDetails = (ProjDetails, - ElaboratedInstallPlan, - ElaboratedSharedConfig) - -planProject :: FilePath -> ProjectConfig -> IO PlanDetails -planProject testdir cliConfig = do - - projDetails@ - (distDirLayout, - cabalDirLayout, - projectConfig, - localPackages, - _buildSettings) <- configureProject testdir cliConfig - - (elaboratedPlan, _, elaboratedShared) <- - rebuildInstallPlan verbosity - distDirLayout cabalDirLayout - projectConfig - localPackages - - return (projDetails, - elaboratedPlan, - elaboratedShared) - -executePlan :: PlanDetails -> IO (ElaboratedInstallPlan, BuildOutcomes) -executePlan ((distDirLayout, cabalDirLayout, _, _, buildSettings), - elaboratedPlan, - elaboratedShared) = do - - let targets :: Map.Map UnitId [ComponentTarget] - targets = - Map.fromList - [ (unitid, [ComponentTarget cname WholeComponent]) - | ts <- Map.elems (availableTargets elaboratedPlan) - , AvailableTarget { - availableTargetStatus = TargetBuildable (unitid, cname) _ - } <- ts - ] - elaboratedPlan' = pruneInstallPlanToTargets - TargetActionBuild targets - elaboratedPlan - - pkgsBuildStatus <- - rebuildTargetsDryRun distDirLayout elaboratedShared - elaboratedPlan' - - let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages - pkgsBuildStatus elaboratedPlan' - - buildOutcomes <- - rebuildTargets verbosity - distDirLayout - (cabalStoreDirLayout cabalDirLayout) - elaboratedPlan'' - elaboratedShared - pkgsBuildStatus - -- Avoid trying to use act-as-setup mode: - buildSettings { buildSettingNumJobs = 1 } - - return (elaboratedPlan'', buildOutcomes) - -cleanProject :: FilePath -> IO () -cleanProject testdir = do - alreadyExists <- doesDirectoryExist distDir - when alreadyExists $ removeDirectoryRecursive distDir - where - projectRoot = ProjectRootImplicit (basedir testdir) - distDirLayout = defaultDistDirLayout projectRoot Nothing - distDir = distDirectory distDirLayout - - -verbosity :: Verbosity -verbosity = minBound --normal --verbose --maxBound --minBound - - - -------------------------------------------- --- Tasty integration to adjust the config --- - -withProjectConfig :: (ProjectConfig -> TestTree) -> TestTree -withProjectConfig testtree = - askOption $ \ghcPath -> - testtree (mkProjectConfig ghcPath) - -mkProjectConfig :: GhcPath -> ProjectConfig -mkProjectConfig (GhcPath ghcPath) = - mempty { - projectConfigShared = mempty { - projectConfigHcPath = maybeToFlag ghcPath - }, - projectConfigBuildOnly = mempty { - projectConfigNumJobs = toFlag (Just 1) - } - } - where - maybeToFlag = maybe mempty toFlag - - -data GhcPath = GhcPath (Maybe FilePath) - deriving Typeable - -instance IsOption GhcPath where - defaultValue = GhcPath Nothing - optionName = Tagged "with-ghc" - optionHelp = Tagged "The ghc compiler to use" - parseValue = Just . GhcPath . Just - -projectConfigOptionDescriptions :: [OptionDescription] -projectConfigOptionDescriptions = [Option (Proxy :: Proxy GhcPath)] - - ---------------------------------------- --- HUint style utils for this context --- - -expectException :: Exception e => String -> IO a -> IO e -expectException expected action = do - res <- try action - case res of - Left e -> return e - Right _ -> throwIO $ HUnitFailure Nothing $ "expected an exception " ++ expected - -expectPackagePreExisting :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId - -> IO InstalledPackageInfo -expectPackagePreExisting plan buildOutcomes pkgid = do - planpkg <- expectPlanPackage plan pkgid - case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of - (InstallPlan.PreExisting pkg, Nothing) - -> return pkg - (_, buildResult) -> unexpectedBuildResult "PreExisting" planpkg buildResult - -expectPackageConfigured :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId - -> IO ElaboratedConfiguredPackage -expectPackageConfigured plan buildOutcomes pkgid = do - planpkg <- expectPlanPackage plan pkgid - case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of - (InstallPlan.Configured pkg, Nothing) - -> return pkg - (_, buildResult) -> unexpectedBuildResult "Configured" planpkg buildResult - -expectPackageInstalled :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId - -> IO (ElaboratedConfiguredPackage, BuildResult) -expectPackageInstalled plan buildOutcomes pkgid = do - planpkg <- expectPlanPackage plan pkgid - case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of - (InstallPlan.Configured pkg, Just (Right result)) - -> return (pkg, result) - (_, buildResult) -> unexpectedBuildResult "Installed" planpkg buildResult - -expectPackageFailed :: ElaboratedInstallPlan -> BuildOutcomes -> PackageId - -> IO (ElaboratedConfiguredPackage, BuildFailure) -expectPackageFailed plan buildOutcomes pkgid = do - planpkg <- expectPlanPackage plan pkgid - case (planpkg, InstallPlan.lookupBuildOutcome planpkg buildOutcomes) of - (InstallPlan.Configured pkg, Just (Left failure)) - -> return (pkg, failure) - (_, buildResult) -> unexpectedBuildResult "Failed" planpkg buildResult - -unexpectedBuildResult :: String -> ElaboratedPlanPackage - -> Maybe (Either BuildFailure BuildResult) -> IO a -unexpectedBuildResult expected planpkg buildResult = - throwIO $ HUnitFailure Nothing $ - "expected to find " ++ display (packageId planpkg) ++ " in the " - ++ expected ++ " state, but it is actually in the " ++ actual ++ " state." - where - actual = case (buildResult, planpkg) of - (Nothing, InstallPlan.PreExisting{}) -> "PreExisting" - (Nothing, InstallPlan.Configured{}) -> "Configured" - (Just (Right _), InstallPlan.Configured{}) -> "Installed" - (Just (Left _), InstallPlan.Configured{}) -> "Failed" - _ -> "Impossible!" - -expectPlanPackage :: ElaboratedInstallPlan -> PackageId - -> IO ElaboratedPlanPackage -expectPlanPackage plan pkgid = - case [ pkg - | pkg <- InstallPlan.toList plan - , packageId pkg == pkgid ] of - [pkg] -> return pkg - [] -> throwIO $ HUnitFailure Nothing $ - "expected to find " ++ display pkgid - ++ " in the install plan but it's not there" - _ -> throwIO $ HUnitFailure Nothing $ - "expected to find only one instance of " ++ display pkgid - ++ " in the install plan but there's several" - -expectBuildFailed :: BuildFailure -> IO () -expectBuildFailed (BuildFailure _ (BuildFailed _)) = return () -expectBuildFailed (BuildFailure _ reason) = - assertFailure $ "expected BuildFailed, got " ++ show reason - ---------------------------------------- --- Other utils --- - --- | Allow altering a file during a test, but then restore it afterwards --- -withFileFinallyRestore :: FilePath -> IO a -> IO a -withFileFinallyRestore file action = do - copyFile file backup - action `finally` renameFile backup file - where - backup = file <.> "backup" diff --git a/tests/IntegrationTests2/build/local-tarball/cabal.project b/tests/IntegrationTests2/build/local-tarball/cabal.project new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/local-tarball/cabal.project @@ -0,0 +1,2 @@ +packages: p-0.1.tar.gz + q/ diff --git a/tests/IntegrationTests2/build/local-tarball/p-0.1.tar.gz b/tests/IntegrationTests2/build/local-tarball/p-0.1.tar.gz new file mode 100644 Binary files /dev/null and b/tests/IntegrationTests2/build/local-tarball/p-0.1.tar.gz differ diff --git a/tests/IntegrationTests2/build/local-tarball/q/Q.hs b/tests/IntegrationTests2/build/local-tarball/q/Q.hs new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/local-tarball/q/Q.hs @@ -0,0 +1,5 @@ +module Q where + +import P + +q = p ++ " world" diff --git a/tests/IntegrationTests2/build/local-tarball/q/q.cabal b/tests/IntegrationTests2/build/local-tarball/q/q.cabal new file mode 100644 --- /dev/null +++ b/tests/IntegrationTests2/build/local-tarball/q/q.cabal @@ -0,0 +1,8 @@ +name: q +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Q + build-depends: base, p diff --git a/tests/MemoryUsageTests.hs b/tests/MemoryUsageTests.hs deleted file mode 100644 --- a/tests/MemoryUsageTests.hs +++ /dev/null @@ -1,15 +0,0 @@ -module MemoryUsageTests where - -import Test.Tasty - -import qualified UnitTests.Distribution.Solver.Modular.MemoryUsage - -tests :: TestTree -tests = - testGroup "Memory Usage" - [ testGroup "UnitTests.Distribution.Solver.Modular.MemoryUsage" - UnitTests.Distribution.Solver.Modular.MemoryUsage.tests - ] - -main :: IO () -main = defaultMain tests diff --git a/tests/SolverQuickCheck.hs b/tests/SolverQuickCheck.hs deleted file mode 100644 --- a/tests/SolverQuickCheck.hs +++ /dev/null @@ -1,16 +0,0 @@ -module SolverQuickCheck where - -import Test.Tasty - -import qualified UnitTests.Distribution.Solver.Modular.QuickCheck - - -tests :: TestTree -tests = - testGroup "Solver QuickCheck" - [ testGroup "UnitTests.Distribution.Solver.Modular.QuickCheck" - UnitTests.Distribution.Solver.Modular.QuickCheck.tests - ] - -main :: IO () -main = defaultMain tests diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs deleted file mode 100644 --- a/tests/UnitTests.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module UnitTests where - -import Test.Tasty - -import Distribution.Simple.Utils -import Distribution.Verbosity - -import Distribution.Compat.Time - -import qualified UnitTests.Distribution.Solver.Modular.Builder -import qualified UnitTests.Distribution.Solver.Modular.WeightedPSQ -import qualified UnitTests.Distribution.Solver.Modular.Solver -import qualified UnitTests.Distribution.Solver.Modular.RetryLog -import qualified UnitTests.Distribution.Client.FileMonitor -import qualified UnitTests.Distribution.Client.Glob -import qualified UnitTests.Distribution.Client.GZipUtils -import qualified UnitTests.Distribution.Client.Sandbox -import qualified UnitTests.Distribution.Client.Sandbox.Timestamp -import qualified UnitTests.Distribution.Client.Store -import qualified UnitTests.Distribution.Client.Tar -import qualified UnitTests.Distribution.Client.Targets -import qualified UnitTests.Distribution.Client.UserConfig -import qualified UnitTests.Distribution.Client.ProjectConfig -import qualified UnitTests.Distribution.Client.JobControl -import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp -import qualified UnitTests.Distribution.Client.InstallPlan - -import UnitTests.Options - - -tests :: Int -> TestTree -tests mtimeChangeCalibrated = - askOption $ \(OptionMtimeChangeDelay mtimeChangeProvided) -> - let mtimeChange = if mtimeChangeProvided /= 0 - then mtimeChangeProvided - else mtimeChangeCalibrated - in - testGroup "Unit Tests" - [ testGroup "UnitTests.Distribution.Solver.Modular.Builder" - UnitTests.Distribution.Solver.Modular.Builder.tests - , testGroup "UnitTests.Distribution.Solver.Modular.WeightedPSQ" - UnitTests.Distribution.Solver.Modular.WeightedPSQ.tests - , testGroup "UnitTests.Distribution.Solver.Modular.Solver" - UnitTests.Distribution.Solver.Modular.Solver.tests - , testGroup "UnitTests.Distribution.Solver.Modular.RetryLog" - UnitTests.Distribution.Solver.Modular.RetryLog.tests - , testGroup "UnitTests.Distribution.Client.FileMonitor" $ - UnitTests.Distribution.Client.FileMonitor.tests mtimeChange - , testGroup "UnitTests.Distribution.Client.Glob" - UnitTests.Distribution.Client.Glob.tests - , testGroup "Distribution.Client.GZipUtils" - UnitTests.Distribution.Client.GZipUtils.tests - , testGroup "Distribution.Client.Sandbox" - UnitTests.Distribution.Client.Sandbox.tests - , testGroup "Distribution.Client.Sandbox.Timestamp" - UnitTests.Distribution.Client.Sandbox.Timestamp.tests - , testGroup "Distribution.Client.Store" - UnitTests.Distribution.Client.Store.tests - , testGroup "Distribution.Client.Tar" - UnitTests.Distribution.Client.Tar.tests - , testGroup "Distribution.Client.Targets" - UnitTests.Distribution.Client.Targets.tests - , testGroup "UnitTests.Distribution.Client.UserConfig" - UnitTests.Distribution.Client.UserConfig.tests - , testGroup "UnitTests.Distribution.Client.ProjectConfig" - UnitTests.Distribution.Client.ProjectConfig.tests - , testGroup "UnitTests.Distribution.Client.JobControl" - UnitTests.Distribution.Client.JobControl.tests - , testGroup "UnitTests.Distribution.Client.IndexUtils.Timestamp" - UnitTests.Distribution.Client.IndexUtils.Timestamp.tests - , testGroup "UnitTests.Distribution.Client.InstallPlan" - UnitTests.Distribution.Client.InstallPlan.tests - ] - -main :: IO () -main = do - (mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay - let toMillis :: Int -> Double - toMillis x = fromIntegral x / 1000.0 - notice normal $ "File modification time resolution calibration completed, " - ++ "maximum delay observed: " - ++ (show . toMillis $ mtimeChange ) ++ " ms. " - ++ "Will be using delay of " ++ (show . toMillis $ mtimeChange') - ++ " for test runs." - defaultMainWithIngredients - (includingOptions extraOptions : defaultIngredients) - (tests mtimeChange') - diff --git a/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module UnitTests.Distribution.Client.ArbitraryInstances ( - adjustSize, - shortListOf, - shortListOf1, - arbitraryFlag, - ShortToken(..), - arbitraryShortToken, - NonMEmpty(..), - NoShrink(..), - ) where - -import Data.Char -import Data.List -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -import Control.Applicative -#endif -import Control.Monad - -import Distribution.Version -import Distribution.Types.Dependency -import Distribution.Package -import Distribution.System -import Distribution.Verbosity - -import Distribution.Simple.Setup -import Distribution.Simple.InstallDirs - -import Distribution.Utils.NubList - -import Distribution.Client.IndexUtils.Timestamp - -import Test.QuickCheck - - -adjustSize :: (Int -> Int) -> Gen a -> Gen a -adjustSize adjust gen = sized (\n -> resize (adjust n) gen) - -shortListOf :: Int -> Gen a -> Gen [a] -shortListOf bound gen = - sized $ \n -> do - k <- choose (0, (n `div` 2) `min` bound) - vectorOf k gen - -shortListOf1 :: Int -> Gen a -> Gen [a] -shortListOf1 bound gen = - sized $ \n -> do - k <- choose (1, 1 `max` ((n `div` 2) `min` bound)) - vectorOf k gen - -newtype ShortToken = ShortToken { getShortToken :: String } - deriving Show - -instance Arbitrary ShortToken where - arbitrary = - ShortToken <$> - (shortListOf1 5 (choose ('#', '~')) - `suchThat` (not . ("[]" `isPrefixOf`))) - --TODO: [code cleanup] need to replace parseHaskellString impl to stop - -- accepting Haskell list syntax [], ['a'] etc, just allow String syntax. - -- Workaround, don't generate [] as this does not round trip. - - - shrink (ShortToken cs) = - [ ShortToken cs' | cs' <- shrink cs, not (null cs') ] - -arbitraryShortToken :: Gen String -arbitraryShortToken = getShortToken <$> arbitrary - -instance Arbitrary Version where - arbitrary = do - branch <- shortListOf1 4 $ - frequency [(3, return 0) - ,(3, return 1) - ,(2, return 2) - ,(1, return 3)] - return (mkVersion branch) - where - - shrink ver = [ mkVersion branch' | branch' <- shrink (versionNumbers ver) - , not (null branch') ] - -instance Arbitrary VersionRange where - arbitrary = canonicaliseVersionRange <$> sized verRangeExp - where - verRangeExp n = frequency $ - [ (2, return anyVersion) - , (1, liftM thisVersion arbitrary) - , (1, liftM laterVersion arbitrary) - , (1, liftM orLaterVersion arbitrary) - , (1, liftM orLaterVersion' arbitrary) - , (1, liftM earlierVersion arbitrary) - , (1, liftM orEarlierVersion arbitrary) - , (1, liftM orEarlierVersion' arbitrary) - , (1, liftM withinVersion arbitrary) - , (2, liftM VersionRangeParens arbitrary) - ] ++ if n == 0 then [] else - [ (2, liftM2 unionVersionRanges verRangeExp2 verRangeExp2) - , (2, liftM2 intersectVersionRanges verRangeExp2 verRangeExp2) - ] - where - verRangeExp2 = verRangeExp (n `div` 2) - - orLaterVersion' v = - unionVersionRanges (laterVersion v) (thisVersion v) - orEarlierVersion' v = - unionVersionRanges (earlierVersion v) (thisVersion v) - - canonicaliseVersionRange = fromVersionIntervals . toVersionIntervals - -instance Arbitrary PackageName where - arbitrary = mkPackageName . intercalate "-" <$> shortListOf1 2 nameComponent - where - nameComponent = shortListOf1 5 (elements packageChars) - `suchThat` (not . all isDigit) - packageChars = filter isAlphaNum ['\0'..'\127'] - -instance Arbitrary Dependency where - arbitrary = Dependency <$> arbitrary <*> arbitrary - -instance Arbitrary OS where - arbitrary = elements knownOSs - -instance Arbitrary Arch where - arbitrary = elements knownArches - -instance Arbitrary Platform where - arbitrary = Platform <$> arbitrary <*> arbitrary - -instance Arbitrary a => Arbitrary (Flag a) where - arbitrary = arbitraryFlag arbitrary - shrink NoFlag = [] - shrink (Flag x) = NoFlag : [ Flag x' | x' <- shrink x ] - -arbitraryFlag :: Gen a -> Gen (Flag a) -arbitraryFlag genA = - sized $ \sz -> - case sz of - 0 -> pure NoFlag - _ -> frequency [ (1, pure NoFlag) - , (3, Flag <$> genA) ] - - -instance (Arbitrary a, Ord a) => Arbitrary (NubList a) where - arbitrary = toNubList <$> arbitrary - shrink xs = [ toNubList [] | (not . null) (fromNubList xs) ] - -- try empty, otherwise don't shrink as it can loop - -instance Arbitrary Verbosity where - arbitrary = elements [minBound..maxBound] - -instance Arbitrary PathTemplate where - arbitrary = toPathTemplate <$> arbitraryShortToken - shrink t = [ toPathTemplate s | s <- shrink (show t), not (null s) ] - - -newtype NonMEmpty a = NonMEmpty { getNonMEmpty :: a } - deriving (Eq, Ord, Show) - -instance (Arbitrary a, Monoid a, Eq a) => Arbitrary (NonMEmpty a) where - arbitrary = NonMEmpty <$> (arbitrary `suchThat` (/= mempty)) - shrink (NonMEmpty x) = [ NonMEmpty x' | x' <- shrink x, x' /= mempty ] - -newtype NoShrink a = NoShrink { getNoShrink :: a } - deriving (Eq, Ord, Show) - -instance Arbitrary a => Arbitrary (NoShrink a) where - arbitrary = NoShrink <$> arbitrary - shrink _ = [] - -instance Arbitrary Timestamp where - arbitrary = (maybe (toEnum 0) id . epochTimeToTimestamp) <$> arbitrary - -instance Arbitrary IndexState where - arbitrary = frequency [ (1, pure IndexStateHead) - , (50, IndexStateTime <$> arbitrary) - ] diff --git a/tests/UnitTests/Distribution/Client/FileMonitor.hs b/tests/UnitTests/Distribution/Client/FileMonitor.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/FileMonitor.hs +++ /dev/null @@ -1,857 +0,0 @@ -module UnitTests.Distribution.Client.FileMonitor (tests) where - -import Control.Monad -import Control.Exception -import Control.Concurrent (threadDelay) -import qualified Data.Set as Set -import System.FilePath -import qualified System.Directory as IO -import Prelude hiding (writeFile) -import qualified Prelude as IO (writeFile) - -import Distribution.Text (simpleParse) -import Distribution.Compat.Binary -import Distribution.Simple.Utils (withTempDirectory) -import Distribution.Verbosity (silent) - -import Distribution.Client.FileMonitor -import Distribution.Compat.Time - -import Test.Tasty -import Test.Tasty.HUnit - - -tests :: Int -> [TestTree] -tests mtimeChange = - [ testCase "sanity check mtimes" $ testFileMTimeSanity mtimeChange - , testCase "sanity check dirs" $ testDirChangeSanity mtimeChange - , testCase "no monitor cache" testNoMonitorCache - , testCase "corrupt monitor cache" testCorruptMonitorCache - , testCase "empty monitor" testEmptyMonitor - , testCase "missing file" testMissingFile - , testCase "change file" $ testChangedFile mtimeChange - , testCase "file mtime vs content" $ testChangedFileMtimeVsContent mtimeChange - , testCase "update during action" $ testUpdateDuringAction mtimeChange - , testCase "remove file" testRemoveFile - , testCase "non-existent file" testNonExistentFile - , testCase "changed file type" $ testChangedFileType mtimeChange - , testCase "several monitor kinds" $ testMultipleMonitorKinds mtimeChange - - , testGroup "glob matches" - [ testCase "no change" testGlobNoChange - , testCase "add match" $ testGlobAddMatch mtimeChange - , testCase "remove match" $ testGlobRemoveMatch mtimeChange - , testCase "change match" $ testGlobChangeMatch mtimeChange - - , testCase "add match subdir" $ testGlobAddMatchSubdir mtimeChange - , testCase "remove match subdir" $ testGlobRemoveMatchSubdir mtimeChange - , testCase "change match subdir" $ testGlobChangeMatchSubdir mtimeChange - - , testCase "match toplevel dir" $ testGlobMatchTopDir mtimeChange - , testCase "add non-match" $ testGlobAddNonMatch mtimeChange - , testCase "remove non-match" $ testGlobRemoveNonMatch mtimeChange - - , testCase "add non-match" $ testGlobAddNonMatchSubdir mtimeChange - , testCase "remove non-match" $ testGlobRemoveNonMatchSubdir mtimeChange - - , testCase "invariant sorted 1" $ testInvariantMonitorStateGlobFiles - mtimeChange - , testCase "invariant sorted 2" $ testInvariantMonitorStateGlobDirs - mtimeChange - - , testCase "match dirs" $ testGlobMatchDir mtimeChange - , testCase "match dirs only" $ testGlobMatchDirOnly mtimeChange - , testCase "change file type" $ testGlobChangeFileType mtimeChange - , testCase "absolute paths" $ testGlobAbsolutePath mtimeChange - ] - - , testCase "value unchanged" testValueUnchanged - , testCase "value changed" testValueChanged - , testCase "value & file changed" $ testValueAndFileChanged mtimeChange - , testCase "value updated" testValueUpdated - ] - --- Check the file system behaves the way we expect it to - --- we rely on file mtimes having a reasonable resolution -testFileMTimeSanity :: Int -> Assertion -testFileMTimeSanity mtimeChange = - withTempDirectory silent "." "file-status-" $ \dir -> do - replicateM_ 10 $ do - IO.writeFile (dir "a") "content" - t1 <- getModTime (dir "a") - threadDelay mtimeChange - IO.writeFile (dir "a") "content" - t2 <- getModTime (dir "a") - assertBool "expected different file mtimes" (t2 > t1) - --- We rely on directories changing mtime when entries are added or removed -testDirChangeSanity :: Int -> Assertion -testDirChangeSanity mtimeChange = - withTempDirectory silent "." "dir-mtime-" $ \dir -> do - - expectMTimeChange dir "file add" $ - IO.writeFile (dir "file") "content" - - expectMTimeSame dir "file content change" $ - IO.writeFile (dir "file") "new content" - - expectMTimeChange dir "file del" $ - IO.removeFile (dir "file") - - expectMTimeChange dir "subdir add" $ - IO.createDirectory (dir "dir") - - expectMTimeSame dir "subdir file add" $ - IO.writeFile (dir "dir" "file") "content" - - expectMTimeChange dir "subdir file move in" $ - IO.renameFile (dir "dir" "file") (dir "file") - - expectMTimeChange dir "subdir file move out" $ - IO.renameFile (dir "file") (dir "dir" "file") - - expectMTimeSame dir "subdir dir add" $ - IO.createDirectory (dir "dir" "subdir") - - expectMTimeChange dir "subdir dir move in" $ - IO.renameDirectory (dir "dir" "subdir") (dir "subdir") - - expectMTimeChange dir "subdir dir move out" $ - IO.renameDirectory (dir "subdir") (dir "dir" "subdir") - - where - expectMTimeChange, expectMTimeSame :: FilePath -> String -> IO () - -> Assertion - - expectMTimeChange dir descr action = do - t <- getModTime dir - threadDelay mtimeChange - action - t' <- getModTime dir - assertBool ("expected dir mtime change on " ++ descr) (t' > t) - - expectMTimeSame dir descr action = do - t <- getModTime dir - threadDelay mtimeChange - action - t' <- getModTime dir - assertBool ("expected same dir mtime on " ++ descr) (t' == t) - - --- Now for the FileMonitor tests proper... - --- first run, where we don't even call updateMonitor -testNoMonitorCache :: Assertion -testNoMonitorCache = - withFileMonitor $ \root monitor -> do - reason <- expectMonitorChanged root (monitor :: FileMonitor () ()) () - reason @?= MonitorFirstRun - --- write garbage into the binary cache file -testCorruptMonitorCache :: Assertion -testCorruptMonitorCache = - withFileMonitor $ \root monitor -> do - IO.writeFile (fileMonitorCacheFile monitor) "broken" - reason <- expectMonitorChanged root monitor () - reason @?= MonitorCorruptCache - - updateMonitor root monitor [] () () - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [] - - IO.writeFile (fileMonitorCacheFile monitor) "broken" - reason2 <- expectMonitorChanged root monitor () - reason2 @?= MonitorCorruptCache - --- no files to monitor -testEmptyMonitor :: Assertion -testEmptyMonitor = - withFileMonitor $ \root monitor -> do - touchFile root "a" - updateMonitor root monitor [] () () - touchFile root "b" - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [] - --- monitor a file that is expected to exist -testMissingFile :: Assertion -testMissingFile = do - test monitorFile touchFile "a" - test monitorFileHashed touchFile "a" - test monitorFile touchFile ("dir" "a") - test monitorFileHashed touchFile ("dir" "a") - test monitorDirectory touchDir "a" - test monitorDirectory touchDir ("dir" "a") - where - test :: (FilePath -> MonitorFilePath) - -> (RootPath -> FilePath -> IO ()) - -> FilePath - -> IO () - test monitorKind touch file = - withFileMonitor $ \root monitor -> do - -- a file that doesn't exist at snapshot time is considered to have - -- changed - updateMonitor root monitor [monitorKind file] () () - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged file - - -- a file doesn't exist at snapshot time, but gets added afterwards is - -- also considered to have changed - updateMonitor root monitor [monitorKind file] () () - touch root file - reason2 <- expectMonitorChanged root monitor () - reason2 @?= MonitoredFileChanged file - - -testChangedFile :: Int -> Assertion -testChangedFile mtimeChange = do - test monitorFile touchFile touchFile "a" - test monitorFileHashed touchFile touchFileContent "a" - test monitorFile touchFile touchFile ("dir" "a") - test monitorFileHashed touchFile touchFileContent ("dir" "a") - test monitorDirectory touchDir touchDir "a" - test monitorDirectory touchDir touchDir ("dir" "a") - where - test :: (FilePath -> MonitorFilePath) - -> (RootPath -> FilePath -> IO ()) - -> (RootPath -> FilePath -> IO ()) - -> FilePath - -> IO () - test monitorKind touch touch' file = - withFileMonitor $ \root monitor -> do - touch root file - updateMonitor root monitor [monitorKind file] () () - threadDelay mtimeChange - touch' root file - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged file - - -testChangedFileMtimeVsContent :: Int -> Assertion -testChangedFileMtimeVsContent mtimeChange = - withFileMonitor $ \root monitor -> do - -- if we don't touch the file, it's unchanged - touchFile root "a" - updateMonitor root monitor [monitorFile "a"] () () - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [monitorFile "a"] - - -- if we do touch the file, it's changed if we only consider mtime - updateMonitor root monitor [monitorFile "a"] () () - threadDelay mtimeChange - touchFile root "a" - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged "a" - - -- but if we touch the file, it's unchanged if we consider content hash - updateMonitor root monitor [monitorFileHashed "a"] () () - threadDelay mtimeChange - touchFile root "a" - (res2, files2) <- expectMonitorUnchanged root monitor () - res2 @?= () - files2 @?= [monitorFileHashed "a"] - - -- finally if we change the content it's changed - updateMonitor root monitor [monitorFileHashed "a"] () () - threadDelay mtimeChange - touchFileContent root "a" - reason2 <- expectMonitorChanged root monitor () - reason2 @?= MonitoredFileChanged "a" - - -testUpdateDuringAction :: Int -> Assertion -testUpdateDuringAction mtimeChange = do - test (monitorFile "a") touchFile "a" - test (monitorFileHashed "a") touchFile "a" - test (monitorDirectory "a") touchDir "a" - test (monitorFileGlobStr "*") touchFile "a" - test (monitorFileGlobStr "*") { monitorKindDir = DirModTime } - touchDir "a" - where - test :: MonitorFilePath - -> (RootPath -> FilePath -> IO ()) - -> FilePath - -> IO () - test monitorSpec touch file = - withFileMonitor $ \root monitor -> do - touch root file - updateMonitor root monitor [monitorSpec] () () - - -- start doing an update action... - threadDelay mtimeChange -- some time passes - touch root file -- a file gets updates during the action - threadDelay mtimeChange -- some time passes then we finish - updateMonitor root monitor [monitorSpec] () () - -- we don't notice this change since we took the timestamp after the - -- action finished - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [monitorSpec] - - -- Let's try again, this time taking the timestamp before the action - timestamp' <- beginUpdateFileMonitor - threadDelay mtimeChange -- some time passes - touch root file -- a file gets updates during the action - threadDelay mtimeChange -- some time passes then we finish - updateMonitorWithTimestamp root monitor timestamp' [monitorSpec] () () - -- now we do notice the change since we took the snapshot before the - -- action finished - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged file - - -testRemoveFile :: Assertion -testRemoveFile = do - test monitorFile touchFile removeFile "a" - test monitorFileHashed touchFile removeFile "a" - test monitorFile touchFile removeFile ("dir" "a") - test monitorFileHashed touchFile removeFile ("dir" "a") - test monitorDirectory touchDir removeDir "a" - test monitorDirectory touchDir removeDir ("dir" "a") - where - test :: (FilePath -> MonitorFilePath) - -> (RootPath -> FilePath -> IO ()) - -> (RootPath -> FilePath -> IO ()) - -> FilePath - -> IO () - test monitorKind touch remove file = - withFileMonitor $ \root monitor -> do - touch root file - updateMonitor root monitor [monitorKind file] () () - remove root file - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged file - - --- monitor a file that we expect not to exist -testNonExistentFile :: Assertion -testNonExistentFile = - withFileMonitor $ \root monitor -> do - -- a file that doesn't exist at snapshot time or check time is unchanged - updateMonitor root monitor [monitorNonExistentFile "a"] () () - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [monitorNonExistentFile "a"] - - -- if the file then exists it has changed - touchFile root "a" - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged "a" - - -- if the file then exists at snapshot and check time it has changed - updateMonitor root monitor [monitorNonExistentFile "a"] () () - reason2 <- expectMonitorChanged root monitor () - reason2 @?= MonitoredFileChanged "a" - - -- but if the file existed at snapshot time and doesn't exist at check time - -- it is consider unchanged. This is unlike files we expect to exist, but - -- that's because files that exist can have different content and actions - -- can depend on that content, whereas if the action expected a file not to - -- exist and it now does not, it'll give the same result, irrespective of - -- the fact that the file might have existed in the meantime. - updateMonitor root monitor [monitorNonExistentFile "a"] () () - removeFile root "a" - (res2, files2) <- expectMonitorUnchanged root monitor () - res2 @?= () - files2 @?= [monitorNonExistentFile "a"] - - -testChangedFileType :: Int-> Assertion -testChangedFileType mtimeChange = do - test (monitorFile "a") touchFile removeFile createDir - test (monitorFileHashed "a") touchFile removeFile createDir - - test (monitorDirectory "a") createDir removeDir touchFile - test (monitorFileOrDirectory "a") createDir removeDir touchFile - - test (monitorFileGlobStr "*") { monitorKindDir = DirModTime } - touchFile removeFile createDir - test (monitorFileGlobStr "*") { monitorKindDir = DirModTime } - createDir removeDir touchFile - where - test :: MonitorFilePath - -> (RootPath -> String -> IO ()) - -> (RootPath -> String -> IO ()) - -> (RootPath -> String -> IO ()) - -> IO () - test monitorKind touch remove touch' = - withFileMonitor $ \root monitor -> do - touch root "a" - updateMonitor root monitor [monitorKind] () () - threadDelay mtimeChange - remove root "a" - touch' root "a" - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged "a" - --- Monitoring the same file with two different kinds of monitor should work --- both should be kept, and both checked for changes. --- We had a bug where only one monitor kind was kept per file. --- https://github.com/haskell/cabal/pull/3863#issuecomment-248495178 -testMultipleMonitorKinds :: Int -> Assertion -testMultipleMonitorKinds mtimeChange = - withFileMonitor $ \root monitor -> do - touchFile root "a" - updateMonitor root monitor [monitorFile "a", monitorFileHashed "a"] () () - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [monitorFile "a", monitorFileHashed "a"] - threadDelay mtimeChange - touchFile root "a" -- not changing content, just mtime - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged "a" - - createDir root "dir" - updateMonitor root monitor [monitorDirectory "dir", - monitorDirectoryExistence "dir"] () () - (res2, files2) <- expectMonitorUnchanged root monitor () - res2 @?= () - files2 @?= [monitorDirectory "dir", monitorDirectoryExistence "dir"] - threadDelay mtimeChange - touchFile root ("dir" "a") -- changing dir mtime, not existence - reason2 <- expectMonitorChanged root monitor () - reason2 @?= MonitoredFileChanged "dir" - - ------------------- --- globs --- - -testGlobNoChange :: Assertion -testGlobNoChange = - withFileMonitor $ \root monitor -> do - touchFile root ("dir" "good-a") - touchFile root ("dir" "good-b") - updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () () - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [monitorFileGlobStr "dir/good-*"] - -testGlobAddMatch :: Int -> Assertion -testGlobAddMatch mtimeChange = - withFileMonitor $ \root monitor -> do - touchFile root ("dir" "good-a") - updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () () - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [monitorFileGlobStr "dir/good-*"] - threadDelay mtimeChange - touchFile root ("dir" "good-b") - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged ("dir" "good-b") - -testGlobRemoveMatch :: Int -> Assertion -testGlobRemoveMatch mtimeChange = - withFileMonitor $ \root monitor -> do - touchFile root ("dir" "good-a") - touchFile root ("dir" "good-b") - updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () () - threadDelay mtimeChange - removeFile root "dir/good-a" - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged ("dir" "good-a") - -testGlobChangeMatch :: Int -> Assertion -testGlobChangeMatch mtimeChange = - withFileMonitor $ \root monitor -> do - touchFile root ("dir" "good-a") - touchFile root ("dir" "good-b") - updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () () - threadDelay mtimeChange - touchFile root ("dir" "good-b") - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [monitorFileGlobStr "dir/good-*"] - - touchFileContent root ("dir" "good-b") - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged ("dir" "good-b") - -testGlobAddMatchSubdir :: Int -> Assertion -testGlobAddMatchSubdir mtimeChange = - withFileMonitor $ \root monitor -> do - touchFile root ("dir" "a" "good-a") - updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () () - threadDelay mtimeChange - touchFile root ("dir" "b" "good-b") - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged ("dir" "b" "good-b") - -testGlobRemoveMatchSubdir :: Int -> Assertion -testGlobRemoveMatchSubdir mtimeChange = - withFileMonitor $ \root monitor -> do - touchFile root ("dir" "a" "good-a") - touchFile root ("dir" "b" "good-b") - updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () () - threadDelay mtimeChange - removeDir root ("dir" "a") - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged ("dir" "a" "good-a") - -testGlobChangeMatchSubdir :: Int -> Assertion -testGlobChangeMatchSubdir mtimeChange = - withFileMonitor $ \root monitor -> do - touchFile root ("dir" "a" "good-a") - touchFile root ("dir" "b" "good-b") - updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () () - threadDelay mtimeChange - touchFile root ("dir" "b" "good-b") - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [monitorFileGlobStr "dir/*/good-*"] - - touchFileContent root "dir/b/good-b" - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged ("dir" "b" "good-b") - --- check nothing goes squiffy with matching in the top dir -testGlobMatchTopDir :: Int -> Assertion -testGlobMatchTopDir mtimeChange = - withFileMonitor $ \root monitor -> do - updateMonitor root monitor [monitorFileGlobStr "*"] () () - threadDelay mtimeChange - touchFile root "a" - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged "a" - -testGlobAddNonMatch :: Int -> Assertion -testGlobAddNonMatch mtimeChange = - withFileMonitor $ \root monitor -> do - touchFile root ("dir" "good-a") - updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () () - threadDelay mtimeChange - touchFile root ("dir" "bad") - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [monitorFileGlobStr "dir/good-*"] - -testGlobRemoveNonMatch :: Int -> Assertion -testGlobRemoveNonMatch mtimeChange = - withFileMonitor $ \root monitor -> do - touchFile root ("dir" "good-a") - touchFile root ("dir" "bad") - updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () () - threadDelay mtimeChange - removeFile root "dir/bad" - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [monitorFileGlobStr "dir/good-*"] - -testGlobAddNonMatchSubdir :: Int -> Assertion -testGlobAddNonMatchSubdir mtimeChange = - withFileMonitor $ \root monitor -> do - touchFile root ("dir" "a" "good-a") - updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () () - threadDelay mtimeChange - touchFile root ("dir" "b" "bad") - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [monitorFileGlobStr "dir/*/good-*"] - -testGlobRemoveNonMatchSubdir :: Int -> Assertion -testGlobRemoveNonMatchSubdir mtimeChange = - withFileMonitor $ \root monitor -> do - touchFile root ("dir" "a" "good-a") - touchFile root ("dir" "b" "bad") - updateMonitor root monitor [monitorFileGlobStr "dir/*/good-*"] () () - threadDelay mtimeChange - removeDir root ("dir" "b") - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [monitorFileGlobStr "dir/*/good-*"] - - --- try and tickle a bug that happens if we don't maintain the invariant that --- MonitorStateGlobFiles entries are sorted -testInvariantMonitorStateGlobFiles :: Int -> Assertion -testInvariantMonitorStateGlobFiles mtimeChange = - withFileMonitor $ \root monitor -> do - touchFile root ("dir" "a") - touchFile root ("dir" "b") - touchFile root ("dir" "c") - touchFile root ("dir" "d") - updateMonitor root monitor [monitorFileGlobStr "dir/*"] () () - threadDelay mtimeChange - -- so there should be no change (since we're doing content checks) - -- but if we can get the dir entries to appear in the wrong order - -- then if the sorted invariant is not maintained then we can fool - -- the 'probeGlobStatus' into thinking there's changes - removeFile root ("dir" "a") - removeFile root ("dir" "b") - removeFile root ("dir" "c") - removeFile root ("dir" "d") - touchFile root ("dir" "d") - touchFile root ("dir" "c") - touchFile root ("dir" "b") - touchFile root ("dir" "a") - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [monitorFileGlobStr "dir/*"] - --- same thing for the subdirs case -testInvariantMonitorStateGlobDirs :: Int -> Assertion -testInvariantMonitorStateGlobDirs mtimeChange = - withFileMonitor $ \root monitor -> do - touchFile root ("dir" "a" "file") - touchFile root ("dir" "b" "file") - touchFile root ("dir" "c" "file") - touchFile root ("dir" "d" "file") - updateMonitor root monitor [monitorFileGlobStr "dir/*/file"] () () - threadDelay mtimeChange - removeDir root ("dir" "a") - removeDir root ("dir" "b") - removeDir root ("dir" "c") - removeDir root ("dir" "d") - touchFile root ("dir" "d" "file") - touchFile root ("dir" "c" "file") - touchFile root ("dir" "b" "file") - touchFile root ("dir" "a" "file") - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [monitorFileGlobStr "dir/*/file"] - --- ensure that a glob can match a directory as well as a file -testGlobMatchDir :: Int -> Assertion -testGlobMatchDir mtimeChange = - withFileMonitor $ \root monitor -> do - createDir root ("dir" "a") - updateMonitor root monitor [monitorFileGlobStr "dir/*"] () () - threadDelay mtimeChange - -- nothing changed yet - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [monitorFileGlobStr "dir/*"] - -- expect dir/b to match and be detected as changed - createDir root ("dir" "b") - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged ("dir" "b") - -- now remove dir/a and expect it to be detected as changed - updateMonitor root monitor [monitorFileGlobStr "dir/*"] () () - threadDelay mtimeChange - removeDir root ("dir" "a") - reason2 <- expectMonitorChanged root monitor () - reason2 @?= MonitoredFileChanged ("dir" "a") - -testGlobMatchDirOnly :: Int -> Assertion -testGlobMatchDirOnly mtimeChange = - withFileMonitor $ \root monitor -> do - updateMonitor root monitor [monitorFileGlobStr "dir/*/"] () () - threadDelay mtimeChange - -- expect file dir/a to not match, so not detected as changed - touchFile root ("dir" "a") - (res, files) <- expectMonitorUnchanged root monitor () - res @?= () - files @?= [monitorFileGlobStr "dir/*/"] - -- note that checking the file monitor for changes can updates the - -- cached dir mtimes (when it has to record that there's new matches) - -- so we need an extra mtime delay - threadDelay mtimeChange - -- but expect dir/b to match - createDir root ("dir" "b") - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged ("dir" "b") - -testGlobChangeFileType :: Int -> Assertion -testGlobChangeFileType mtimeChange = - withFileMonitor $ \root monitor -> do - -- change file to dir - touchFile root ("dir" "a") - updateMonitor root monitor [monitorFileGlobStr "dir/*"] () () - threadDelay mtimeChange - removeFile root ("dir" "a") - createDir root ("dir" "a") - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged ("dir" "a") - -- change dir to file - updateMonitor root monitor [monitorFileGlobStr "dir/*"] () () - threadDelay mtimeChange - removeDir root ("dir" "a") - touchFile root ("dir" "a") - reason2 <- expectMonitorChanged root monitor () - reason2 @?= MonitoredFileChanged ("dir" "a") - -testGlobAbsolutePath :: Int -> Assertion -testGlobAbsolutePath mtimeChange = - withFileMonitor $ \root monitor -> do - root' <- absoluteRoot root - -- absolute glob, removing a file - touchFile root ("dir/good-a") - touchFile root ("dir/good-b") - updateMonitor root monitor [monitorFileGlobStr (root' "dir/good-*")] () () - threadDelay mtimeChange - removeFile root "dir/good-a" - reason <- expectMonitorChanged root monitor () - reason @?= MonitoredFileChanged (root' "dir/good-a") - -- absolute glob, adding a file - updateMonitor root monitor [monitorFileGlobStr (root' "dir/good-*")] () () - threadDelay mtimeChange - touchFile root ("dir/good-a") - reason2 <- expectMonitorChanged root monitor () - reason2 @?= MonitoredFileChanged (root' "dir/good-a") - -- absolute glob, changing a file - updateMonitor root monitor [monitorFileGlobStr (root' "dir/good-*")] () () - threadDelay mtimeChange - touchFileContent root "dir/good-b" - reason3 <- expectMonitorChanged root monitor () - reason3 @?= MonitoredFileChanged (root' "dir/good-b") - - ------------------- --- value changes --- - -testValueUnchanged :: Assertion -testValueUnchanged = - withFileMonitor $ \root monitor -> do - touchFile root "a" - updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok" - (res, files) <- expectMonitorUnchanged root monitor 42 - res @?= "ok" - files @?= [monitorFile "a"] - -testValueChanged :: Assertion -testValueChanged = - withFileMonitor $ \root monitor -> do - touchFile root "a" - updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok" - reason <- expectMonitorChanged root monitor 43 - reason @?= MonitoredValueChanged 42 - -testValueAndFileChanged :: Int -> Assertion -testValueAndFileChanged mtimeChange = - withFileMonitor $ \root monitor -> do - touchFile root "a" - - -- we change the value and the file, and the value change is reported - updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok" - threadDelay mtimeChange - touchFile root "a" - reason <- expectMonitorChanged root monitor 43 - reason @?= MonitoredValueChanged 42 - - -- if fileMonitorCheckIfOnlyValueChanged then if only the value changed - -- then it's reported as MonitoredValueChanged - let monitor' :: FileMonitor Int String - monitor' = monitor { fileMonitorCheckIfOnlyValueChanged = True } - updateMonitor root monitor' [monitorFile "a"] 42 "ok" - reason2 <- expectMonitorChanged root monitor' 43 - reason2 @?= MonitoredValueChanged 42 - - -- but if a file changed too then we don't report MonitoredValueChanged - updateMonitor root monitor' [monitorFile "a"] 42 "ok" - threadDelay mtimeChange - touchFile root "a" - reason3 <- expectMonitorChanged root monitor' 43 - reason3 @?= MonitoredFileChanged "a" - -testValueUpdated :: Assertion -testValueUpdated = - withFileMonitor $ \root monitor -> do - touchFile root "a" - - let monitor' :: FileMonitor (Set.Set Int) String - monitor' = (monitor :: FileMonitor (Set.Set Int) String) { - fileMonitorCheckIfOnlyValueChanged = True, - fileMonitorKeyValid = Set.isSubsetOf - } - - updateMonitor root monitor' [monitorFile "a"] (Set.fromList [42,43]) "ok" - (res,_files) <- expectMonitorUnchanged root monitor' (Set.fromList [42]) - res @?= "ok" - - reason <- expectMonitorChanged root monitor' (Set.fromList [42,44]) - reason @?= MonitoredValueChanged (Set.fromList [42,43]) - - -------------- --- Utils - -newtype RootPath = RootPath FilePath - -touchFile :: RootPath -> FilePath -> IO () -touchFile (RootPath root) fname = do - let path = root fname - IO.createDirectoryIfMissing True (takeDirectory path) - IO.writeFile path "touched" - -touchFileContent :: RootPath -> FilePath -> IO () -touchFileContent (RootPath root) fname = do - let path = root fname - IO.createDirectoryIfMissing True (takeDirectory path) - IO.writeFile path "different" - -removeFile :: RootPath -> FilePath -> IO () -removeFile (RootPath root) fname = IO.removeFile (root fname) - -touchDir :: RootPath -> FilePath -> IO () -touchDir root@(RootPath rootdir) dname = do - IO.createDirectoryIfMissing True (rootdir dname) - touchFile root (dname "touch") - removeFile root (dname "touch") - -createDir :: RootPath -> FilePath -> IO () -createDir (RootPath root) dname = do - let path = root dname - IO.createDirectoryIfMissing True (takeDirectory path) - IO.createDirectory path - -removeDir :: RootPath -> FilePath -> IO () -removeDir (RootPath root) dname = IO.removeDirectoryRecursive (root dname) - -absoluteRoot :: RootPath -> IO FilePath -absoluteRoot (RootPath root) = IO.canonicalizePath root - -monitorFileGlobStr :: String -> MonitorFilePath -monitorFileGlobStr globstr - | Just glob <- simpleParse globstr = monitorFileGlob glob - | otherwise = error $ "Failed to parse " ++ globstr - - -expectMonitorChanged :: (Binary a, Binary b) - => RootPath -> FileMonitor a b -> a - -> IO (MonitorChangedReason a) -expectMonitorChanged root monitor key = do - res <- checkChanged root monitor key - case res of - MonitorChanged reason -> return reason - MonitorUnchanged _ _ -> throwIO $ HUnitFailure Nothing "expected change" - -expectMonitorUnchanged :: (Binary a, Binary b) - => RootPath -> FileMonitor a b -> a - -> IO (b, [MonitorFilePath]) -expectMonitorUnchanged root monitor key = do - res <- checkChanged root monitor key - case res of - MonitorChanged _reason -> throwIO $ HUnitFailure Nothing "expected no change" - MonitorUnchanged b files -> return (b, files) - -checkChanged :: (Binary a, Binary b) - => RootPath -> FileMonitor a b - -> a -> IO (MonitorChanged a b) -checkChanged (RootPath root) monitor key = - checkFileMonitorChanged monitor root key - -updateMonitor :: (Binary a, Binary b) - => RootPath -> FileMonitor a b - -> [MonitorFilePath] -> a -> b -> IO () -updateMonitor (RootPath root) monitor files key result = - updateFileMonitor monitor root Nothing files key result - -updateMonitorWithTimestamp :: (Binary a, Binary b) - => RootPath -> FileMonitor a b -> MonitorTimestamp - -> [MonitorFilePath] -> a -> b -> IO () -updateMonitorWithTimestamp (RootPath root) monitor timestamp files key result = - updateFileMonitor monitor root (Just timestamp) files key result - -withFileMonitor :: Eq a => (RootPath -> FileMonitor a b -> IO c) -> IO c -withFileMonitor action = do - withTempDirectory silent "." "file-status-" $ \root -> do - let file = root <.> "monitor" - monitor = newFileMonitor file - finally (action (RootPath root) monitor) $ do - exists <- IO.doesFileExist file - when exists $ IO.removeFile file diff --git a/tests/UnitTests/Distribution/Client/GZipUtils.hs b/tests/UnitTests/Distribution/Client/GZipUtils.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/GZipUtils.hs +++ /dev/null @@ -1,60 +0,0 @@ -module UnitTests.Distribution.Client.GZipUtils ( - tests - ) where - -import Codec.Compression.GZip as GZip -import Codec.Compression.Zlib as Zlib -import Control.Exception.Base (evaluate) -import Control.Exception (try, SomeException) -import Control.Monad (void) -import Data.ByteString as BS (null) -import Data.ByteString.Lazy as BSL (pack, toChunks) -import Data.ByteString.Lazy.Char8 as BSLL (pack, init, length) -import Data.Monoid ((<>)) -import Distribution.Client.GZipUtils (maybeDecompress) -import Data.Word (Word8) - -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck - -tests :: [TestTree] -tests = [ testCase "maybeDecompress" maybeDecompressUnitTest - -- "decompress plain" property is non-trivial to state, - -- maybeDecompress returns input bytestring only if error occurs right at the beginning of the decompression process - -- generating such input would essentially duplicate maybeDecompress implementation - , testProperty "decompress zlib" prop_maybeDecompress_zlib - , testProperty "decompress gzip" prop_maybeDecompress_gzip - ] - -maybeDecompressUnitTest :: Assertion -maybeDecompressUnitTest = - assertBool "decompress plain" (maybeDecompress original == original) - >> assertBool "decompress zlib (with show)" (show (maybeDecompress compressedZlib) == show original) - >> assertBool "decompress gzip (with show)" (show (maybeDecompress compressedGZip) == show original) - >> assertBool "decompress zlib" (maybeDecompress compressedZlib == original) - >> assertBool "decompress gzip" (maybeDecompress compressedGZip == original) - >> assertBool "have no empty chunks" (Prelude.all (not . BS.null) . BSL.toChunks . maybeDecompress $ compressedZlib) - >> (runBrokenStream >>= assertBool "decompress broken stream" . isLeft) - where - original = BSLL.pack "original uncompressed input" - compressedZlib = Zlib.compress original - compressedGZip = GZip.compress original - - runBrokenStream :: IO (Either SomeException ()) - runBrokenStream = try . void . evaluate . BSLL.length $ maybeDecompress (BSLL.init compressedZlib <> BSLL.pack "*") - -prop_maybeDecompress_zlib :: [Word8] -> Property -prop_maybeDecompress_zlib ws = property $ maybeDecompress compressedZlib === original - where original = BSL.pack ws - compressedZlib = Zlib.compress original - -prop_maybeDecompress_gzip :: [Word8] -> Property -prop_maybeDecompress_gzip ws = property $ maybeDecompress compressedGZip === original - where original = BSL.pack ws - compressedGZip = GZip.compress original - --- (Only available from "Data.Either" since 7.8.) -isLeft :: Either a b -> Bool -isLeft (Right _) = False -isLeft (Left _) = True diff --git a/tests/UnitTests/Distribution/Client/Glob.hs b/tests/UnitTests/Distribution/Client/Glob.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/Glob.hs +++ /dev/null @@ -1,203 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module UnitTests.Distribution.Client.Glob (tests) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif -import Data.Char -import Data.List -import Distribution.Text (display, parse, simpleParse) -import Distribution.Compat.ReadP - -import Distribution.Client.Glob -import UnitTests.Distribution.Client.ArbitraryInstances - -import Test.Tasty -import Test.Tasty.QuickCheck -import Test.Tasty.HUnit -import Control.Exception - - -tests :: [TestTree] -tests = - [ testProperty "print/parse roundtrip" prop_roundtrip_printparse - , testCase "parse examples" testParseCases - ] - ---TODO: [nice to have] tests for trivial globs, tests for matching, --- tests for windows style file paths - -prop_roundtrip_printparse :: FilePathGlob -> Bool -prop_roundtrip_printparse pathglob = - -- can't use simpleParse because it mis-handles trailing spaces - case [ x | (x, []) <- readP_to_S parse (display pathglob) ] of - xs@(_:_) -> last xs == pathglob - _ -> False - --- first run, where we don't even call updateMonitor -testParseCases :: Assertion -testParseCases = do - - FilePathGlob (FilePathRoot "/") GlobDirTrailing <- testparse "/" - FilePathGlob FilePathHomeDir GlobDirTrailing <- testparse "~/" - - FilePathGlob (FilePathRoot "A:\\") GlobDirTrailing <- testparse "A:/" - FilePathGlob (FilePathRoot "Z:\\") GlobDirTrailing <- testparse "z:/" - FilePathGlob (FilePathRoot "C:\\") GlobDirTrailing <- testparse "C:\\" - FilePathGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:" - - FilePathGlob FilePathRelative - (GlobFile [Literal "."]) <- testparse "." - - FilePathGlob FilePathRelative - (GlobFile [Literal "~"]) <- testparse "~" - - FilePathGlob FilePathRelative - (GlobDir [Literal "."] GlobDirTrailing) <- testparse "./" - - FilePathGlob FilePathRelative - (GlobFile [Literal "foo"]) <- testparse "foo" - - FilePathGlob FilePathRelative - (GlobDir [Literal "foo"] - (GlobFile [Literal "bar"])) <- testparse "foo/bar" - - FilePathGlob FilePathRelative - (GlobDir [Literal "foo"] - (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "foo/bar/" - - FilePathGlob (FilePathRoot "/") - (GlobDir [Literal "foo"] - (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "/foo/bar/" - - FilePathGlob FilePathRelative - (GlobFile [WildCard]) <- testparse "*" - - FilePathGlob FilePathRelative - (GlobFile [WildCard,WildCard]) <- testparse "**" -- not helpful but valid - - FilePathGlob FilePathRelative - (GlobFile [WildCard, Literal "foo", WildCard]) <- testparse "*foo*" - - FilePathGlob FilePathRelative - (GlobFile [Literal "foo", WildCard, Literal "bar"]) <- testparse "foo*bar" - - FilePathGlob FilePathRelative - (GlobFile [Union [[WildCard], [Literal "foo"]]]) <- testparse "{*,foo}" - - parseFail "{" - parseFail "}" - parseFail "," - parseFail "{" - parseFail "{{}" - parseFail "{}" - parseFail "{,}" - parseFail "{foo,}" - parseFail "{,foo}" - - return () - -testparse :: String -> IO FilePathGlob -testparse s = - case simpleParse s of - Just p -> return p - Nothing -> throwIO $ HUnitFailure Nothing ("expected parse of: " ++ s) - -parseFail :: String -> Assertion -parseFail s = - case simpleParse s :: Maybe FilePathGlob of - Just _ -> throwIO $ HUnitFailure Nothing ("expected no parse of: " ++ s) - Nothing -> return () - -instance Arbitrary FilePathGlob where - arbitrary = (FilePathGlob <$> arbitrary <*> arbitrary) - `suchThat` validFilePathGlob - - shrink (FilePathGlob root pathglob) = - [ FilePathGlob root' pathglob' - | (root', pathglob') <- shrink (root, pathglob) - , validFilePathGlob (FilePathGlob root' pathglob') ] - -validFilePathGlob :: FilePathGlob -> Bool -validFilePathGlob (FilePathGlob FilePathRelative pathglob) = - case pathglob of - GlobDirTrailing -> False - GlobDir [Literal "~"] _ -> False - GlobDir [Literal (d:":")] _ - | isLetter d -> False - _ -> True -validFilePathGlob _ = True - -instance Arbitrary FilePathRoot where - arbitrary = - frequency - [ (3, pure FilePathRelative) - , (1, pure (FilePathRoot unixroot)) - , (1, FilePathRoot <$> windrive) - , (1, pure FilePathHomeDir) - ] - where - unixroot = "/" - windrive = do d <- choose ('A', 'Z'); return (d : ":\\") - - shrink FilePathRelative = [] - shrink (FilePathRoot _) = [FilePathRelative] - shrink FilePathHomeDir = [FilePathRelative] - - -instance Arbitrary FilePathGlobRel where - arbitrary = sized $ \sz -> - oneof $ take (max 1 sz) - [ pure GlobDirTrailing - , GlobFile <$> (getGlobPieces <$> arbitrary) - , GlobDir <$> (getGlobPieces <$> arbitrary) - <*> resize (sz `div` 2) arbitrary - ] - - shrink GlobDirTrailing = [] - shrink (GlobFile glob) = - GlobDirTrailing - : [ GlobFile (getGlobPieces glob') | glob' <- shrink (GlobPieces glob) ] - shrink (GlobDir glob pathglob) = - pathglob - : GlobFile glob - : [ GlobDir (getGlobPieces glob') pathglob' - | (glob', pathglob') <- shrink (GlobPieces glob, pathglob) ] - -newtype GlobPieces = GlobPieces { getGlobPieces :: [GlobPiece] } - deriving Eq - -instance Arbitrary GlobPieces where - arbitrary = GlobPieces . mergeLiterals <$> shortListOf1 5 arbitrary - - shrink (GlobPieces glob) = - [ GlobPieces (mergeLiterals (getNonEmpty glob')) - | glob' <- shrink (NonEmpty glob) ] - -mergeLiterals :: [GlobPiece] -> [GlobPiece] -mergeLiterals (Literal a : Literal b : ps) = mergeLiterals (Literal (a++b) : ps) -mergeLiterals (Union as : ps) = Union (map mergeLiterals as) : mergeLiterals ps -mergeLiterals (p:ps) = p : mergeLiterals ps -mergeLiterals [] = [] - -instance Arbitrary GlobPiece where - arbitrary = sized $ \sz -> - frequency - [ (3, Literal <$> shortListOf1 10 (elements globLiteralChars)) - , (1, pure WildCard) - , (1, Union <$> resize (sz `div` 2) (shortListOf1 5 (shortListOf1 5 arbitrary))) - ] - - shrink (Literal str) = [ Literal str' - | str' <- shrink str - , not (null str') - , all (`elem` globLiteralChars) str' ] - shrink WildCard = [] - shrink (Union as) = [ Union (map getGlobPieces (getNonEmpty as')) - | as' <- shrink (NonEmpty (map GlobPieces as)) ] - -globLiteralChars :: [Char] -globLiteralChars = ['\0'..'\128'] \\ "*{},/\\" - diff --git a/tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs b/tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs +++ /dev/null @@ -1,60 +0,0 @@ -module UnitTests.Distribution.Client.IndexUtils.Timestamp (tests) where - -import Distribution.Text -import Data.Time -import Data.Time.Clock.POSIX - -import Distribution.Client.IndexUtils.Timestamp - -import Test.Tasty -import Test.Tasty.QuickCheck - -tests :: [TestTree] -tests = - [ testProperty "Timestamp1" prop_timestamp1 - , testProperty "Timestamp2" prop_timestamp2 - , testProperty "Timestamp3" prop_timestamp3 - , testProperty "Timestamp4" prop_timestamp4 - , testProperty "Timestamp5" prop_timestamp5 - ] - --- test unixtime format parsing -prop_timestamp1 :: Int -> Bool -prop_timestamp1 t0 = Just t == simpleParse ('@':show t0) - where - t = toEnum t0 :: Timestamp - --- test display/simpleParse roundtrip -prop_timestamp2 :: Int -> Bool -prop_timestamp2 t0 - | t /= nullTimestamp = simpleParse (display t) == Just t - | otherwise = display t == "" - where - t = toEnum t0 :: Timestamp - --- test display against reference impl -prop_timestamp3 :: Int -> Bool -prop_timestamp3 t0 - | t /= nullTimestamp = refDisp t == display t - | otherwise = display t == "" - where - t = toEnum t0 :: Timestamp - - refDisp = maybe undefined (formatTime undefined "%FT%TZ") - . timestampToUTCTime - --- test utcTimeToTimestamp/timestampToUTCTime roundtrip -prop_timestamp4 :: Int -> Bool -prop_timestamp4 t0 - | t /= nullTimestamp = (utcTimeToTimestamp =<< timestampToUTCTime t) == Just t - | otherwise = timestampToUTCTime t == Nothing - where - t = toEnum t0 :: Timestamp - -prop_timestamp5 :: Int -> Bool -prop_timestamp5 t0 - | t /= nullTimestamp = timestampToUTCTime t == Just ut - | otherwise = timestampToUTCTime t == Nothing - where - t = toEnum t0 :: Timestamp - ut = posixSecondsToUTCTime (fromIntegral t0) diff --git a/tests/UnitTests/Distribution/Client/InstallPlan.hs b/tests/UnitTests/Distribution/Client/InstallPlan.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/InstallPlan.hs +++ /dev/null @@ -1,312 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoMonoLocalBinds #-} -{-# LANGUAGE ConstraintKinds #-} -module UnitTests.Distribution.Client.InstallPlan (tests) where - -import Distribution.Package -import Distribution.Version -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit) -import qualified Distribution.Compat.Graph as Graph -import Distribution.Compat.Graph (IsNode(..)) -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.PackageFixedDeps -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Client.Types -import Distribution.Client.JobControl - -import Data.Graph -import Data.Array hiding (index) -import Data.List -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Set (Set) -import Data.IORef -import Control.Monad -import Control.Concurrent (threadDelay) -import System.Random -import Test.QuickCheck - -import Test.Tasty -import Test.Tasty.QuickCheck - - -tests :: [TestTree] -tests = - [ testProperty "reverseTopologicalOrder" prop_reverseTopologicalOrder - , testProperty "executionOrder" prop_executionOrder - , testProperty "execute serial" prop_execute_serial - , testProperty "execute parallel" prop_execute_parallel - , testProperty "execute/executionOrder" prop_execute_vs_executionOrder - ] - -prop_reverseTopologicalOrder :: TestInstallPlan -> Bool -prop_reverseTopologicalOrder (TestInstallPlan plan graph toVertex _) = - isReverseTopologicalOrder - graph - (map (toVertex . installedUnitId) - (InstallPlan.reverseTopologicalOrder plan)) - --- | @executionOrder@ is in reverse topological order -prop_executionOrder :: TestInstallPlan -> Bool -prop_executionOrder (TestInstallPlan plan graph toVertex _) = - isReversePartialTopologicalOrder graph (map toVertex pkgids) - && allConfiguredPackages plan == Set.fromList pkgids - where - pkgids = map installedUnitId (InstallPlan.executionOrder plan) - --- | @execute@ is in reverse topological order -prop_execute_serial :: TestInstallPlan -> Property -prop_execute_serial tplan@(TestInstallPlan plan graph toVertex _) = - ioProperty $ do - jobCtl <- newSerialJobControl - pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ()) - return $ isReversePartialTopologicalOrder graph (map toVertex pkgids) - && allConfiguredPackages plan == Set.fromList pkgids - -prop_execute_parallel :: Positive (Small Int) -> TestInstallPlan -> Property -prop_execute_parallel (Positive (Small maxJobLimit)) - tplan@(TestInstallPlan plan graph toVertex _) = - ioProperty $ do - jobCtl <- newParallelJobControl maxJobLimit - pkgids <- executeTestInstallPlan jobCtl tplan $ \_ -> do - delay <- randomRIO (0,1000) - threadDelay delay - return $ isReversePartialTopologicalOrder graph (map toVertex pkgids) - && allConfiguredPackages plan == Set.fromList pkgids - --- | return the packages that are visited by execute, in order. -executeTestInstallPlan :: JobControl IO (UnitId, Either () ()) - -> TestInstallPlan - -> (TestPkg -> IO ()) - -> IO [UnitId] -executeTestInstallPlan jobCtl (TestInstallPlan plan _ _ _) visit = do - resultsRef <- newIORef [] - _ <- InstallPlan.execute jobCtl False (const ()) - plan $ \(ReadyPackage pkg) -> do - visit pkg - atomicModifyIORef resultsRef $ \pkgs -> (installedUnitId pkg:pkgs, ()) - return (Right ()) - fmap reverse (readIORef resultsRef) - --- | @execute@ visits the packages in the same order as @executionOrder@ -prop_execute_vs_executionOrder :: TestInstallPlan -> Property -prop_execute_vs_executionOrder tplan@(TestInstallPlan plan _ _ _) = - ioProperty $ do - jobCtl <- newSerialJobControl - pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ()) - let pkgids' = map installedUnitId (InstallPlan.executionOrder plan) - return (pkgids == pkgids') - - --------------------------- --- Property helper utils --- - --- | A graph topological ordering is a linear ordering of its vertices such --- that for every directed edge uv from vertex u to vertex v, u comes before v --- in the ordering. --- --- A reverse topological ordering is the swapped: for every directed edge uv --- from vertex u to vertex v, v comes before u in the ordering. --- -isReverseTopologicalOrder :: Graph -> [Vertex] -> Bool -isReverseTopologicalOrder g vs = - and [ ixs ! u > ixs ! v - | let ixs = array (bounds g) (zip vs [0::Int ..]) - , (u,v) <- edges g ] - -isReversePartialTopologicalOrder :: Graph -> [Vertex] -> Bool -isReversePartialTopologicalOrder g vs = - and [ case (ixs ! u, ixs ! v) of - (Just ixu, Just ixv) -> ixu > ixv - _ -> True - | let ixs = array (bounds g) - (zip (range (bounds g)) (repeat Nothing) ++ - zip vs (map Just [0::Int ..])) - , (u,v) <- edges g ] - -allConfiguredPackages :: HasUnitId srcpkg - => GenericInstallPlan ipkg srcpkg -> Set UnitId -allConfiguredPackages plan = - Set.fromList - [ installedUnitId pkg - | InstallPlan.Configured pkg <- InstallPlan.toList plan ] - - --------------------- --- Test generators --- - -data TestInstallPlan = TestInstallPlan - (GenericInstallPlan TestPkg TestPkg) - Graph - (UnitId -> Vertex) - (Vertex -> UnitId) - -instance Show TestInstallPlan where - show (TestInstallPlan plan _ _ _) = InstallPlan.showInstallPlan plan - -data TestPkg = TestPkg PackageId UnitId [UnitId] - deriving (Eq, Show) - -instance IsNode TestPkg where - type Key TestPkg = UnitId - nodeKey (TestPkg _ ipkgid _) = ipkgid - nodeNeighbors (TestPkg _ _ deps) = deps - - -instance Package TestPkg where - packageId (TestPkg pkgid _ _) = pkgid - -instance HasUnitId TestPkg where - installedUnitId (TestPkg _ ipkgid _) = ipkgid - -instance PackageFixedDeps TestPkg where - depends (TestPkg _ _ deps) = CD.singleton CD.ComponentLib deps - -instance PackageInstalled TestPkg where - installedDepends (TestPkg _ _ deps) = deps - -instance Arbitrary TestInstallPlan where - arbitrary = arbitraryTestInstallPlan - -arbitraryTestInstallPlan :: Gen TestInstallPlan -arbitraryTestInstallPlan = do - graph <- arbitraryAcyclicGraph - (choose (2,5)) - (choose (1,5)) - 0.3 - - plan <- arbitraryInstallPlan mkTestPkg mkTestPkg 0.5 graph - - let toVertexMap = Map.fromList [ (mkUnitIdV v, v) | v <- vertices graph ] - fromVertexMap = Map.fromList [ (v, mkUnitIdV v) | v <- vertices graph ] - toVertex = (toVertexMap Map.!) - fromVertex = (fromVertexMap Map.!) - - return (TestInstallPlan plan graph toVertex fromVertex) - where - mkTestPkg pkgv depvs = - return (TestPkg pkgid ipkgid deps) - where - pkgid = mkPkgId pkgv - ipkgid = mkUnitIdV pkgv - deps = map mkUnitIdV depvs - mkUnitIdV = mkUnitId . show - mkPkgId v = PackageIdentifier (mkPackageName ("pkg" ++ show v)) - (mkVersion [1]) - - --- | Generate a random 'InstallPlan' following the structure of an existing --- 'Graph'. --- --- It takes generators for installed and source packages and the chance that --- each package is installed (for those packages with no prerequisites). --- -arbitraryInstallPlan :: (IsUnit ipkg, - IsUnit srcpkg) - => (Vertex -> [Vertex] -> Gen ipkg) - -> (Vertex -> [Vertex] -> Gen srcpkg) - -> Float - -> Graph - -> Gen (InstallPlan.GenericInstallPlan ipkg srcpkg) -arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do - - (ipkgvs, srcpkgvs) <- - fmap ((\(ipkgs, srcpkgs) -> (map fst ipkgs, map fst srcpkgs)) - . partition snd) $ - sequence - [ do isipkg <- if isRoot then pick ipkgProportion - else return False - return (v, isipkg) - | (v,n) <- assocs (outdegree graph) - , let isRoot = n == 0 ] - - ipkgs <- sequence - [ mkIPkg pkgv depvs - | pkgv <- ipkgvs - , let depvs = graph ! pkgv - ] - srcpkgs <- sequence - [ mkSrcPkg pkgv depvs - | pkgv <- srcpkgvs - , let depvs = graph ! pkgv - ] - let index = Graph.fromDistinctList - (map InstallPlan.PreExisting ipkgs - ++ map InstallPlan.Configured srcpkgs) - return $ InstallPlan.new (IndependentGoals False) index - - --- | Generate a random directed acyclic graph, based on the algorithm presented --- here --- --- It generates a DAG based on ranks of nodes. Nodes in each rank can only --- have edges to nodes in subsequent ranks. --- --- The generator is paramterised by a generator for the number of ranks and --- the number of nodes within each rank. It is also paramterised by the --- chance that each node in each rank will have an edge from each node in --- each previous rank. Thus a higher chance will produce a more densely --- connected graph. --- -arbitraryAcyclicGraph :: Gen Int -> Gen Int -> Float -> Gen Graph -arbitraryAcyclicGraph genNRanks genNPerRank edgeChance = do - nranks <- genNRanks - rankSizes <- replicateM nranks genNPerRank - let rankStarts = scanl (+) 0 rankSizes - rankRanges = drop 1 (zip rankStarts (tail rankStarts)) - totalRange = sum rankSizes - rankEdges <- mapM (uncurry genRank) rankRanges - return $ buildG (0, totalRange-1) (concat rankEdges) - where - genRank :: Vertex -> Vertex -> Gen [Edge] - genRank rankStart rankEnd = - filterM (const (pick edgeChance)) - [ (i,j) - | i <- [0..rankStart-1] - , j <- [rankStart..rankEnd-1] - ] - -pick :: Float -> Gen Bool -pick chance = do - p <- choose (0,1) - return (p < chance) - - --------------------------------- --- Inspecting generated graphs --- - -{- --- Handy util for checking the generated graphs look sensible -writeDotFile :: FilePath -> Graph -> IO () -writeDotFile file = writeFile file . renderDotGraph - -renderDotGraph :: Graph -> String -renderDotGraph graph = - unlines ( - [header - ,graphDefaultAtribs - ,nodeDefaultAtribs - ,edgeDefaultAtribs] - ++ map renderNode (vertices graph) - ++ map renderEdge (edges graph) - ++ [footer] - ) - where - renderNode n = "\t" ++ show n ++ " [label=\"" ++ show n ++ "\"];" - - renderEdge (n, n') = "\t" ++ show n ++ " -> " ++ show n' ++ "[];" - - -header, footer, graphDefaultAtribs, nodeDefaultAtribs, edgeDefaultAtribs :: String - -header = "digraph packages {" -footer = "}" - -graphDefaultAtribs = "\tgraph [fontsize=14, fontcolor=black, color=black];" -nodeDefaultAtribs = "\tnode [label=\"\\N\", width=\"0.75\", shape=ellipse];" -edgeDefaultAtribs = "\tedge [fontsize=10];" --} diff --git a/tests/UnitTests/Distribution/Client/JobControl.hs b/tests/UnitTests/Distribution/Client/JobControl.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/JobControl.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -module UnitTests.Distribution.Client.JobControl (tests) where - -import Distribution.Client.JobControl - -import Data.List -import Data.Maybe -import Data.IORef -import Control.Monad -import Control.Concurrent (threadDelay) -import Control.Exception (Exception, try, throwIO) -import Data.Typeable (Typeable) -import qualified Data.Set as Set - -import Test.Tasty -import Test.Tasty.QuickCheck hiding (collect) - - -tests :: [TestTree] -tests = - [ testGroup "serial" - [ testProperty "submit batch" prop_submit_serial - , testProperty "submit batch" prop_remaining_serial - , testProperty "submit interleaved" prop_interleaved_serial - , testProperty "concurrent jobs" prop_concurrent_serial - , testProperty "cancel" prop_cancel_serial - , testProperty "exceptions" prop_exception_serial - ] - , testGroup "parallel" - [ testProperty "submit batch" prop_submit_parallel - , testProperty "submit batch" prop_remaining_parallel - , testProperty "submit interleaved" prop_interleaved_parallel - , testProperty "concurrent jobs" prop_concurrent_parallel - , testProperty "cancel" prop_cancel_parallel - , testProperty "exceptions" prop_exception_parallel - ] - ] - - -prop_submit_serial :: [Int] -> Property -prop_submit_serial xs = - ioProperty $ do - jobCtl <- newSerialJobControl - prop_submit jobCtl xs - -prop_submit_parallel :: Positive (Small Int) -> [Int] -> Property -prop_submit_parallel (Positive (Small maxJobLimit)) xs = - ioProperty $ do - jobCtl <- newParallelJobControl maxJobLimit - prop_submit jobCtl xs - -prop_remaining_serial :: [Int] -> Property -prop_remaining_serial xs = - ioProperty $ do - jobCtl <- newSerialJobControl - prop_remaining jobCtl xs - -prop_remaining_parallel :: Positive (Small Int) -> [Int] -> Property -prop_remaining_parallel (Positive (Small maxJobLimit)) xs = - ioProperty $ do - jobCtl <- newParallelJobControl maxJobLimit - prop_remaining jobCtl xs - -prop_interleaved_serial :: [Int] -> Property -prop_interleaved_serial xs = - ioProperty $ do - jobCtl <- newSerialJobControl - prop_submit_interleaved jobCtl xs - -prop_interleaved_parallel :: Positive (Small Int) -> [Int] -> Property -prop_interleaved_parallel (Positive (Small maxJobLimit)) xs = - ioProperty $ do - jobCtl <- newParallelJobControl maxJobLimit - prop_submit_interleaved jobCtl xs - -prop_submit :: JobControl IO Int -> [Int] -> IO Bool -prop_submit jobCtl xs = do - mapM_ (\x -> spawnJob jobCtl (return x)) xs - xs' <- mapM (\_ -> collectJob jobCtl) xs - return (sort xs == sort xs') - -prop_remaining :: JobControl IO Int -> [Int] -> IO Bool -prop_remaining jobCtl xs = do - mapM_ (\x -> spawnJob jobCtl (return x)) xs - xs' <- collectRemainingJobs jobCtl - return (sort xs == sort xs') - -collectRemainingJobs :: Monad m => JobControl m a -> m [a] -collectRemainingJobs jobCtl = go [] - where - go xs = do - remaining <- remainingJobs jobCtl - if remaining - then do x <- collectJob jobCtl - go (x:xs) - else return xs - -prop_submit_interleaved :: JobControl IO (Maybe Int) -> [Int] -> IO Bool -prop_submit_interleaved jobCtl xs = do - xs' <- sequence - [ spawn >> collect - | let spawns = map (\x -> spawnJob jobCtl (return (Just x))) xs - ++ repeat (return ()) - collects = replicate 5 (return Nothing) - ++ map (\_ -> collectJob jobCtl) xs - , (spawn, collect) <- zip spawns collects - ] - return (sort xs == sort (catMaybes xs')) - -prop_concurrent_serial :: NonNegative (Small Int) -> Property -prop_concurrent_serial (NonNegative (Small ntasks)) = - ioProperty $ do - jobCtl <- newSerialJobControl - countRef <- newIORef (0 :: Int) - replicateM_ ntasks (spawnJob jobCtl (task countRef)) - counts <- replicateM ntasks (collectJob jobCtl) - return $ length counts == ntasks - && all (\(n0, n1) -> n0 == 0 && n1 == 1) counts - where - task countRef = do - n0 <- atomicModifyIORef countRef (\n -> (n+1, n)) - threadDelay 100 - n1 <- atomicModifyIORef countRef (\n -> (n-1, n)) - return (n0, n1) - -prop_concurrent_parallel :: Positive (Small Int) -> NonNegative Int -> Property -prop_concurrent_parallel (Positive (Small maxJobLimit)) (NonNegative ntasks) = - ioProperty $ do - jobCtl <- newParallelJobControl maxJobLimit - countRef <- newIORef (0 :: Int) - replicateM_ ntasks (spawnJob jobCtl (task countRef)) - counts <- replicateM ntasks (collectJob jobCtl) - return $ length counts == ntasks - && all (\(n0, n1) -> n0 >= 0 && n0 < maxJobLimit - && n1 > 0 && n1 <= maxJobLimit) counts - -- we do hit the concurrency limit (in the right circumstances) - && if ntasks >= maxJobLimit*2 -- give us enough of a margin - then any (\(_,n1) -> n1 == maxJobLimit) counts - else True - where - task countRef = do - n0 <- atomicModifyIORef countRef (\n -> (n+1, n)) - threadDelay 100 - n1 <- atomicModifyIORef countRef (\n -> (n-1, n)) - return (n0, n1) - -prop_cancel_serial :: [Int] -> [Int] -> Property -prop_cancel_serial xs ys = - ioProperty $ do - jobCtl <- newSerialJobControl - mapM_ (\x -> spawnJob jobCtl (return x)) (xs++ys) - xs' <- mapM (\_ -> collectJob jobCtl) xs - cancelJobs jobCtl - ys' <- collectRemainingJobs jobCtl - return (sort xs == sort xs' && null ys') - -prop_cancel_parallel :: Positive (Small Int) -> [Int] -> [Int] -> Property -prop_cancel_parallel (Positive (Small maxJobLimit)) xs ys = do - ioProperty $ do - jobCtl <- newParallelJobControl maxJobLimit - mapM_ (\x -> spawnJob jobCtl (threadDelay 100 >> return x)) (xs++ys) - xs' <- mapM (\_ -> collectJob jobCtl) xs - cancelJobs jobCtl - ys' <- collectRemainingJobs jobCtl - return $ Set.fromList (xs'++ys') `Set.isSubsetOf` Set.fromList (xs++ys) - -data TestException = TestException Int - deriving (Typeable, Show) - -instance Exception TestException - -prop_exception_serial :: [Either Int Int] -> Property -prop_exception_serial xs = - ioProperty $ do - jobCtl <- newSerialJobControl - prop_exception jobCtl xs - -prop_exception_parallel :: Positive (Small Int) -> [Either Int Int] -> Property -prop_exception_parallel (Positive (Small maxJobLimit)) xs = - ioProperty $ do - jobCtl <- newParallelJobControl maxJobLimit - prop_exception jobCtl xs - -prop_exception :: JobControl IO Int -> [Either Int Int] -> IO Bool -prop_exception jobCtl xs = do - mapM_ (\x -> spawnJob jobCtl (either (throwIO . TestException) return x)) xs - xs' <- replicateM (length xs) $ do - mx <- try (collectJob jobCtl) - return $ case mx of - Left (TestException n) -> Left n - Right n -> Right n - return (sort xs == sort xs') - diff --git a/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/tests/UnitTests/Distribution/Client/ProjectConfig.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/ProjectConfig.hs +++ /dev/null @@ -1,874 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module UnitTests.Distribution.Client.ProjectConfig (tests) where - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -import Control.Applicative -#endif -import Data.Map (Map) -import qualified Data.Map as Map -import Data.List - -import Distribution.Package -import Distribution.PackageDescription hiding (Flag) -import Distribution.Compiler -import Distribution.Version -import Distribution.ParseUtils -import Distribution.Text as Text -import Distribution.Simple.Compiler -import Distribution.Simple.Setup -import Distribution.Simple.InstallDirs -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Simple.Utils -import Distribution.Simple.Program.Types -import Distribution.Simple.Program.Db - -import Distribution.Client.Types -import Distribution.Client.Dependency.Types -import Distribution.Client.BuildReports.Types -import Distribution.Client.Targets -import Distribution.Utils.NubList -import Network.URI - -import Distribution.Solver.Types.PackageConstraint -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.Settings - -import Distribution.Client.ProjectConfig -import Distribution.Client.ProjectConfig.Legacy - -import UnitTests.Distribution.Client.ArbitraryInstances - -import Test.Tasty -import Test.Tasty.QuickCheck - -tests :: [TestTree] -tests = - [ testGroup "ProjectConfig <-> LegacyProjectConfig round trip" $ - [ testProperty "packages" prop_roundtrip_legacytypes_packages - , testProperty "buildonly" prop_roundtrip_legacytypes_buildonly - , testProperty "specific" prop_roundtrip_legacytypes_specific - ] ++ - -- a couple tests seem to trigger a RTS fault in ghc-7.6 and older - -- unclear why as of yet - concat - [ [ testProperty "shared" prop_roundtrip_legacytypes_shared - , testProperty "local" prop_roundtrip_legacytypes_local - , testProperty "all" prop_roundtrip_legacytypes_all - ] - | not usingGhc76orOlder - ] - - , testGroup "individual parser tests" - [ testProperty "package location" prop_parsePackageLocationTokenQ - , testProperty "RelaxedDep" prop_roundtrip_printparse_RelaxedDep - , testProperty "RelaxDeps" prop_roundtrip_printparse_RelaxDeps - , testProperty "RelaxDeps'" prop_roundtrip_printparse_RelaxDeps' - ] - - , testGroup "ProjectConfig printing/parsing round trip" - [ testProperty "packages" prop_roundtrip_printparse_packages - , testProperty "buildonly" prop_roundtrip_printparse_buildonly - , testProperty "shared" prop_roundtrip_printparse_shared - , testProperty "local" prop_roundtrip_printparse_local - , testProperty "specific" prop_roundtrip_printparse_specific - , testProperty "all" prop_roundtrip_printparse_all - ] - ] - where - usingGhc76orOlder = - case buildCompilerId of - CompilerId GHC v -> v < mkVersion [7,7] - _ -> False - - ------------------------------------------------- --- Round trip: conversion to/from legacy types --- - -roundtrip :: Eq a => (a -> b) -> (b -> a) -> a -> Bool -roundtrip f f_inv x = - (f_inv . f) x == x - -roundtrip_legacytypes :: ProjectConfig -> Bool -roundtrip_legacytypes = - roundtrip convertToLegacyProjectConfig - convertLegacyProjectConfig - - -prop_roundtrip_legacytypes_all :: ProjectConfig -> Bool -prop_roundtrip_legacytypes_all config = - roundtrip_legacytypes - config { - projectConfigProvenance = mempty - } - -prop_roundtrip_legacytypes_packages :: ProjectConfig -> Bool -prop_roundtrip_legacytypes_packages config = - roundtrip_legacytypes - config { - projectConfigBuildOnly = mempty, - projectConfigShared = mempty, - projectConfigProvenance = mempty, - projectConfigLocalPackages = mempty, - projectConfigSpecificPackage = mempty - } - -prop_roundtrip_legacytypes_buildonly :: ProjectConfigBuildOnly -> Bool -prop_roundtrip_legacytypes_buildonly config = - roundtrip_legacytypes - mempty { projectConfigBuildOnly = config } - -prop_roundtrip_legacytypes_shared :: ProjectConfigShared -> Bool -prop_roundtrip_legacytypes_shared config = - roundtrip_legacytypes - mempty { projectConfigShared = config } - -prop_roundtrip_legacytypes_local :: PackageConfig -> Bool -prop_roundtrip_legacytypes_local config = - roundtrip_legacytypes - mempty { projectConfigLocalPackages = config } - -prop_roundtrip_legacytypes_specific :: Map PackageName PackageConfig -> Bool -prop_roundtrip_legacytypes_specific config = - roundtrip_legacytypes - mempty { projectConfigSpecificPackage = MapMappend config } - - --------------------------------------------- --- Round trip: printing and parsing config --- - -roundtrip_printparse :: ProjectConfig -> Bool -roundtrip_printparse config = - case (fmap convertLegacyProjectConfig - . parseLegacyProjectConfig - . showLegacyProjectConfig - . convertToLegacyProjectConfig) - config of - ParseOk _ x -> x == config { projectConfigProvenance = mempty } - _ -> False - - -prop_roundtrip_printparse_all :: ProjectConfig -> Bool -prop_roundtrip_printparse_all config = - roundtrip_printparse config { - projectConfigBuildOnly = - hackProjectConfigBuildOnly (projectConfigBuildOnly config), - - projectConfigShared = - hackProjectConfigShared (projectConfigShared config) - } - -prop_roundtrip_printparse_packages :: [PackageLocationString] - -> [PackageLocationString] - -> [SourceRepo] - -> [Dependency] - -> Bool -prop_roundtrip_printparse_packages pkglocstrs1 pkglocstrs2 repos named = - roundtrip_printparse - mempty { - projectPackages = map getPackageLocationString pkglocstrs1, - projectPackagesOptional = map getPackageLocationString pkglocstrs2, - projectPackagesRepo = repos, - projectPackagesNamed = named - } - -prop_roundtrip_printparse_buildonly :: ProjectConfigBuildOnly -> Bool -prop_roundtrip_printparse_buildonly config = - roundtrip_printparse - mempty { - projectConfigBuildOnly = hackProjectConfigBuildOnly config - } - -hackProjectConfigBuildOnly :: ProjectConfigBuildOnly -> ProjectConfigBuildOnly -hackProjectConfigBuildOnly config = - config { - -- These two fields are only command line transitory things, not - -- something to be recorded persistently in a config file - projectConfigOnlyDeps = mempty, - projectConfigDryRun = mempty - } - -prop_roundtrip_printparse_shared :: ProjectConfigShared -> Bool -prop_roundtrip_printparse_shared config = - roundtrip_printparse - mempty { - projectConfigShared = hackProjectConfigShared config - } - -hackProjectConfigShared :: ProjectConfigShared -> ProjectConfigShared -hackProjectConfigShared config = - config { - projectConfigProjectFile = mempty, -- not present within project files - projectConfigConfigFile = mempty, -- ditto - projectConfigConstraints = - --TODO: [required eventually] parse ambiguity in constraint - -- "pkgname -any" as either any version or disabled flag "any". - let ambiguous (UserConstraint _ (PackagePropertyFlags flags), _) = - (not . null) [ () | (name, False) <- unFlagAssignment flags - , "any" `isPrefixOf` unFlagName name ] - ambiguous _ = False - in filter (not . ambiguous) (projectConfigConstraints config) - } - - -prop_roundtrip_printparse_local :: PackageConfig -> Bool -prop_roundtrip_printparse_local config = - roundtrip_printparse - mempty { - projectConfigLocalPackages = config - } - -prop_roundtrip_printparse_specific :: Map PackageName (NonMEmpty PackageConfig) - -> Bool -prop_roundtrip_printparse_specific config = - roundtrip_printparse - mempty { - projectConfigSpecificPackage = MapMappend (fmap getNonMEmpty config) - } - - ----------------------------- --- Individual Parser tests --- - --- | Helper to parse a given string --- --- Succeeds only if there is a unique complete parse -runReadP :: Parse.ReadP a a -> String -> Maybe a -runReadP parser s = case [ x | (x,"") <- Parse.readP_to_S parser s ] of - [x'] -> Just x' - _ -> Nothing - -prop_parsePackageLocationTokenQ :: PackageLocationString -> Bool -prop_parsePackageLocationTokenQ (PackageLocationString str) = - runReadP parsePackageLocationTokenQ (renderPackageLocationToken str) == Just str - -prop_roundtrip_printparse_RelaxedDep :: RelaxedDep -> Bool -prop_roundtrip_printparse_RelaxedDep rdep = - runReadP Text.parse (Text.display rdep) == Just rdep - -prop_roundtrip_printparse_RelaxDeps :: RelaxDeps -> Bool -prop_roundtrip_printparse_RelaxDeps rdep = - runReadP Text.parse (Text.display rdep) == Just rdep - -prop_roundtrip_printparse_RelaxDeps' :: RelaxDeps -> Bool -prop_roundtrip_printparse_RelaxDeps' rdep = - runReadP Text.parse (go $ Text.display rdep) == Just rdep - where - -- replace 'all' tokens by '*' - go :: String -> String - go [] = [] - go "all" = "*" - go ('a':'l':'l':c:rest) | c `elem` ":," = '*' : go (c:rest) - go rest = let (x,y) = break (`elem` ":,") rest - (x',y') = span (`elem` ":,^") y - in x++x'++go y' - ------------------------- --- Arbitrary instances --- - -instance Arbitrary ProjectConfig where - arbitrary = - ProjectConfig - <$> (map getPackageLocationString <$> arbitrary) - <*> (map getPackageLocationString <$> arbitrary) - <*> shortListOf 3 arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> (MapMappend . fmap getNonMEmpty . Map.fromList - <$> shortListOf 3 arbitrary) - -- package entries with no content are equivalent to - -- the entry not existing at all, so exclude empty - - shrink ProjectConfig { projectPackages = x0 - , projectPackagesOptional = x1 - , projectPackagesRepo = x2 - , projectPackagesNamed = x3 - , projectConfigBuildOnly = x4 - , projectConfigShared = x5 - , projectConfigProvenance = x6 - , projectConfigLocalPackages = x7 - , projectConfigSpecificPackage = x8 - , projectConfigAllPackages = x9 } = - [ ProjectConfig { projectPackages = x0' - , projectPackagesOptional = x1' - , projectPackagesRepo = x2' - , projectPackagesNamed = x3' - , projectConfigBuildOnly = x4' - , projectConfigShared = x5' - , projectConfigProvenance = x6' - , projectConfigLocalPackages = x7' - , projectConfigSpecificPackage = (MapMappend - (fmap getNonMEmpty x8')) - , projectConfigAllPackages = x9' } - | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8', x9')) - <- shrink ((x0, x1, x2, x3), - (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8), x9)) - ] - -newtype PackageLocationString - = PackageLocationString { getPackageLocationString :: String } - deriving Show - -instance Arbitrary PackageLocationString where - arbitrary = - PackageLocationString <$> - oneof - [ show . getNonEmpty <$> (arbitrary :: Gen (NonEmptyList String)) - , arbitraryGlobLikeStr - , show <$> (arbitrary :: Gen URI) - ] - -arbitraryGlobLikeStr :: Gen String -arbitraryGlobLikeStr = outerTerm - where - outerTerm = concat <$> shortListOf1 4 - (frequency [ (2, token) - , (1, braces <$> innerTerm) ]) - innerTerm = intercalate "," <$> shortListOf1 3 - (frequency [ (3, token) - , (1, braces <$> innerTerm) ]) - token = shortListOf1 4 (elements (['#'..'~'] \\ "{,}")) - braces s = "{" ++ s ++ "}" - - -instance Arbitrary ProjectConfigBuildOnly where - arbitrary = - ProjectConfigBuildOnly - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> (toNubList <$> shortListOf 2 arbitrary) -- 4 - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> (fmap getShortToken <$> arbitrary) -- 8 - <*> arbitrary - <*> arbitraryNumJobs - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> (fmap getShortToken <$> arbitrary) - <*> arbitrary - <*> (fmap getShortToken <$> arbitrary) - <*> (fmap getShortToken <$> arbitrary) - <*> (fmap getShortToken <$> arbitrary) - where - arbitraryNumJobs = fmap (fmap getPositive) <$> arbitrary - - shrink ProjectConfigBuildOnly { projectConfigVerbosity = x00 - , projectConfigDryRun = x01 - , projectConfigOnlyDeps = x02 - , projectConfigSummaryFile = x03 - , projectConfigLogFile = x04 - , projectConfigBuildReports = x05 - , projectConfigReportPlanningFailure = x06 - , projectConfigSymlinkBinDir = x07 - , projectConfigOneShot = x08 - , projectConfigNumJobs = x09 - , projectConfigKeepGoing = x10 - , projectConfigOfflineMode = x11 - , projectConfigKeepTempFiles = x12 - , projectConfigHttpTransport = x13 - , projectConfigIgnoreExpiry = x14 - , projectConfigCacheDir = x15 - , projectConfigLogsDir = x16 - , projectConfigStoreDir = x17 } = - [ ProjectConfigBuildOnly { projectConfigVerbosity = x00' - , projectConfigDryRun = x01' - , projectConfigOnlyDeps = x02' - , projectConfigSummaryFile = x03' - , projectConfigLogFile = x04' - , projectConfigBuildReports = x05' - , projectConfigReportPlanningFailure = x06' - , projectConfigSymlinkBinDir = x07' - , projectConfigOneShot = x08' - , projectConfigNumJobs = postShrink_NumJobs x09' - , projectConfigKeepGoing = x10' - , projectConfigOfflineMode = x11' - , projectConfigKeepTempFiles = x12' - , projectConfigHttpTransport = x13 - , projectConfigIgnoreExpiry = x14' - , projectConfigCacheDir = x15 - , projectConfigLogsDir = x16 - , projectConfigStoreDir = x17} - | ((x00', x01', x02', x03', x04'), - (x05', x06', x07', x08', x09'), - (x10', x11', x12', x14')) - <- shrink - ((x00, x01, x02, x03, x04), - (x05, x06, x07, x08, preShrink_NumJobs x09), - (x10, x11, x12, x14)) - ] - where - preShrink_NumJobs = fmap (fmap Positive) - postShrink_NumJobs = fmap (fmap getPositive) - -instance Arbitrary ProjectConfigShared where - arbitrary = - ProjectConfigShared - <$> arbitraryFlag arbitraryShortToken - <*> arbitraryFlag arbitraryShortToken - <*> arbitraryFlag arbitraryShortToken - <*> arbitrary - <*> arbitraryFlag arbitraryShortToken - <*> arbitraryFlag arbitraryShortToken - <*> arbitrary - <*> arbitrary - <*> (toNubList <$> listOf arbitraryShortToken) - <*> arbitrary - <*> arbitraryConstraints - <*> shortListOf 2 arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> (toNubList <$> listOf arbitraryShortToken) - where - arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)] - arbitraryConstraints = - fmap (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary - - shrink ProjectConfigShared { projectConfigDistDir = x00 - , projectConfigProjectFile = x01 - , projectConfigHcFlavor = x02 - , projectConfigHcPath = x03 - , projectConfigHcPkg = x04 - , projectConfigHaddockIndex = x05 - , projectConfigRemoteRepos = x06 - , projectConfigLocalRepos = x07 - , projectConfigIndexState = x08 - , projectConfigConstraints = x09 - , projectConfigPreferences = x10 - , projectConfigCabalVersion = x11 - , projectConfigSolver = x12 - , projectConfigAllowOlder = x13 - , projectConfigAllowNewer = x14 - , projectConfigMaxBackjumps = x15 - , projectConfigReorderGoals = x16 - , projectConfigCountConflicts = x17 - , projectConfigStrongFlags = x18 - , projectConfigAllowBootLibInstalls = x19 - , projectConfigPerComponent = x20 - , projectConfigIndependentGoals = x21 - , projectConfigConfigFile = x22 - , projectConfigProgPathExtra = x23} = - [ ProjectConfigShared { projectConfigDistDir = x00' - , projectConfigProjectFile = x01' - , projectConfigHcFlavor = x02' - , projectConfigHcPath = fmap getNonEmpty x03' - , projectConfigHcPkg = fmap getNonEmpty x04' - , projectConfigHaddockIndex = x05' - , projectConfigRemoteRepos = x06' - , projectConfigLocalRepos = x07' - , projectConfigIndexState = x08' - , projectConfigConstraints = postShrink_Constraints x09' - , projectConfigPreferences = x10' - , projectConfigCabalVersion = x11' - , projectConfigSolver = x12' - , projectConfigAllowOlder = x13' - , projectConfigAllowNewer = x14' - , projectConfigMaxBackjumps = x15' - , projectConfigReorderGoals = x16' - , projectConfigCountConflicts = x17' - , projectConfigStrongFlags = x18' - , projectConfigAllowBootLibInstalls = x19' - , projectConfigPerComponent = x20' - , projectConfigIndependentGoals = x21' - , projectConfigConfigFile = x22' - , projectConfigProgPathExtra = x23'} - | ((x00', x01', x02', x03', x04'), - (x05', x06', x07', x08', x09'), - (x10', x11', x12', x13', x14'), - (x15', x16', x17', x18', x19'), - x20', x21', x22', x23') - <- shrink - ((x00, x01, x02, fmap NonEmpty x03, fmap NonEmpty x04), - (x05, x06, x07, x08, preShrink_Constraints x09), - (x10, x11, x12, x13, x14), - (x15, x16, x17, x18, x19), - x20, x21, x22, x23) - ] - where - preShrink_Constraints = map fst - postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource)) - -projectConfigConstraintSource :: ConstraintSource -projectConfigConstraintSource = - ConstraintSourceProjectConfig "TODO" - -instance Arbitrary ProjectConfigProvenance where - arbitrary = elements [Implicit, Explicit "cabal.project"] - -instance Arbitrary FlagAssignment where - arbitrary = mkFlagAssignment <$> arbitrary - -instance Arbitrary PackageConfig where - arbitrary = - PackageConfig - <$> (MapLast . Map.fromList <$> shortListOf 10 - ((,) <$> arbitraryProgramName - <*> arbitraryShortToken)) - <*> (MapMappend . Map.fromList <$> shortListOf 10 - ((,) <$> arbitraryProgramName - <*> listOf arbitraryShortToken)) - <*> (toNubList <$> listOf arbitraryShortToken) - <*> arbitrary - <*> arbitrary <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> shortListOf 5 arbitraryShortToken - <*> arbitrary - <*> arbitrary <*> arbitrary - <*> shortListOf 5 arbitraryShortToken - <*> shortListOf 5 arbitraryShortToken - <*> shortListOf 5 arbitraryShortToken - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitraryFlag arbitraryShortToken - <*> arbitrary - <*> arbitrary - <*> arbitrary <*> arbitrary - <*> arbitrary - <*> arbitraryFlag arbitraryShortToken - <*> arbitrary - <*> arbitraryFlag arbitraryShortToken - <*> arbitrary - <*> arbitrary - where - arbitraryProgramName :: Gen String - arbitraryProgramName = - elements [ programName prog - | (prog, _) <- knownPrograms (defaultProgramDb) ] - - shrink PackageConfig { packageConfigProgramPaths = x00 - , packageConfigProgramArgs = x01 - , packageConfigProgramPathExtra = x02 - , packageConfigFlagAssignment = x03 - , packageConfigVanillaLib = x04 - , packageConfigSharedLib = x05 - , packageConfigStaticLib = x42 - , packageConfigDynExe = x06 - , packageConfigProf = x07 - , packageConfigProfLib = x08 - , packageConfigProfExe = x09 - , packageConfigProfDetail = x10 - , packageConfigProfLibDetail = x11 - , packageConfigConfigureArgs = x12 - , packageConfigOptimization = x13 - , packageConfigProgPrefix = x14 - , packageConfigProgSuffix = x15 - , packageConfigExtraLibDirs = x16 - , packageConfigExtraFrameworkDirs = x17 - , packageConfigExtraIncludeDirs = x18 - , packageConfigGHCiLib = x19 - , packageConfigSplitSections = x20 - , packageConfigSplitObjs = x20_1 - , packageConfigStripExes = x21 - , packageConfigStripLibs = x22 - , packageConfigTests = x23 - , packageConfigBenchmarks = x24 - , packageConfigCoverage = x25 - , packageConfigRelocatable = x26 - , packageConfigDebugInfo = x27 - , packageConfigRunTests = x28 - , packageConfigDocumentation = x29 - , packageConfigHaddockHoogle = x30 - , packageConfigHaddockHtml = x31 - , packageConfigHaddockHtmlLocation = x32 - , packageConfigHaddockForeignLibs = x33 - , packageConfigHaddockExecutables = x33_1 - , packageConfigHaddockTestSuites = x34 - , packageConfigHaddockBenchmarks = x35 - , packageConfigHaddockInternal = x36 - , packageConfigHaddockCss = x37 - , packageConfigHaddockLinkedSource = x38 - , packageConfigHaddockHscolourCss = x39 - , packageConfigHaddockContents = x40 - , packageConfigHaddockForHackage = x41 } = - [ PackageConfig { packageConfigProgramPaths = postShrink_Paths x00' - , packageConfigProgramArgs = postShrink_Args x01' - , packageConfigProgramPathExtra = x02' - , packageConfigFlagAssignment = x03' - , packageConfigVanillaLib = x04' - , packageConfigSharedLib = x05' - , packageConfigStaticLib = x42' - , packageConfigDynExe = x06' - , packageConfigProf = x07' - , packageConfigProfLib = x08' - , packageConfigProfExe = x09' - , packageConfigProfDetail = x10' - , packageConfigProfLibDetail = x11' - , packageConfigConfigureArgs = map getNonEmpty x12' - , packageConfigOptimization = x13' - , packageConfigProgPrefix = x14' - , packageConfigProgSuffix = x15' - , packageConfigExtraLibDirs = map getNonEmpty x16' - , packageConfigExtraFrameworkDirs = map getNonEmpty x17' - , packageConfigExtraIncludeDirs = map getNonEmpty x18' - , packageConfigGHCiLib = x19' - , packageConfigSplitSections = x20' - , packageConfigSplitObjs = x20_1' - , packageConfigStripExes = x21' - , packageConfigStripLibs = x22' - , packageConfigTests = x23' - , packageConfigBenchmarks = x24' - , packageConfigCoverage = x25' - , packageConfigRelocatable = x26' - , packageConfigDebugInfo = x27' - , packageConfigRunTests = x28' - , packageConfigDocumentation = x29' - , packageConfigHaddockHoogle = x30' - , packageConfigHaddockHtml = x31' - , packageConfigHaddockHtmlLocation = x32' - , packageConfigHaddockForeignLibs = x33' - , packageConfigHaddockExecutables = x33_1' - , packageConfigHaddockTestSuites = x34' - , packageConfigHaddockBenchmarks = x35' - , packageConfigHaddockInternal = x36' - , packageConfigHaddockCss = fmap getNonEmpty x37' - , packageConfigHaddockLinkedSource = x38' - , packageConfigHaddockHscolourCss = fmap getNonEmpty x39' - , packageConfigHaddockContents = x40' - , packageConfigHaddockForHackage = x41' } - | (((x00', x01', x02', x03', x04'), - (x05', x42', x06', x07', x08', x09'), - (x10', x11', x12', x13', x14'), - (x15', x16', x17', x18', x19')), - ((x20', x20_1', x21', x22', x23', x24'), - (x25', x26', x27', x28', x29'), - (x30', x31', x32', (x33', x33_1'), x34'), - (x35', x36', x37', x38', x39'), - (x40', x41'))) - <- shrink - (((preShrink_Paths x00, preShrink_Args x01, x02, x03, x04), - (x05, x42, x06, x07, x08, x09), - (x10, x11, map NonEmpty x12, x13, x14), - (x15, map NonEmpty x16, - map NonEmpty x17, - map NonEmpty x18, - x19)), - ((x20, x20_1, x21, x22, x23, x24), - (x25, x26, x27, x28, x29), - (x30, x31, x32, (x33, x33_1), x34), - (x35, x36, fmap NonEmpty x37, x38, fmap NonEmpty x39), - (x40, x41))) - ] - where - preShrink_Paths = Map.map NonEmpty - . Map.mapKeys NoShrink - . getMapLast - postShrink_Paths = MapLast - . Map.map getNonEmpty - . Map.mapKeys getNoShrink - preShrink_Args = Map.map (NonEmpty . map NonEmpty) - . Map.mapKeys NoShrink - . getMapMappend - postShrink_Args = MapMappend - . Map.map (map getNonEmpty . getNonEmpty) - . Map.mapKeys getNoShrink - -instance Arbitrary HaddockTarget where - arbitrary = elements [ForHackage, ForDevelopment] - -instance Arbitrary SourceRepo where - arbitrary = (SourceRepo RepoThis - <$> arbitrary - <*> (fmap getShortToken <$> arbitrary) - <*> (fmap getShortToken <$> arbitrary) - <*> (fmap getShortToken <$> arbitrary) - <*> (fmap getShortToken <$> arbitrary) - <*> (fmap getShortToken <$> arbitrary)) - `suchThat` (/= emptySourceRepo RepoThis) - - shrink (SourceRepo _ x1 x2 x3 x4 x5 x6) = - [ repo - | ((x1', x2', x3'), (x4', x5', x6')) - <- shrink ((x1, - fmap ShortToken x2, - fmap ShortToken x3), - (fmap ShortToken x4, - fmap ShortToken x5, - fmap ShortToken x6)) - , let repo = SourceRepo RepoThis x1' - (fmap getShortToken x2') - (fmap getShortToken x3') - (fmap getShortToken x4') - (fmap getShortToken x5') - (fmap getShortToken x6') - , repo /= emptySourceRepo RepoThis - ] - -instance Arbitrary RepoType where - arbitrary = elements knownRepoTypes - -instance Arbitrary ReportLevel where - arbitrary = elements [NoReports .. DetailedReports] - -instance Arbitrary CompilerFlavor where - arbitrary = elements knownCompilerFlavors - where - --TODO: [code cleanup] export knownCompilerFlavors from D.Compiler - -- it's already defined there, just need it exported. - knownCompilerFlavors = - [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC] - -instance Arbitrary a => Arbitrary (InstallDirs a) where - arbitrary = - InstallDirs - <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 4 - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 8 - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 12 - <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary -- 16 - -instance Arbitrary PackageDB where - arbitrary = oneof [ pure GlobalPackageDB - , pure UserPackageDB - , SpecificPackageDB . getShortToken <$> arbitrary - ] - -instance Arbitrary RemoteRepo where - arbitrary = - RemoteRepo - <$> arbitraryShortToken `suchThat` (not . (":" `isPrefixOf`)) - <*> arbitrary -- URI - <*> arbitrary - <*> listOf arbitraryRootKey - <*> (fmap getNonNegative arbitrary) - <*> pure False - where - arbitraryRootKey = - shortListOf1 5 (oneof [ choose ('0', '9') - , choose ('a', 'f') ]) - -instance Arbitrary UserConstraintScope where - arbitrary = oneof [ UserQualified <$> arbitrary <*> arbitrary - , UserAnySetupQualifier <$> arbitrary - , UserAnyQualifier <$> arbitrary - ] - -instance Arbitrary UserQualifier where - arbitrary = oneof [ pure UserQualToplevel - , UserQualSetup <$> arbitrary - - -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax. - -- , UserQualExe <$> arbitrary <*> arbitrary - ] - -instance Arbitrary UserConstraint where - arbitrary = UserConstraint <$> arbitrary <*> arbitrary - -instance Arbitrary PackageProperty where - arbitrary = oneof [ PackagePropertyVersion <$> arbitrary - , pure PackagePropertyInstalled - , pure PackagePropertySource - , PackagePropertyFlags . mkFlagAssignment <$> shortListOf1 3 arbitrary - , PackagePropertyStanzas . (\x->[x]) <$> arbitrary - ] - -instance Arbitrary OptionalStanza where - arbitrary = elements [minBound..maxBound] - -instance Arbitrary FlagName where - arbitrary = mkFlagName <$> flagident - where - flagident = lowercase <$> shortListOf1 5 (elements flagChars) - `suchThat` (("-" /=) . take 1) - flagChars = "-_" ++ ['a'..'z'] - -instance Arbitrary PreSolver where - arbitrary = elements [minBound..maxBound] - -instance Arbitrary ReorderGoals where - arbitrary = ReorderGoals <$> arbitrary - -instance Arbitrary CountConflicts where - arbitrary = CountConflicts <$> arbitrary - -instance Arbitrary IndependentGoals where - arbitrary = IndependentGoals <$> arbitrary - -instance Arbitrary StrongFlags where - arbitrary = StrongFlags <$> arbitrary - -instance Arbitrary AllowBootLibInstalls where - arbitrary = AllowBootLibInstalls <$> arbitrary - -instance Arbitrary AllowNewer where - arbitrary = AllowNewer <$> arbitrary - -instance Arbitrary AllowOlder where - arbitrary = AllowOlder <$> arbitrary - -instance Arbitrary RelaxDeps where - arbitrary = oneof [ pure mempty - , RelaxDepsSome <$> shortListOf1 3 arbitrary - , pure RelaxDepsAll - ] - -instance Arbitrary RelaxDepMod where - arbitrary = elements [RelaxDepModNone, RelaxDepModCaret] - -instance Arbitrary RelaxDepScope where - arbitrary = oneof [ pure RelaxDepScopeAll - , RelaxDepScopePackage <$> arbitrary - , RelaxDepScopePackageId <$> (PackageIdentifier <$> arbitrary <*> arbitrary) - ] - -instance Arbitrary RelaxDepSubject where - arbitrary = oneof [ pure RelaxDepSubjectAll - , RelaxDepSubjectPkg <$> arbitrary - ] - -instance Arbitrary RelaxedDep where - arbitrary = RelaxedDep <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary ProfDetailLevel where - arbitrary = elements [ d | (_,_,d) <- knownProfDetailLevels ] - -instance Arbitrary OptimisationLevel where - arbitrary = elements [minBound..maxBound] - -instance Arbitrary DebugInfoLevel where - arbitrary = elements [minBound..maxBound] - -instance Arbitrary URI where - arbitrary = - URI <$> elements ["file:", "http:", "https:"] - <*> (Just <$> arbitrary) - <*> (('/':) <$> arbitraryURIToken) - <*> (('?':) <$> arbitraryURIToken) - <*> pure "" - -instance Arbitrary URIAuth where - arbitrary = - URIAuth <$> pure "" -- no password as this does not roundtrip - <*> arbitraryURIToken - <*> arbitraryURIPort - -arbitraryURIToken :: Gen String -arbitraryURIToken = - shortListOf1 6 (elements (filter isUnreserved ['\0'..'\255'])) - -arbitraryURIPort :: Gen String -arbitraryURIPort = - oneof [ pure "", (':':) <$> shortListOf1 4 (choose ('0','9')) ] diff --git a/tests/UnitTests/Distribution/Client/Sandbox.hs b/tests/UnitTests/Distribution/Client/Sandbox.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/Sandbox.hs +++ /dev/null @@ -1,28 +0,0 @@ -module UnitTests.Distribution.Client.Sandbox ( - tests - ) where - -import Distribution.Client.Sandbox (withSandboxBinDirOnSearchPath) - -import Test.Tasty -import Test.Tasty.HUnit - -import System.FilePath (getSearchPath, ()) - -tests :: [TestTree] -tests = [ testCase "sandboxBinDirOnSearchPath" sandboxBinDirOnSearchPathTest - , testCase "oldSearchPathRestored" oldSearchPathRestoreTest - ] - -sandboxBinDirOnSearchPathTest :: Assertion -sandboxBinDirOnSearchPathTest = - withSandboxBinDirOnSearchPath "foo" $ do - r <- getSearchPath - assertBool "'foo/bin' not on search path" $ ("foo" "bin") `elem` r - -oldSearchPathRestoreTest :: Assertion -oldSearchPathRestoreTest = do - r <- getSearchPath - withSandboxBinDirOnSearchPath "foo" $ return () - r' <- getSearchPath - assertEqual "Old search path wasn't restored" r r' diff --git a/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs b/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs +++ /dev/null @@ -1,63 +0,0 @@ -module UnitTests.Distribution.Client.Sandbox.Timestamp (tests) where - -import System.FilePath - -import Distribution.Simple.Utils (withTempDirectory) -import Distribution.Verbosity - -import Distribution.Compat.Time -import Distribution.Client.Sandbox.Timestamp - -import Test.Tasty -import Test.Tasty.HUnit - -tests :: [TestTree] -tests = - [ testCase "timestamp record version 1 can be read" timestampReadTest_v1 - , testCase "timestamp record version 2 can be read" timestampReadTest_v2 - , testCase "written timestamp record can be read" timestampReadWriteTest ] - -timestampRecord_v1 :: String -timestampRecord_v1 = - "[(\"i386-linux-ghc-8.0.0.20160204\",[(\"/foo/bar/Baz\",1455350946)])" ++ - ",(\"i386-linux-ghc-7.10.3\",[(\"/foo/bar/Baz\",1455484719)])]\n" - -timestampRecord_v2 :: String -timestampRecord_v2 = - "2\n" ++ - "[(\"i386-linux-ghc-8.0.0.20160204\",[(\"/foo/bar/Baz\",1455350946)])" ++ - ",(\"i386-linux-ghc-7.10.3\",[(\"/foo/bar/Baz\",1455484719)])]" - -timestampReadTest_v1 :: Assertion -timestampReadTest_v1 = - timestampReadTest timestampRecord_v1 $ - map (\(i, ts) -> - (i, map (\(p, ModTime t) -> - (p, posixSecondsToModTime . fromIntegral $ t)) ts)) - timestampRecord - -timestampReadTest_v2 :: Assertion -timestampReadTest_v2 = timestampReadTest timestampRecord_v2 timestampRecord - -timestampReadTest :: FilePath -> [TimestampFileRecord] -> Assertion -timestampReadTest fileContent expected = - withTempDirectory silent "." "cabal-timestamp-" $ \dir -> do - let fileName = dir "timestamp-record" - writeFile fileName fileContent - tRec <- readTimestampFile normal fileName - assertEqual "expected timestamp records to be equal" - expected tRec - -timestampRecord :: [TimestampFileRecord] -timestampRecord = - [("i386-linux-ghc-8.0.0.20160204",[("/foo/bar/Baz",ModTime 1455350946)]) - ,("i386-linux-ghc-7.10.3",[("/foo/bar/Baz",ModTime 1455484719)])] - -timestampReadWriteTest :: Assertion -timestampReadWriteTest = - withTempDirectory silent "." "cabal-timestamp-" $ \dir -> do - let fileName = dir "timestamp-record" - writeTimestampFile fileName timestampRecord - tRec <- readTimestampFile normal fileName - assertEqual "expected timestamp records to be equal" - timestampRecord tRec diff --git a/tests/UnitTests/Distribution/Client/Store.hs b/tests/UnitTests/Distribution/Client/Store.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/Store.hs +++ /dev/null @@ -1,181 +0,0 @@ -module UnitTests.Distribution.Client.Store (tests) where - ---import Control.Monad ---import Control.Concurrent (forkIO, threadDelay) ---import Control.Concurrent.MVar -import qualified Data.Set as Set -import System.FilePath -import System.Directory ---import System.Random - -import Distribution.Package (UnitId, mkUnitId) -import Distribution.Compiler (CompilerId(..), CompilerFlavor(..)) -import Distribution.Version (mkVersion) -import Distribution.Verbosity (Verbosity, silent) -import Distribution.Simple.Utils (withTempDirectory) - -import Distribution.Client.Store -import Distribution.Client.RebuildMonad - -import Test.Tasty -import Test.Tasty.HUnit - - -tests :: [TestTree] -tests = - [ testCase "list content empty" testListEmpty - , testCase "install serial" testInstallSerial ---, testCase "install parallel" testInstallParallel - --TODO: figure out some way to do a parallel test, see issue below - ] - - -testListEmpty :: Assertion -testListEmpty = - withTempDirectory verbosity "." "store-" $ \tmp -> do - let storeDirLayout = defaultStoreDirLayout (tmp "store") - - assertStoreEntryExists storeDirLayout compid unitid False - assertStoreContent tmp storeDirLayout compid Set.empty - where - compid = CompilerId GHC (mkVersion [1,0]) - unitid = mkUnitId "foo-1.0-xyz" - - -testInstallSerial :: Assertion -testInstallSerial = - withTempDirectory verbosity "." "store-" $ \tmp -> do - let storeDirLayout = defaultStoreDirLayout (tmp "store") - copyFiles file content dir = do - -- we copy into a prefix inside the tmp dir and return the prefix - let destprefix = dir "prefix" - createDirectory destprefix - writeFile (destprefix file) content - return (destprefix,[]) - - assertNewStoreEntry tmp storeDirLayout compid unitid1 - (copyFiles "file1" "content-foo") (return ()) - UseNewStoreEntry - - assertNewStoreEntry tmp storeDirLayout compid unitid1 - (copyFiles "file1" "content-foo") (return ()) - UseExistingStoreEntry - - assertNewStoreEntry tmp storeDirLayout compid unitid2 - (copyFiles "file2" "content-bar") (return ()) - UseNewStoreEntry - - let pkgDir :: UnitId -> FilePath - pkgDir = storePackageDirectory storeDirLayout compid - assertFileEqual (pkgDir unitid1 "file1") "content-foo" - assertFileEqual (pkgDir unitid2 "file2") "content-bar" - where - compid = CompilerId GHC (mkVersion [1,0]) - unitid1 = mkUnitId "foo-1.0-xyz" - unitid2 = mkUnitId "bar-2.0-xyz" - - -{- --- unfortunately a parallel test like the one below is thwarted by the normal --- process-internal file locking. If that locking were not in place then we --- ought to get the blocking behaviour, but due to the normal Handle locking --- it just fails instead. - -testInstallParallel :: Assertion -testInstallParallel = - withTempDirectory verbosity "." "store-" $ \tmp -> do - let storeDirLayout = defaultStoreDirLayout (tmp "store") - - sync1 <- newEmptyMVar - sync2 <- newEmptyMVar - outv <- newEmptyMVar - regv <- newMVar (0 :: Int) - - sequence_ - [ do forkIO $ do - let copyFiles dir = do - delay <- randomRIO (1,100000) - writeFile (dir "file") (show n) - putMVar sync1 () - readMVar sync2 - threadDelay delay - register = do - modifyMVar_ regv (return . (+1)) - threadDelay 200000 - o <- newStoreEntry verbosity storeDirLayout - compid unitid - copyFiles register - putMVar outv (n, o) - | n <- [0..9 :: Int] ] - - replicateM_ 10 (takeMVar sync1) - -- all threads are in the copyFiles action concurrently, release them: - putMVar sync2 () - - outcomes <- replicateM 10 (takeMVar outv) - regcount <- readMVar regv - let regcount' = length [ () | (_, UseNewStoreEntry) <- outcomes ] - - assertEqual "num registrations" 1 regcount - assertEqual "num registrations" 1 regcount' - - assertStoreContent tmp storeDirLayout compid (Set.singleton unitid) - - let pkgDir :: UnitId -> FilePath - pkgDir = storePackageDirectory storeDirLayout compid - case [ n | (n, UseNewStoreEntry) <- outcomes ] of - [n] -> assertFileEqual (pkgDir unitid "file") (show n) - _ -> assertFailure "impossible" - - where - compid = CompilerId GHC (mkVersion [1,0]) - unitid = mkUnitId "foo-1.0-xyz" --} - -------------- --- Utils - -assertNewStoreEntry :: FilePath -> StoreDirLayout - -> CompilerId -> UnitId - -> (FilePath -> IO (FilePath,[FilePath])) -> IO () - -> NewStoreEntryOutcome - -> Assertion -assertNewStoreEntry tmp storeDirLayout compid unitid - copyFiles register expectedOutcome = do - entries <- runRebuild tmp $ getStoreEntries storeDirLayout compid - outcome <- newStoreEntry verbosity storeDirLayout - compid unitid - copyFiles register - assertEqual "newStoreEntry outcome" expectedOutcome outcome - assertStoreEntryExists storeDirLayout compid unitid True - let expected = Set.insert unitid entries - assertStoreContent tmp storeDirLayout compid expected - - -assertStoreEntryExists :: StoreDirLayout - -> CompilerId -> UnitId -> Bool - -> Assertion -assertStoreEntryExists storeDirLayout compid unitid expected = do - actual <- doesStoreEntryExist storeDirLayout compid unitid - assertEqual "store entry exists" expected actual - - -assertStoreContent :: FilePath -> StoreDirLayout - -> CompilerId -> Set.Set UnitId - -> Assertion -assertStoreContent tmp storeDirLayout compid expected = do - actual <- runRebuild tmp $ getStoreEntries storeDirLayout compid - assertEqual "store content" actual expected - - -assertFileEqual :: FilePath -> String -> Assertion -assertFileEqual path expected = do - exists <- doesFileExist path - assertBool ("file does not exist:\n" ++ path) exists - actual <- readFile path - assertEqual ("file content for:\n" ++ path) expected actual - - -verbosity :: Verbosity -verbosity = silent - diff --git a/tests/UnitTests/Distribution/Client/Tar.hs b/tests/UnitTests/Distribution/Client/Tar.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/Tar.hs +++ /dev/null @@ -1,75 +0,0 @@ -module UnitTests.Distribution.Client.Tar ( - tests - ) where - -import Distribution.Client.Tar ( filterEntries - , filterEntriesM - ) -import Codec.Archive.Tar ( Entries(..) - , foldEntries - ) -import Codec.Archive.Tar.Entry ( EntryContent(..) - , simpleEntry - , Entry(..) - , toTarPath - ) - -import Test.Tasty -import Test.Tasty.HUnit - -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -import Control.Monad.Writer.Lazy (runWriterT, tell) - -tests :: [TestTree] -tests = [ testCase "filterEntries" filterTest - , testCase "filterEntriesM" filterMTest - ] - -filterTest :: Assertion -filterTest = do - let e1 = getFileEntry "file1" "x" - e2 = getFileEntry "file2" "y" - p = (\e -> let (NormalFile dta _) = entryContent e - str = BS.Char8.unpack dta - in str /= "y") - assertEqual "Unexpected result for filter" "xz" $ - entriesToString $ filterEntries p $ Next e1 $ Next e2 Done - assertEqual "Unexpected result for filter" "z" $ - entriesToString $ filterEntries p $ Done - assertEqual "Unexpected result for filter" "xf" $ - entriesToString $ filterEntries p $ Next e1 $ Next e2 $ Fail "f" - -filterMTest :: Assertion -filterMTest = do - let e1 = getFileEntry "file1" "x" - e2 = getFileEntry "file2" "y" - p = (\e -> let (NormalFile dta _) = entryContent e - str = BS.Char8.unpack dta - in tell "t" >> return (str /= "y")) - - (r, w) <- runWriterT $ filterEntriesM p $ Next e1 $ Next e2 Done - assertEqual "Unexpected result for filterM" "xz" $ entriesToString r - assertEqual "Unexpected result for filterM w" "tt" w - - (r1, w1) <- runWriterT $ filterEntriesM p $ Done - assertEqual "Unexpected result for filterM" "z" $ entriesToString r1 - assertEqual "Unexpected result for filterM w" "" w1 - - (r2, w2) <- runWriterT $ filterEntriesM p $ Next e1 $ Next e2 $ Fail "f" - assertEqual "Unexpected result for filterM" "xf" $ entriesToString r2 - assertEqual "Unexpected result for filterM w" "tt" w2 - -getFileEntry :: FilePath -> [Char] -> Entry -getFileEntry pth dta = - simpleEntry tp $ NormalFile dta' $ BS.length dta' - where tp = case toTarPath False pth of - Right tp' -> tp' - Left e -> error e - dta' = BS.Char8.pack dta - -entriesToString :: Entries String -> String -entriesToString = - foldEntries (\e acc -> let (NormalFile dta _) = entryContent e - str = BS.Char8.unpack dta - in str ++ acc) "z" id diff --git a/tests/UnitTests/Distribution/Client/Targets.hs b/tests/UnitTests/Distribution/Client/Targets.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/Targets.hs +++ /dev/null @@ -1,107 +0,0 @@ -module UnitTests.Distribution.Client.Targets ( - tests - ) where - -import Distribution.Client.Targets (UserQualifier(..) - ,UserConstraintScope(..) - ,UserConstraint(..), readUserConstraint) -import Distribution.Compat.ReadP (readP_to_S) -import Distribution.Package (mkPackageName) -import Distribution.PackageDescription (mkFlagName, mkFlagAssignment) -import Distribution.Version (anyVersion, thisVersion, mkVersion) -import Distribution.ParseUtils (parseCommaList) -import Distribution.Text (parse) - -import Distribution.Solver.Types.PackageConstraint (PackageProperty(..)) -import Distribution.Solver.Types.OptionalStanza (OptionalStanza(..)) - -import Test.Tasty -import Test.Tasty.HUnit - -import Data.Char (isSpace) -import Data.List (intercalate) - --- Helper function: makes a test group by mapping each element --- of a list to a test case. -makeGroup :: String -> (a -> Assertion) -> [a] -> TestTree -makeGroup name f xs = testGroup name $ - zipWith testCase (map show [0 :: Integer ..]) (map f xs) - -tests :: [TestTree] -tests = - [ makeGroup "readUserConstraint" (uncurry readUserConstraintTest) - exampleConstraints - - , makeGroup "parseUserConstraint" (uncurry parseUserConstraintTest) - exampleConstraints - - , makeGroup "readUserConstraints" (uncurry readUserConstraintsTest) - [-- First example only. - (head exampleStrs, take 1 exampleUcs), - -- All examples separated by commas. - (intercalate ", " exampleStrs, exampleUcs)] - ] - where - (exampleStrs, exampleUcs) = unzip exampleConstraints - -exampleConstraints :: [(String, UserConstraint)] -exampleConstraints = - [ ("template-haskell installed", - UserConstraint (UserQualified UserQualToplevel (pn "template-haskell")) - PackagePropertyInstalled) - - , ("bytestring -any", - UserConstraint (UserQualified UserQualToplevel (pn "bytestring")) - (PackagePropertyVersion anyVersion)) - - , ("any.directory test", - UserConstraint (UserAnyQualifier (pn "directory")) - (PackagePropertyStanzas [TestStanzas])) - - , ("setup.Cabal installed", - UserConstraint (UserAnySetupQualifier (pn "Cabal")) - PackagePropertyInstalled) - - , ("process:setup.bytestring ==5.2", - UserConstraint (UserQualified (UserQualSetup (pn "process")) (pn "bytestring")) - (PackagePropertyVersion (thisVersion (mkVersion [5, 2])))) - - , ("network:setup.containers +foo -bar baz", - UserConstraint (UserQualified (UserQualSetup (pn "network")) (pn "containers")) - (PackagePropertyFlags (mkFlagAssignment - [(fn "foo", True), - (fn "bar", False), - (fn "baz", True)]))) - - -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax. - -- - -- , ("foo:happy:exe.template-haskell test", - -- UserConstraint (UserQualified (UserQualExe (pn "foo") (pn "happy")) (pn "template-haskell")) - -- (PackagePropertyStanzas [TestStanzas])) - ] - where - pn = mkPackageName - fn = mkFlagName - -readUserConstraintTest :: String -> UserConstraint -> Assertion -readUserConstraintTest str uc = - assertEqual ("Couldn't read constraint: '" ++ str ++ "'") expected actual - where - expected = uc - actual = let Right r = readUserConstraint str in r - -parseUserConstraintTest :: String -> UserConstraint -> Assertion -parseUserConstraintTest str uc = - assertEqual ("Couldn't parse constraint: '" ++ str ++ "'") expected actual - where - expected = [uc] - actual = [ x | (x, ys) <- readP_to_S parse str - , all isSpace ys] - -readUserConstraintsTest :: String -> [UserConstraint] -> Assertion -readUserConstraintsTest str ucs = - assertEqual ("Couldn't read constraints: '" ++ str ++ "'") expected actual - where - expected = [ucs] - actual = [ x | (x, ys) <- readP_to_S (parseCommaList parse) str - , all isSpace ys] diff --git a/tests/UnitTests/Distribution/Client/UserConfig.hs b/tests/UnitTests/Distribution/Client/UserConfig.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Client/UserConfig.hs +++ /dev/null @@ -1,112 +0,0 @@ -{-# LANGUAGE CPP #-} -module UnitTests.Distribution.Client.UserConfig - ( tests - ) where - -import Control.Exception (bracket) -import Control.Monad (replicateM_) -import Data.List (sort, nub) -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -#endif -import System.Directory (doesFileExist, - getCurrentDirectory, getTemporaryDirectory) -import System.FilePath (()) - -import Test.Tasty -import Test.Tasty.HUnit - -import Distribution.Client.Config -import Distribution.Utils.NubList (fromNubList) -import Distribution.Client.Setup (GlobalFlags (..), InstallFlags (..)) -import Distribution.Client.Utils (removeExistingFile) -import Distribution.Simple.Setup (Flag (..), ConfigFlags (..), fromFlag) -import Distribution.Simple.Utils (withTempDirectory) -import Distribution.Verbosity (silent) - -tests :: [TestTree] -tests = [ testCase "nullDiffOnCreate" nullDiffOnCreateTest - , testCase "canDetectDifference" canDetectDifference - , testCase "canUpdateConfig" canUpdateConfig - , testCase "doubleUpdateConfig" doubleUpdateConfig - , testCase "newDefaultConfig" newDefaultConfig - ] - -nullDiffOnCreateTest :: Assertion -nullDiffOnCreateTest = bracketTest $ \configFile -> do - -- Create a new default config file in our test directory. - _ <- loadConfig silent (Flag configFile) - -- Now we read it in and compare it against the default. - diff <- userConfigDiff silent (globalFlags configFile) [] - assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff - - -canDetectDifference :: Assertion -canDetectDifference = bracketTest $ \configFile -> do - -- Create a new default config file in our test directory. - _ <- loadConfig silent (Flag configFile) - appendFile configFile "verbose: 0\n" - diff <- userConfigDiff silent (globalFlags configFile) [] - assertBool (unlines $ "Should detect a difference:" : diff) $ - diff == [ "+ verbose: 0" ] - - -canUpdateConfig :: Assertion -canUpdateConfig = bracketTest $ \configFile -> do - -- Write a trivial cabal file. - writeFile configFile "tests: True\n" - -- Update the config file. - userConfigUpdate silent (globalFlags configFile) [] - -- Load it again. - updated <- loadConfig silent (Flag configFile) - assertBool ("Field 'tests' should be True") $ - fromFlag (configTests $ savedConfigureFlags updated) - - -doubleUpdateConfig :: Assertion -doubleUpdateConfig = bracketTest $ \configFile -> do - -- Create a new default config file in our test directory. - _ <- loadConfig silent (Flag configFile) - -- Update it twice. - replicateM_ 2 $ userConfigUpdate silent (globalFlags configFile) [] - -- Load it again. - updated <- loadConfig silent (Flag configFile) - - assertBool ("Field 'remote-repo' doesn't contain duplicates") $ - listUnique (map show . fromNubList . globalRemoteRepos $ savedGlobalFlags updated) - assertBool ("Field 'extra-prog-path' doesn't contain duplicates") $ - listUnique (map show . fromNubList . configProgramPathExtra $ savedConfigureFlags updated) - assertBool ("Field 'build-summary' doesn't contain duplicates") $ - listUnique (map show . fromNubList . installSummaryFile $ savedInstallFlags updated) - - -newDefaultConfig :: Assertion -newDefaultConfig = do - sysTmpDir <- getTemporaryDirectory - withTempDirectory silent sysTmpDir "cabal-test" $ \tmpDir -> do - let configFile = tmpDir "tmp.config" - _ <- createDefaultConfigFile silent [] configFile - exists <- doesFileExist configFile - assertBool ("Config file should be written to " ++ configFile) exists - - -globalFlags :: FilePath -> GlobalFlags -globalFlags configFile = mempty { globalConfigFile = Flag configFile } - - -listUnique :: Ord a => [a] -> Bool -listUnique xs = - let sorted = sort xs - in nub sorted == xs - - -bracketTest :: (FilePath -> IO ()) -> Assertion -bracketTest = - bracket testSetup testTearDown - where - testSetup :: IO FilePath - testSetup = fmap ( "test-user-config") getCurrentDirectory - - testTearDown :: FilePath -> IO () - testTearDown configFile = - mapM_ removeExistingFile [configFile, configFile ++ ".backup"] diff --git a/tests/UnitTests/Distribution/Solver/Modular/Builder.hs b/tests/UnitTests/Distribution/Solver/Modular/Builder.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Solver/Modular/Builder.hs +++ /dev/null @@ -1,20 +0,0 @@ -module UnitTests.Distribution.Solver.Modular.Builder ( - tests - ) where - -import Distribution.Solver.Modular.Builder - -import Test.Tasty -import Test.Tasty.QuickCheck - -tests :: [TestTree] -tests = [ testProperty "splitsAltImplementation" splitsTest - ] - --- | Simpler splits implementation -splits' :: [a] -> [(a, [a])] -splits' [] = [] -splits' (x : xs) = (x, xs) : map (\ (y, ys) -> (y, x : ys)) (splits' xs) - -splitsTest :: [Int] -> Property -splitsTest xs = splits' xs === splits xs diff --git a/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/tests/UnitTests/Distribution/Solver/Modular/DSL.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ /dev/null @@ -1,698 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | DSL for testing the modular solver -module UnitTests.Distribution.Solver.Modular.DSL ( - ExampleDependency(..) - , Dependencies(..) - , ExTest(..) - , ExExe(..) - , ExConstraint(..) - , ExPreference(..) - , ExampleDb - , ExampleVersionRange - , ExamplePkgVersion - , ExamplePkgName - , ExampleFlagName - , ExFlag(..) - , ExampleAvailable(..) - , ExampleInstalled(..) - , ExampleQualifier(..) - , ExampleVar(..) - , EnableAllTests(..) - , exAv - , exInst - , exFlagged - , exResolve - , extractInstallPlan - , declareFlags - , withSetupDeps - , withTest - , withTests - , withExe - , withExes - , runProgress - , mkSimpleVersion - , mkVersionRange - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude - --- base -import Data.Either (partitionEithers) -import qualified Data.Map as Map - --- Cabal -import qualified Distribution.Compiler as C -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.License (License(..)) -import qualified Distribution.ModuleName as Module -import qualified Distribution.Package as C - hiding (HasUnitId(..)) -import qualified Distribution.Types.ExeDependency as C -import qualified Distribution.Types.LegacyExeDependency as C -import qualified Distribution.Types.PkgconfigDependency as C -import qualified Distribution.Types.UnqualComponentName as C -import qualified Distribution.Types.CondTree as C -import qualified Distribution.PackageDescription as C -import qualified Distribution.PackageDescription.Check as C -import qualified Distribution.Simple.PackageIndex as C.PackageIndex -import Distribution.Simple.Setup (BooleanFlag(..)) -import qualified Distribution.System as C -import Distribution.Text (display) -import qualified Distribution.Version as C -import Language.Haskell.Extension (Extension(..), Language(..)) - --- cabal-install -import Distribution.Client.Dependency -import Distribution.Client.Dependency.Types -import Distribution.Client.Types -import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan - -import Distribution.Solver.Types.ComponentDeps (ComponentDeps) -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ConstraintSource -import Distribution.Solver.Types.Flag -import Distribution.Solver.Types.LabeledPackageConstraint -import Distribution.Solver.Types.OptionalStanza -import qualified Distribution.Solver.Types.PackageIndex as CI.PackageIndex -import Distribution.Solver.Types.PackageConstraint -import qualified Distribution.Solver.Types.PackagePath as P -import qualified Distribution.Solver.Types.PkgConfigDb as PC -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.SolverPackage -import Distribution.Solver.Types.SourcePackage -import Distribution.Solver.Types.Variable - -{------------------------------------------------------------------------------- - Example package database DSL - - In order to be able to set simple examples up quickly, we define a very - simple version of the package database here explicitly designed for use in - tests. - - The design of `ExampleDb` takes the perspective of the solver, not the - perspective of the package DB. This makes it easier to set up tests for - various parts of the solver, but makes the mapping somewhat awkward, because - it means we first map from "solver perspective" `ExampleDb` to the package - database format, and then the modular solver internally in `IndexConversion` - maps this back to the solver specific data structures. - - IMPLEMENTATION NOTES - -------------------- - - TODO: Perhaps these should be made comments of the corresponding data type - definitions. For now these are just my own conclusions and may be wrong. - - * The difference between `GenericPackageDescription` and `PackageDescription` - is that `PackageDescription` describes a particular _configuration_ of a - package (for instance, see documentation for `checkPackage`). A - `GenericPackageDescription` can be turned into a `PackageDescription` in - two ways: - - a. `finalizePD` does the proper translation, by taking - into account the platform, available dependencies, etc. and picks a - flag assignment (or gives an error if no flag assignment can be found) - b. `flattenPackageDescription` ignores flag assignment and just joins all - components together. - - The slightly odd thing is that a `GenericPackageDescription` contains a - `PackageDescription` as a field; both of the above functions do the same - thing: they take the embedded `PackageDescription` as a basis for the result - value, but override `library`, `executables`, `testSuites`, `benchmarks` - and `buildDepends`. - * The `condTreeComponents` fields of a `CondTree` is a list of triples - `(condition, then-branch, else-branch)`, where the `else-branch` is - optional. --------------------------------------------------------------------------------} - -type ExamplePkgName = String -type ExamplePkgVersion = Int -type ExamplePkgHash = String -- for example "installed" packages -type ExampleFlagName = String -type ExampleTestName = String -type ExampleExeName = String -type ExampleVersionRange = C.VersionRange - -data Dependencies = NotBuildable | Buildable [ExampleDependency] - deriving Show - -data ExampleDependency = - -- | Simple dependency on any version - ExAny ExamplePkgName - - -- | Simple dependency on a fixed version - | ExFix ExamplePkgName ExamplePkgVersion - - -- | Simple dependency on a range of versions, with an inclusive lower bound - -- and an exclusive upper bound. - | ExRange ExamplePkgName ExamplePkgVersion ExamplePkgVersion - - -- | Build-tool-depends dependency - | ExBuildToolAny ExamplePkgName ExampleExeName - - -- | Build-tool-depends dependency on a fixed version - | ExBuildToolFix ExamplePkgName ExampleExeName ExamplePkgVersion - - -- | Legacy build-tools dependency - | ExLegacyBuildToolAny ExamplePkgName - - -- | Legacy build-tools dependency on a fixed version - | ExLegacyBuildToolFix ExamplePkgName ExamplePkgVersion - - -- | Dependencies indexed by a flag - | ExFlagged ExampleFlagName Dependencies Dependencies - - -- | Dependency on a language extension - | ExExt Extension - - -- | Dependency on a language version - | ExLang Language - - -- | Dependency on a pkg-config package - | ExPkg (ExamplePkgName, ExamplePkgVersion) - deriving Show - --- | Simplified version of D.Types.GenericPackageDescription.Flag for use in --- example source packages. -data ExFlag = ExFlag { - exFlagName :: ExampleFlagName - , exFlagDefault :: Bool - , exFlagType :: FlagType - } deriving Show - -data ExTest = ExTest ExampleTestName [ExampleDependency] - -data ExExe = ExExe ExampleExeName [ExampleDependency] - -exFlagged :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency] - -> ExampleDependency -exFlagged n t e = ExFlagged n (Buildable t) (Buildable e) - -data ExConstraint = - ExVersionConstraint ConstraintScope ExampleVersionRange - | ExFlagConstraint ConstraintScope ExampleFlagName Bool - | ExStanzaConstraint ConstraintScope [OptionalStanza] - deriving Show - -data ExPreference = - ExPkgPref ExamplePkgName ExampleVersionRange - | ExStanzaPref ExamplePkgName [OptionalStanza] - deriving Show - -data ExampleAvailable = ExAv { - exAvName :: ExamplePkgName - , exAvVersion :: ExamplePkgVersion - , exAvDeps :: ComponentDeps [ExampleDependency] - - -- Setting flags here is only necessary to override the default values of - -- the fields in C.Flag. - , exAvFlags :: [ExFlag] - } deriving Show - -data ExampleVar = - P ExampleQualifier ExamplePkgName - | F ExampleQualifier ExamplePkgName ExampleFlagName - | S ExampleQualifier ExamplePkgName OptionalStanza - -data ExampleQualifier = - QualNone - | QualIndep ExamplePkgName - | QualSetup ExamplePkgName - - -- The two package names are the build target and the package containing the - -- setup script. - | QualIndepSetup ExamplePkgName ExamplePkgName - - -- The two package names are the package depending on the exe and the - -- package containing the exe. - | QualExe ExamplePkgName ExamplePkgName - --- | Whether to enable tests in all packages in a test case. -newtype EnableAllTests = EnableAllTests Bool - deriving BooleanFlag - --- | Constructs an 'ExampleAvailable' package for the 'ExampleDb', --- given: --- --- 1. The name 'ExamplePkgName' of the available package, --- 2. The version 'ExamplePkgVersion' available --- 3. The list of dependency constraints 'ExampleDependency' --- that this package has. 'ExampleDependency' provides --- a number of pre-canned dependency types to look at. --- -exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency] - -> ExampleAvailable -exAv n v ds = ExAv { exAvName = n, exAvVersion = v - , exAvDeps = CD.fromLibraryDeps ds, exAvFlags = [] } - --- | Override the default settings (e.g., manual vs. automatic) for a subset of --- a package's flags. -declareFlags :: [ExFlag] -> ExampleAvailable -> ExampleAvailable -declareFlags flags ex = ex { - exAvFlags = flags - } - -withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable -withSetupDeps ex setupDeps = ex { - exAvDeps = exAvDeps ex <> CD.fromSetupDeps setupDeps - } - -withTest :: ExampleAvailable -> ExTest -> ExampleAvailable -withTest ex test = withTests ex [test] - -withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable -withTests ex tests = - let testCDs = CD.fromList [(CD.ComponentTest $ C.mkUnqualComponentName name, deps) - | ExTest name deps <- tests] - in ex { exAvDeps = exAvDeps ex <> testCDs } - -withExe :: ExampleAvailable -> ExExe -> ExampleAvailable -withExe ex exe = withExes ex [exe] - -withExes :: ExampleAvailable -> [ExExe] -> ExampleAvailable -withExes ex exes = - let exeCDs = CD.fromList [(CD.ComponentExe $ C.mkUnqualComponentName name, deps) - | ExExe name deps <- exes] - in ex { exAvDeps = exAvDeps ex <> exeCDs } - --- | An installed package in 'ExampleDb'; construct me with 'exInst'. -data ExampleInstalled = ExInst { - exInstName :: ExamplePkgName - , exInstVersion :: ExamplePkgVersion - , exInstHash :: ExamplePkgHash - , exInstBuildAgainst :: [ExamplePkgHash] - } deriving Show - --- | Constructs an example installed package given: --- --- 1. The name of the package 'ExamplePkgName', i.e., 'String' --- 2. The version of the package 'ExamplePkgVersion', i.e., 'Int' --- 3. The IPID for the package 'ExamplePkgHash', i.e., 'String' --- (just some unique identifier for the package.) --- 4. The 'ExampleInstalled' packages which this package was --- compiled against.) --- -exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash - -> [ExampleInstalled] -> ExampleInstalled -exInst pn v hash deps = ExInst pn v hash (map exInstHash deps) - --- | An example package database is a list of installed packages --- 'ExampleInstalled' and available packages 'ExampleAvailable'. --- Generally, you want to use 'exInst' and 'exAv' to construct --- these packages. -type ExampleDb = [Either ExampleInstalled ExampleAvailable] - -type DependencyTree a = C.CondTree C.ConfVar [C.Dependency] a - -type DependencyComponent a = C.CondBranch C.ConfVar [C.Dependency] a - -exDbPkgs :: ExampleDb -> [ExamplePkgName] -exDbPkgs = map (either exInstName exAvName) - -exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage -exAvSrcPkg ex = - let pkgId = exAvPkgId ex - - flags :: [C.Flag] - flags = - let declaredFlags :: Map ExampleFlagName C.Flag - declaredFlags = - Map.fromListWith - (\f1 f2 -> error $ "duplicate flag declarations: " ++ show [f1, f2]) - [(exFlagName flag, mkFlag flag) | flag <- exAvFlags ex] - - usedFlags :: Map ExampleFlagName C.Flag - usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names] - where - names = concatMap extractFlags $ - CD.libraryDeps (exAvDeps ex) - ++ concatMap snd testSuites - ++ concatMap snd executables - in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings: - Map.elems $ declaredFlags `Map.union` usedFlags - - testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)] - executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)] - setup = case CD.setupDeps (exAvDeps ex) of - [] -> Nothing - deps -> Just C.SetupBuildInfo { - C.setupDepends = mkSetupDeps deps, - C.defaultSetupDepends = False - } - package = SourcePackage { - packageInfoId = pkgId - , packageSource = LocalTarballPackage "<>" - , packageDescrOverride = Nothing - , packageDescription = C.GenericPackageDescription { - C.packageDescription = C.emptyPackageDescription { - C.package = pkgId - , C.setupBuildInfo = setup - , C.licenseRaw = Right BSD3 - , C.buildTypeRaw = if isNothing setup - then Just C.Simple - else Just C.Custom - , C.category = "category" - , C.maintainer = "maintainer" - , C.description = "description" - , C.synopsis = "synopsis" - , C.licenseFiles = ["LICENSE"] - , C.specVersionRaw = Left $ C.mkVersion [1,12] - } - , C.genPackageFlags = flags - , C.condLibrary = - let mkLib bi = mempty { C.libBuildInfo = bi } - in Just $ mkCondTree defaultLib mkLib $ mkBuildInfoTree $ - Buildable (CD.libraryDeps (exAvDeps ex)) - , C.condSubLibraries = [] - , C.condForeignLibs = [] - , C.condExecutables = - let mkTree = mkCondTree defaultExe mkExe . mkBuildInfoTree . Buildable - mkExe bi = mempty { C.buildInfo = bi } - in map (\(t, deps) -> (t, mkTree deps)) executables - , C.condTestSuites = - let mkTree = mkCondTree defaultTest mkTest . mkBuildInfoTree . Buildable - mkTest bi = mempty { C.testBuildInfo = bi } - in map (\(t, deps) -> (t, mkTree deps)) testSuites - , C.condBenchmarks = [] - } - } - pkgCheckErrors = - -- We ignore these warnings because some unit tests test that the - -- solver allows unknown extensions/languages when the compiler - -- supports them. - let ignore = ["Unknown extensions:", "Unknown languages:"] - in [ err | err <- C.checkPackage (packageDescription package) Nothing - , not $ any (`isPrefixOf` C.explanation err) ignore ] - in if null pkgCheckErrors - then package - else error $ "invalid GenericPackageDescription for package " - ++ display pkgId ++ ": " ++ show pkgCheckErrors - where - defaultTopLevelBuildInfo :: C.BuildInfo - defaultTopLevelBuildInfo = mempty { C.defaultLanguage = Just Haskell98 } - - defaultLib :: C.Library - defaultLib = mempty { C.exposedModules = [Module.fromString "Module"] } - - defaultExe :: C.Executable - defaultExe = mempty { C.modulePath = "Main.hs" } - - defaultTest :: C.TestSuite - defaultTest = mempty { - C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1,0]) "Test.hs" - } - - -- Split the set of dependencies into the set of dependencies of the library, - -- the dependencies of the test suites and extensions. - splitTopLevel :: [ExampleDependency] - -> ( [ExampleDependency] - , [Extension] - , Maybe Language - , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config - , [(ExamplePkgName, ExampleExeName, C.VersionRange)] -- build tools - , [(ExamplePkgName, C.VersionRange)] -- legacy build tools - ) - splitTopLevel [] = - ([], [], Nothing, [], [], []) - splitTopLevel (ExBuildToolAny p e:deps) = - let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, exts, lang, pcpkgs, (p, e, C.anyVersion):exes, legacyExes) - splitTopLevel (ExBuildToolFix p e v:deps) = - let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, exts, lang, pcpkgs, (p, e, C.thisVersion (mkSimpleVersion v)):exes, legacyExes) - splitTopLevel (ExLegacyBuildToolAny p:deps) = - let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, exts, lang, pcpkgs, exes, (p, C.anyVersion):legacyExes) - splitTopLevel (ExLegacyBuildToolFix p v:deps) = - let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, exts, lang, pcpkgs, exes, (p, C.thisVersion (mkSimpleVersion v)):legacyExes) - splitTopLevel (ExExt ext:deps) = - let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, ext:exts, lang, pcpkgs, exes, legacyExes) - splitTopLevel (ExLang lang:deps) = - case splitTopLevel deps of - (other, exts, Nothing, pcpkgs, exes, legacyExes) -> (other, exts, Just lang, pcpkgs, exes, legacyExes) - _ -> error "Only 1 Language dependency is supported" - splitTopLevel (ExPkg pkg:deps) = - let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (other, exts, lang, pkg:pcpkgs, exes, legacyExes) - splitTopLevel (dep:deps) = - let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps - in (dep:other, exts, lang, pcpkgs, exes, legacyExes) - - -- Extract the total set of flags used - extractFlags :: ExampleDependency -> [ExampleFlagName] - extractFlags (ExAny _) = [] - extractFlags (ExFix _ _) = [] - extractFlags (ExRange _ _ _) = [] - extractFlags (ExBuildToolAny _ _) = [] - extractFlags (ExBuildToolFix _ _ _) = [] - extractFlags (ExLegacyBuildToolAny _) = [] - extractFlags (ExLegacyBuildToolFix _ _) = [] - extractFlags (ExFlagged f a b) = - f : concatMap extractFlags (deps a ++ deps b) - where - deps :: Dependencies -> [ExampleDependency] - deps NotBuildable = [] - deps (Buildable ds) = ds - extractFlags (ExExt _) = [] - extractFlags (ExLang _) = [] - extractFlags (ExPkg _) = [] - - -- Convert a tree of BuildInfos into a tree of a specific component type. - -- 'defaultTopLevel' contains the default values for the component, and - -- 'mkComponent' creates a component from a 'BuildInfo'. - mkCondTree :: forall a. Semigroup a => - a -> (C.BuildInfo -> a) - -> DependencyTree C.BuildInfo - -> DependencyTree a - mkCondTree defaultTopLevel mkComponent (C.CondNode topData topConstraints topComps) = - C.CondNode { - C.condTreeData = - defaultTopLevel <> mkComponent (defaultTopLevelBuildInfo <> topData) - , C.condTreeConstraints = topConstraints - , C.condTreeComponents = goComponents topComps - } - where - go :: DependencyTree C.BuildInfo -> DependencyTree a - go (C.CondNode ctData constraints comps) = - C.CondNode (mkComponent ctData) constraints (goComponents comps) - - goComponents :: [DependencyComponent C.BuildInfo] - -> [DependencyComponent a] - goComponents comps = [C.CondBranch cond (go t) (go <$> me) | C.CondBranch cond t me <- comps] - - mkBuildInfoTree :: Dependencies -> DependencyTree C.BuildInfo - mkBuildInfoTree NotBuildable = - C.CondNode { - C.condTreeData = mempty { C.buildable = False } - , C.condTreeConstraints = [] - , C.condTreeComponents = [] - } - mkBuildInfoTree (Buildable deps) = - let (libraryDeps, exts, mlang, pcpkgs, buildTools, legacyBuildTools) = splitTopLevel deps - (directDeps, flaggedDeps) = splitDeps libraryDeps - bi = mempty { - C.otherExtensions = exts - , C.defaultLanguage = mlang - , C.buildToolDepends = [ C.ExeDependency (C.mkPackageName p) (C.mkUnqualComponentName e) vr - | (p, e, vr) <- buildTools] - , C.buildTools = [ C.LegacyExeDependency n vr - | (n,vr) <- legacyBuildTools] - , C.pkgconfigDepends = [ C.PkgconfigDependency n' v' - | (n,v) <- pcpkgs - , let n' = C.mkPkgconfigName n - , let v' = C.thisVersion (mkSimpleVersion v) ] - } - in C.CondNode { - C.condTreeData = bi -- Necessary for language extensions - -- TODO: Arguably, build-tools dependencies should also - -- effect constraints on conditional tree. But no way to - -- distinguish between them - , C.condTreeConstraints = map mkDirect directDeps - , C.condTreeComponents = map mkFlagged flaggedDeps - } - - mkDirect :: (ExamplePkgName, C.VersionRange) -> C.Dependency - mkDirect (dep, vr) = C.Dependency (C.mkPackageName dep) vr - - mkFlagged :: (ExampleFlagName, Dependencies, Dependencies) - -> DependencyComponent C.BuildInfo - mkFlagged (f, a, b) = - C.CondBranch (C.Var (C.Flag (C.mkFlagName f))) - (mkBuildInfoTree a) - (Just (mkBuildInfoTree b)) - - -- Split a set of dependencies into direct dependencies and flagged - -- dependencies. A direct dependency is a tuple of the name of package and - -- its version range meant to be converted to a 'C.Dependency' with - -- 'mkDirect' for example. A flagged dependency is the set of dependencies - -- guarded by a flag. - splitDeps :: [ExampleDependency] - -> ( [(ExamplePkgName, C.VersionRange)] - , [(ExampleFlagName, Dependencies, Dependencies)] - ) - splitDeps [] = - ([], []) - splitDeps (ExAny p:deps) = - let (directDeps, flaggedDeps) = splitDeps deps - in ((p, C.anyVersion):directDeps, flaggedDeps) - splitDeps (ExFix p v:deps) = - let (directDeps, flaggedDeps) = splitDeps deps - in ((p, C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps) - splitDeps (ExRange p v1 v2:deps) = - let (directDeps, flaggedDeps) = splitDeps deps - in ((p, mkVersionRange v1 v2):directDeps, flaggedDeps) - splitDeps (ExFlagged f a b:deps) = - let (directDeps, flaggedDeps) = splitDeps deps - in (directDeps, (f, a, b):flaggedDeps) - splitDeps (dep:_) = error $ "Unexpected dependency: " ++ show dep - - -- custom-setup only supports simple dependencies - mkSetupDeps :: [ExampleDependency] -> [C.Dependency] - mkSetupDeps deps = - let (directDeps, []) = splitDeps deps in map mkDirect directDeps - -mkSimpleVersion :: ExamplePkgVersion -> C.Version -mkSimpleVersion n = C.mkVersion [n, 0, 0] - -mkVersionRange :: ExamplePkgVersion -> ExamplePkgVersion -> C.VersionRange -mkVersionRange v1 v2 = - C.intersectVersionRanges (C.orLaterVersion $ mkSimpleVersion v1) - (C.earlierVersion $ mkSimpleVersion v2) - -mkFlag :: ExFlag -> C.Flag -mkFlag flag = C.MkFlag { - C.flagName = C.mkFlagName $ exFlagName flag - , C.flagDescription = "" - , C.flagDefault = exFlagDefault flag - , C.flagManual = - case exFlagType flag of - Manual -> True - Automatic -> False - } - -mkDefaultFlag :: ExampleFlagName -> C.Flag -mkDefaultFlag flag = C.MkFlag { - C.flagName = C.mkFlagName flag - , C.flagDescription = "" - , C.flagDefault = True - , C.flagManual = False - } - -exAvPkgId :: ExampleAvailable -> C.PackageIdentifier -exAvPkgId ex = C.PackageIdentifier { - pkgName = C.mkPackageName (exAvName ex) - , pkgVersion = C.mkVersion [exAvVersion ex, 0, 0] - } - -exInstInfo :: ExampleInstalled -> IPI.InstalledPackageInfo -exInstInfo ex = IPI.emptyInstalledPackageInfo { - IPI.installedUnitId = C.mkUnitId (exInstHash ex) - , IPI.sourcePackageId = exInstPkgId ex - , IPI.depends = map C.mkUnitId (exInstBuildAgainst ex) - } - -exInstPkgId :: ExampleInstalled -> C.PackageIdentifier -exInstPkgId ex = C.PackageIdentifier { - pkgName = C.mkPackageName (exInstName ex) - , pkgVersion = C.mkVersion [exInstVersion ex, 0, 0] - } - -exAvIdx :: [ExampleAvailable] -> CI.PackageIndex.PackageIndex UnresolvedSourcePackage -exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg - -exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex -exInstIdx = C.PackageIndex.fromList . map exInstInfo - -exResolve :: ExampleDb - -- List of extensions supported by the compiler, or Nothing if unknown. - -> Maybe [Extension] - -- List of languages supported by the compiler, or Nothing if unknown. - -> Maybe [Language] - -> PC.PkgConfigDb - -> [ExamplePkgName] - -> Maybe Int - -> CountConflicts - -> IndependentGoals - -> ReorderGoals - -> AllowBootLibInstalls - -> EnableBackjumping - -> SolveExecutables - -> Maybe (Variable P.QPN -> Variable P.QPN -> Ordering) - -> [ExConstraint] - -> [ExPreference] - -> EnableAllTests - -> Progress String String CI.SolverInstallPlan.SolverInstallPlan -exResolve db exts langs pkgConfigDb targets mbj countConflicts indepGoals - reorder allowBootLibInstalls enableBj solveExes goalOrder constraints - prefs enableAllTests - = resolveDependencies C.buildPlatform compiler pkgConfigDb Modular params - where - defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag - compiler = defaultCompiler { C.compilerInfoExtensions = exts - , C.compilerInfoLanguages = langs - } - (inst, avai) = partitionEithers db - instIdx = exInstIdx inst - avaiIdx = SourcePackageDb { - packageIndex = exAvIdx avai - , packagePreferences = Map.empty - } - enableTests - | asBool enableAllTests = fmap (\p -> PackageConstraint - (scopeToplevel (C.mkPackageName p)) - (PackagePropertyStanzas [TestStanzas])) - (exDbPkgs db) - | otherwise = [] - targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets - params = addConstraints (fmap toConstraint constraints) - $ addConstraints (fmap toLpc enableTests) - $ addPreferences (fmap toPref prefs) - $ setCountConflicts countConflicts - $ setIndependentGoals indepGoals - $ setReorderGoals reorder - $ setMaxBackjumps mbj - $ setAllowBootLibInstalls allowBootLibInstalls - $ setEnableBackjumping enableBj - $ setSolveExecutables solveExes - $ setGoalOrder goalOrder - $ standardInstallPolicy instIdx avaiIdx targets' - toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown - - toConstraint (ExVersionConstraint scope v) = - toLpc $ PackageConstraint scope (PackagePropertyVersion v) - toConstraint (ExFlagConstraint scope fn b) = - toLpc $ PackageConstraint scope (PackagePropertyFlags (C.mkFlagAssignment [(C.mkFlagName fn, b)])) - toConstraint (ExStanzaConstraint scope stanzas) = - toLpc $ PackageConstraint scope (PackagePropertyStanzas stanzas) - - toPref (ExPkgPref n v) = PackageVersionPreference (C.mkPackageName n) v - toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas - -extractInstallPlan :: CI.SolverInstallPlan.SolverInstallPlan - -> [(ExamplePkgName, ExamplePkgVersion)] -extractInstallPlan = catMaybes . map confPkg . CI.SolverInstallPlan.toList - where - confPkg :: CI.SolverInstallPlan.SolverPlanPackage -> Maybe (String, Int) - confPkg (CI.SolverInstallPlan.Configured pkg) = Just $ srcPkg pkg - confPkg _ = Nothing - - srcPkg :: SolverPackage UnresolvedPkgLoc -> (String, Int) - srcPkg cpkg = - let C.PackageIdentifier pn ver = packageInfoId (solverPkgSource cpkg) - in (C.unPackageName pn, head (C.versionNumbers ver)) - -{------------------------------------------------------------------------------- - Auxiliary --------------------------------------------------------------------------------} - --- | Run Progress computation -runProgress :: Progress step e a -> ([step], Either e a) -runProgress = go - where - go (Step s p) = let (ss, result) = go p in (s:ss, result) - go (Fail e) = ([], Left e) - go (Done a) = ([], Right a) diff --git a/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs +++ /dev/null @@ -1,254 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} --- | Utilities for creating HUnit test cases with the solver DSL. -module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils ( - SolverTest - , SolverResult(..) - , maxBackjumps - , independentGoals - , allowBootLibInstalls - , disableBackjumping - , disableSolveExecutables - , goalOrder - , constraints - , preferences - , enableAllTests - , solverSuccess - , solverFailure - , anySolverFailure - , mkTest - , mkTestExts - , mkTestLangs - , mkTestPCDepends - , mkTestExtLangPC - , runTest - ) where - -import Prelude () -import Distribution.Solver.Compat.Prelude - -import Data.List (elemIndex) -import Data.Ord (comparing) - --- test-framework -import Test.Tasty as TF -import Test.Tasty.HUnit (testCase, assertEqual, assertBool) - --- Cabal -import qualified Distribution.PackageDescription as C -import qualified Distribution.Types.PackageName as C -import Language.Haskell.Extension (Extension(..), Language(..)) - --- cabal-install -import qualified Distribution.Solver.Types.PackagePath as P -import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigDbFromList) -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.Variable -import Distribution.Client.Dependency (foldProgress) -import UnitTests.Distribution.Solver.Modular.DSL -import UnitTests.Options - -maxBackjumps :: Maybe Int -> SolverTest -> SolverTest -maxBackjumps mbj test = test { testMaxBackjumps = mbj } - --- | Combinator to turn on --independent-goals behavior, i.e. solve --- for the goals as if we were solving for each goal independently. -independentGoals :: SolverTest -> SolverTest -independentGoals test = test { testIndepGoals = IndependentGoals True } - -allowBootLibInstalls :: SolverTest -> SolverTest -allowBootLibInstalls test = - test { testAllowBootLibInstalls = AllowBootLibInstalls True } - -disableBackjumping :: SolverTest -> SolverTest -disableBackjumping test = - test { testEnableBackjumping = EnableBackjumping False } - -disableSolveExecutables :: SolverTest -> SolverTest -disableSolveExecutables test = - test { testSolveExecutables = SolveExecutables False } - -goalOrder :: [ExampleVar] -> SolverTest -> SolverTest -goalOrder order test = test { testGoalOrder = Just order } - -constraints :: [ExConstraint] -> SolverTest -> SolverTest -constraints cs test = test { testConstraints = cs } - -preferences :: [ExPreference] -> SolverTest -> SolverTest -preferences prefs test = test { testSoftConstraints = prefs } - -enableAllTests :: SolverTest -> SolverTest -enableAllTests test = test { testEnableAllTests = EnableAllTests True } - -{------------------------------------------------------------------------------- - Solver tests --------------------------------------------------------------------------------} - -data SolverTest = SolverTest { - testLabel :: String - , testTargets :: [String] - , testResult :: SolverResult - , testMaxBackjumps :: Maybe Int - , testIndepGoals :: IndependentGoals - , testAllowBootLibInstalls :: AllowBootLibInstalls - , testEnableBackjumping :: EnableBackjumping - , testSolveExecutables :: SolveExecutables - , testGoalOrder :: Maybe [ExampleVar] - , testConstraints :: [ExConstraint] - , testSoftConstraints :: [ExPreference] - , testDb :: ExampleDb - , testSupportedExts :: Maybe [Extension] - , testSupportedLangs :: Maybe [Language] - , testPkgConfigDb :: PkgConfigDb - , testEnableAllTests :: EnableAllTests - } - --- | Expected result of a solver test. -data SolverResult = SolverResult { - -- | The solver's log should satisfy this predicate. Note that we also print - -- the log, so evaluating a large log here can cause a space leak. - resultLogPredicate :: [String] -> Bool, - - -- | Fails with an error message satisfying the predicate, or succeeds with - -- the given plan. - resultErrorMsgPredicateOrPlan :: Either (String -> Bool) [(String, Int)] - } - -solverSuccess :: [(String, Int)] -> SolverResult -solverSuccess = SolverResult (const True) . Right - -solverFailure :: (String -> Bool) -> SolverResult -solverFailure = SolverResult (const True) . Left - --- | Can be used for test cases where we just want to verify that --- they fail, but do not care about the error message. -anySolverFailure :: SolverResult -anySolverFailure = solverFailure (const True) - --- | Makes a solver test case, consisting of the following components: --- --- 1. An 'ExampleDb', representing the package database (both --- installed and remote) we are doing dependency solving over, --- 2. A 'String' name for the test, --- 3. A list '[String]' of package names to solve for --- 4. The expected result, either 'Nothing' if there is no --- satisfying solution, or a list '[(String, Int)]' of --- packages to install, at which versions. --- --- See 'UnitTests.Distribution.Solver.Modular.DSL' for how --- to construct an 'ExampleDb', as well as definitions of 'db1' etc. --- in this file. -mkTest :: ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest -mkTest = mkTestExtLangPC Nothing Nothing [] - -mkTestExts :: [Extension] - -> ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest -mkTestExts exts = mkTestExtLangPC (Just exts) Nothing [] - -mkTestLangs :: [Language] - -> ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest -mkTestLangs langs = mkTestExtLangPC Nothing (Just langs) [] - -mkTestPCDepends :: [(String, String)] - -> ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest -mkTestPCDepends pkgConfigDb = mkTestExtLangPC Nothing Nothing pkgConfigDb - -mkTestExtLangPC :: Maybe [Extension] - -> Maybe [Language] - -> [(String, String)] - -> ExampleDb - -> String - -> [String] - -> SolverResult - -> SolverTest -mkTestExtLangPC exts langs pkgConfigDb db label targets result = SolverTest { - testLabel = label - , testTargets = targets - , testResult = result - , testMaxBackjumps = Nothing - , testIndepGoals = IndependentGoals False - , testAllowBootLibInstalls = AllowBootLibInstalls False - , testEnableBackjumping = EnableBackjumping True - , testSolveExecutables = SolveExecutables True - , testGoalOrder = Nothing - , testConstraints = [] - , testSoftConstraints = [] - , testDb = db - , testSupportedExts = exts - , testSupportedLangs = langs - , testPkgConfigDb = pkgConfigDbFromList pkgConfigDb - , testEnableAllTests = EnableAllTests False - } - -runTest :: SolverTest -> TF.TestTree -runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) -> - testCase testLabel $ do - let progress = exResolve testDb testSupportedExts - testSupportedLangs testPkgConfigDb testTargets - testMaxBackjumps (CountConflicts True) testIndepGoals - (ReorderGoals False) testAllowBootLibInstalls - testEnableBackjumping testSolveExecutables - (sortGoals <$> testGoalOrder) testConstraints - testSoftConstraints testEnableAllTests - printMsg msg = when showSolverLog $ putStrLn msg - msgs = foldProgress (:) (const []) (const []) progress - assertBool ("Unexpected solver log:\n" ++ unlines msgs) $ - resultLogPredicate testResult $ concatMap lines msgs - result <- foldProgress ((>>) . printMsg) (return . Left) (return . Right) progress - case result of - Left err -> assertBool ("Unexpected error:\n" ++ err) - (checkErrorMsg testResult err) - Right plan -> assertEqual "" (toMaybe testResult) (Just (extractInstallPlan plan)) - where - toMaybe :: SolverResult -> Maybe [(String, Int)] - toMaybe = either (const Nothing) Just . resultErrorMsgPredicateOrPlan - - checkErrorMsg :: SolverResult -> String -> Bool - checkErrorMsg result msg = - case resultErrorMsgPredicateOrPlan result of - Left f -> f msg - Right _ -> False - - sortGoals :: [ExampleVar] - -> Variable P.QPN -> Variable P.QPN -> Ordering - sortGoals = orderFromList . map toVariable - - -- Sort elements in the list ahead of elements not in the list. Otherwise, - -- follow the order in the list. - orderFromList :: Eq a => [a] -> a -> a -> Ordering - orderFromList xs = - comparing $ \x -> let i = elemIndex x xs in (isNothing i, i) - - toVariable :: ExampleVar -> Variable P.QPN - toVariable (P q pn) = PackageVar (toQPN q pn) - toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.mkFlagName fn) - toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza - - toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN - toQPN q pn = P.Q pp (C.mkPackageName pn) - where - pp = case q of - QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel - QualIndep p -> P.PackagePath (P.Independent $ C.mkPackageName p) - P.QualToplevel - QualSetup s -> P.PackagePath P.DefaultNamespace - (P.QualSetup (C.mkPackageName s)) - QualIndepSetup p s -> P.PackagePath (P.Independent $ C.mkPackageName p) - (P.QualSetup (C.mkPackageName s)) - QualExe p1 p2 -> P.PackagePath P.DefaultNamespace - (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2)) diff --git a/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs b/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs +++ /dev/null @@ -1,191 +0,0 @@ --- | Tests for detecting space leaks in the dependency solver. -module UnitTests.Distribution.Solver.Modular.MemoryUsage (tests) where - -import Test.Tasty (TestTree) - -import UnitTests.Distribution.Solver.Modular.DSL -import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils - -tests :: [TestTree] -tests = [ - runTest $ basicTest "basic space leak test" - , runTest $ flagsTest "package with many flags" - , runTest $ issue2899 "issue #2899" - , runTest $ duplicateDependencies "duplicate dependencies" - , runTest $ duplicateFlaggedDependencies "duplicate flagged dependencies" - ] - --- | This test solves for n packages that each have two versions. There is no --- solution, because the nth package depends on another package that doesn't fit --- its version constraint. Backjumping is disabled, so the solver must explore a --- search tree of size 2^n. It should fail if memory usage is proportional to --- the size of the tree. -basicTest :: String -> SolverTest -basicTest name = - disableBackjumping $ mkTest pkgs name ["target"] anySolverFailure - where - n :: Int - n = 18 - - pkgs :: ExampleDb - pkgs = map Right $ - [ exAv "target" 1 [ExAny $ pkgName 1]] - ++ [ exAv (pkgName i) v [ExRange (pkgName $ i + 1) 2 4] - | i <- [1..n], v <- [2, 3]] - ++ [exAv (pkgName $ n + 1) 1 []] - - pkgName :: Int -> ExamplePkgName - pkgName x = "pkg-" ++ show x - --- | This test is similar to 'basicTest', except that it has one package with n --- flags, flag-1 through flag-n. The solver assigns flags in order, so it --- doesn't discover the unknown dependencies under flag-n until it has assigned --- all of the flags. It has to explore the whole search tree. -flagsTest :: String -> SolverTest -flagsTest name = - disableBackjumping $ - goalOrder orderedFlags $ mkTest pkgs name ["pkg"] anySolverFailure - where - n :: Int - n = 16 - - pkgs :: ExampleDb - pkgs = [Right $ exAv "pkg" 1 $ - [exFlagged (numberedFlag n) [ExAny "unknown1"] [ExAny "unknown2"]] - - -- The remaining flags have no effect: - ++ [exFlagged (numberedFlag i) [] [] | i <- [1..n - 1]] - ] - - orderedFlags :: [ExampleVar] - orderedFlags = [F QualNone "pkg" (numberedFlag i) | i <- [1..n]] - --- | Test for a space leak caused by sharing of search trees under packages with --- link choices (issue #2899). --- --- The goal order is fixed so that the solver chooses setup-dep and then --- target-setup.setup-dep at the top of the search tree. target-setup.setup-dep --- has two choices: link to setup-dep, and don't link to setup-dep. setup-dep --- has a long chain of dependencies (pkg-1 through pkg-n). However, pkg-n --- depends on pkg-n+1, which doesn't exist, so there is no solution. Since each --- dependency has two versions, the solver must try 2^n combinations when --- backjumping is disabled. These combinations create large search trees under --- each of the two choices for target-setup.setup-dep. Although the choice to --- not link is disallowed by the Single Instance Restriction, the solver doesn't --- know that until it has explored (and evaluated) the whole tree under the --- choice to link. If the two trees are shared, memory usage spikes. -issue2899 :: String -> SolverTest -issue2899 name = - disableBackjumping $ - goalOrder goals $ mkTest pkgs name ["target"] anySolverFailure - where - n :: Int - n = 16 - - pkgs :: ExampleDb - pkgs = map Right $ - [ exAv "target" 1 [ExAny "setup-dep"] `withSetupDeps` [ExAny "setup-dep"] - , exAv "setup-dep" 1 [ExAny $ pkgName 1]] - ++ [ exAv (pkgName i) v [ExAny $ pkgName (i + 1)] - | i <- [1..n], v <- [1, 2]] - - pkgName :: Int -> ExamplePkgName - pkgName x = "pkg-" ++ show x - - goals :: [ExampleVar] - goals = [P QualNone "setup-dep", P (QualSetup "target") "setup-dep"] - --- | Test for an issue related to lifting dependencies out of conditionals when --- converting a PackageDescription to the solver's internal representation. --- --- Issue: --- For each conditional and each package B, the solver combined each dependency --- on B in the true branch with each dependency on B in the false branch. It --- added the combined dependencies to the build-depends outside of the --- conditional. Since dependencies could be lifted out of multiple levels of --- conditionals, the number of new dependencies could grow exponentially in the --- number of levels. For example, the following package generated 4 copies of B --- under flag-2=False, 8 copies under flag-1=False, and 16 copies at the top --- level: --- --- if flag(flag-1) --- build-depends: B, B --- else --- if flag(flag-2) --- build-depends: B, B --- else --- if flag(flag-3) --- build-depends: B, B --- else --- build-depends: B, B --- --- This issue caused the quickcheck tests to start frequently running out of --- memory after an optimization that pruned unreachable branches (See PR #4929). --- Each problematic test case contained at least one build-depends field with --- duplicate dependencies, which was then duplicated under multiple levels of --- conditionals by the solver's "buildable: False" transformation, when --- "buildable: False" was under multiple flags. Finally, the branch pruning --- feature put all build-depends fields in consecutive levels of the condition --- tree, causing the solver's representation of the package to follow the --- pattern in the example above. --- --- Now the solver avoids this issue by combining all dependencies on the same --- package before lifting them out of conditionals. --- --- This test case is an expanded version of the example above, with library and --- build-tool dependencies. -duplicateDependencies :: String -> SolverTest -duplicateDependencies name = - mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)] - where - copies, depth :: Int - copies = 50 - depth = 50 - - pkgs :: ExampleDb - pkgs = [ - Right $ exAv "A" 1 (dependencyTree 1) - , Right $ exAv "B" 1 [] `withExe` ExExe "exe" [] - ] - - dependencyTree :: Int -> [ExampleDependency] - dependencyTree n - | n > depth = buildDepends - | otherwise = [exFlagged (numberedFlag n) buildDepends - (dependencyTree (n + 1))] - where - buildDepends = replicate copies (ExFix "B" 1) - ++ replicate copies (ExBuildToolFix "B" "exe" 1) - --- | This test is similar to duplicateDependencies, except that every dependency --- on B is replaced by a conditional that contains B in both branches. It tests --- that the solver doesn't just combine dependencies within one build-depends or --- build-tool-depends field; it also needs to combine dependencies after they --- are lifted out of conditionals. -duplicateFlaggedDependencies :: String -> SolverTest -duplicateFlaggedDependencies name = - mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)] - where - copies, depth :: Int - copies = 15 - depth = 15 - - pkgs :: ExampleDb - pkgs = [ - Right $ exAv "A" 1 (dependencyTree 1) - , Right $ exAv "B" 1 [] `withExe` ExExe "exe" [] - ] - - dependencyTree :: Int -> [ExampleDependency] - dependencyTree n - | n > depth = flaggedDeps - | otherwise = [exFlagged (numberedFlag n) flaggedDeps - (dependencyTree (n + 1))] - where - flaggedDeps = zipWith ($) (replicate copies flaggedDep) [0 :: Int ..] - flaggedDep m = exFlagged (numberedFlag n ++ "-" ++ show m) buildDepends - buildDepends - buildDepends = [ExFix "B" 1, ExBuildToolFix "B" "exe" 1] - -numberedFlag :: Int -> ExampleFlagName -numberedFlag n = "flag-" ++ show n diff --git a/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ /dev/null @@ -1,492 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module UnitTests.Distribution.Solver.Modular.QuickCheck (tests) where - -import Prelude () -import Distribution.Client.Compat.Prelude - -import Control.Arrow ((&&&)) -import Control.DeepSeq (force) -import Data.Either (lefts) -import Data.Function (on) -import Data.Hashable (Hashable(..)) -import Data.List (groupBy, isInfixOf) -import Data.Ord (comparing) - -import Text.Show.Pretty (parseValue, valToStr) - -import Test.Tasty (TestTree) -import Test.Tasty.QuickCheck - -import Distribution.Types.GenericPackageDescription (FlagName) -import Distribution.Utils.ShortText (ShortText) - -import Distribution.Client.Setup (defaultMaxBackjumps) - -import Distribution.Types.PackageName -import Distribution.Types.UnqualComponentName - -import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Solver.Types.ComponentDeps - ( Component(..), ComponentDep, ComponentDeps ) -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageConstraint -import qualified Distribution.Solver.Types.PackagePath as P -import Distribution.Solver.Types.PkgConfigDb - (pkgConfigDbFromList) -import Distribution.Solver.Types.Settings -import Distribution.Solver.Types.Variable -import Distribution.Version - -import UnitTests.Distribution.Solver.Modular.DSL -import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils - ( testPropertyWithSeed ) - -tests :: [TestTree] -tests = [ - -- This test checks that certain solver parameters do not affect the - -- existence of a solution. It runs the solver twice, and only sets those - -- parameters on the second run. The test also applies parameters that - -- can affect the existence of a solution to both runs. - testPropertyWithSeed "target and goal order do not affect solvability" $ - \test targetOrder mGoalOrder1 mGoalOrder2 indepGoals -> - let r1 = solve' mGoalOrder1 test - r2 = solve' mGoalOrder2 test { testTargets = targets2 } - solve' goalOrder = - solve (EnableBackjumping True) (ReorderGoals False) - (CountConflicts True) indepGoals - (getBlind <$> goalOrder) - targets = testTargets test - targets2 = case targetOrder of - SameOrder -> targets - ReverseOrder -> reverse targets - in counterexample (showResults r1 r2) $ - noneReachedBackjumpLimit [r1, r2] ==> - isRight (resultPlan r1) === isRight (resultPlan r2) - - , testPropertyWithSeed - "solvable without --independent-goals => solvable with --independent-goals" $ - \test reorderGoals -> - let r1 = solve' (IndependentGoals False) test - r2 = solve' (IndependentGoals True) test - solve' indep = solve (EnableBackjumping True) reorderGoals - (CountConflicts True) indep Nothing - in counterexample (showResults r1 r2) $ - noneReachedBackjumpLimit [r1, r2] ==> - isRight (resultPlan r1) `implies` isRight (resultPlan r2) - - , testPropertyWithSeed "backjumping does not affect solvability" $ - \test reorderGoals indepGoals -> - let r1 = solve' (EnableBackjumping True) test - r2 = solve' (EnableBackjumping False) test - solve' enableBj = solve enableBj reorderGoals - (CountConflicts True) indepGoals Nothing - in counterexample (showResults r1 r2) $ - noneReachedBackjumpLimit [r1, r2] ==> - isRight (resultPlan r1) === isRight (resultPlan r2) - - -- This test uses --no-count-conflicts, because the goal order used with - -- --count-conflicts depends on the total set of conflicts seen by the - -- solver. The solver explores more of the tree and encounters more - -- conflicts when it doesn't backjump. The different goal orders can lead to - -- different solutions and cause the test to fail. - -- TODO: Find a faster way to randomly sort goals, and then use a random - -- goal order in this test. - , testPropertyWithSeed - "backjumping does not affect the result (with static goal order)" $ - \test reorderGoals indepGoals -> - let r1 = solve' (EnableBackjumping True) test - r2 = solve' (EnableBackjumping False) test - solve' enableBj = solve enableBj reorderGoals - (CountConflicts False) indepGoals Nothing - in counterexample (showResults r1 r2) $ - noneReachedBackjumpLimit [r1, r2] ==> - resultPlan r1 === resultPlan r2 - ] - where - noneReachedBackjumpLimit :: [Result] -> Bool - noneReachedBackjumpLimit = - not . any (\r -> resultPlan r == Left BackjumpLimitReached) - - showResults :: Result -> Result -> String - showResults r1 r2 = showResult 1 r1 ++ showResult 2 r2 - - showResult :: Int -> Result -> String - showResult n result = - unlines $ ["", "Run " ++ show n ++ ":"] - ++ resultLog result - ++ ["result: " ++ show (resultPlan result)] - - implies :: Bool -> Bool -> Bool - implies x y = not x || y - - isRight :: Either a b -> Bool - isRight (Right _) = True - isRight _ = False - -newtype VarOrdering = VarOrdering { - unVarOrdering :: Variable P.QPN -> Variable P.QPN -> Ordering - } - -solve :: EnableBackjumping -> ReorderGoals -> CountConflicts -> IndependentGoals - -> Maybe VarOrdering - -> SolverTest -> Result -solve enableBj reorder countConflicts indep goalOrder test = - let (lg, result) = - runProgress $ exResolve (unTestDb (testDb test)) Nothing Nothing - (pkgConfigDbFromList []) - (map unPN (testTargets test)) - -- The backjump limit prevents individual tests from using - -- too much time and memory. - (Just defaultMaxBackjumps) - countConflicts indep reorder (AllowBootLibInstalls False) - enableBj (SolveExecutables True) (unVarOrdering <$> goalOrder) - (testConstraints test) (testPreferences test) - (EnableAllTests False) - - failure :: String -> Failure - failure msg - | "Backjump limit reached" `isInfixOf` msg = BackjumpLimitReached - | otherwise = OtherFailure - in Result { - resultLog = lg - , resultPlan = - -- Force the result so that we check for internal errors when we check - -- for success or failure. See D.C.Dependency.validateSolverResult. - force $ either (Left . failure) (Right . extractInstallPlan) result - } - --- | How to modify the order of the input targets. -data TargetOrder = SameOrder | ReverseOrder - deriving Show - -instance Arbitrary TargetOrder where - arbitrary = elements [SameOrder, ReverseOrder] - - shrink SameOrder = [] - shrink ReverseOrder = [SameOrder] - -data Result = Result { - resultLog :: [String] - , resultPlan :: Either Failure [(ExamplePkgName, ExamplePkgVersion)] - } - -data Failure = BackjumpLimitReached | OtherFailure - deriving (Eq, Generic, Show) - -instance NFData Failure - --- | Package name. -newtype PN = PN { unPN :: String } - deriving (Eq, Ord, Show) - -instance Arbitrary PN where - arbitrary = PN <$> elements ("base" : [[pn] | pn <- ['A'..'G']]) - --- | Package version. -newtype PV = PV { unPV :: Int } - deriving (Eq, Ord, Show) - -instance Arbitrary PV where - arbitrary = PV <$> elements [1..10] - -type TestPackage = Either ExampleInstalled ExampleAvailable - -getName :: TestPackage -> PN -getName = PN . either exInstName exAvName - -getVersion :: TestPackage -> PV -getVersion = PV . either exInstVersion exAvVersion - -data SolverTest = SolverTest { - testDb :: TestDb - , testTargets :: [PN] - , testConstraints :: [ExConstraint] - , testPreferences :: [ExPreference] - } - --- | Pretty-print the test when quickcheck calls 'show'. -instance Show SolverTest where - show test = - let str = "SolverTest {testDb = " ++ show (testDb test) - ++ ", testTargets = " ++ show (testTargets test) - ++ ", testConstraints = " ++ show (testConstraints test) - ++ ", testPreferences = " ++ show (testPreferences test) - ++ "}" - in maybe str valToStr $ parseValue str - -instance Arbitrary SolverTest where - arbitrary = do - db <- arbitrary - let pkgVersions = nub $ map (getName &&& getVersion) (unTestDb db) - pkgs = nub $ map fst pkgVersions - Positive n <- arbitrary - targets <- randomSubset n pkgs - constraints <- case pkgVersions of - [] -> return [] - _ -> boundedListOf 1 $ arbitraryConstraint pkgVersions - prefs <- case pkgVersions of - [] -> return [] - _ -> boundedListOf 3 $ arbitraryPreference pkgVersions - return (SolverTest db targets constraints prefs) - - shrink test = - [test { testDb = db } | db <- shrink (testDb test)] - ++ [test { testTargets = targets } | targets <- shrink (testTargets test)] - ++ [test { testConstraints = cs } | cs <- shrink (testConstraints test)] - ++ [test { testPreferences = prefs } | prefs <- shrink (testPreferences test)] - --- | Collection of source and installed packages. -newtype TestDb = TestDb { unTestDb :: ExampleDb } - deriving Show - -instance Arbitrary TestDb where - arbitrary = do - -- Avoid cyclic dependencies by grouping packages by name and only - -- allowing each package to depend on packages in the groups before it. - groupedPkgs <- shuffle . groupBy ((==) `on` fst) . nub . sort =<< - boundedListOf 10 arbitrary - db <- foldM nextPkgs (TestDb []) groupedPkgs - TestDb <$> shuffle (unTestDb db) - where - nextPkgs :: TestDb -> [(PN, PV)] -> Gen TestDb - nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> traverse (nextPkg db) pkgs - - nextPkg :: TestDb -> (PN, PV) -> Gen TestPackage - nextPkg db (pn, v) = do - installed <- arbitrary - if installed - then Left <$> arbitraryExInst pn v (lefts $ unTestDb db) - else Right <$> arbitraryExAv pn v db - - shrink (TestDb pkgs) = map TestDb $ shrink pkgs - -arbitraryExAv :: PN -> PV -> TestDb -> Gen ExampleAvailable -arbitraryExAv pn v db = - (\cds -> ExAv (unPN pn) (unPV v) cds []) <$> arbitraryComponentDeps db - -arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled -arbitraryExInst pn v pkgs = do - pkgHash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] - numDeps <- min 3 <$> arbitrary - deps <- randomSubset numDeps pkgs - return $ ExInst (unPN pn) (unPV v) pkgHash (map exInstHash deps) - -arbitraryComponentDeps :: TestDb -> Gen (ComponentDeps [ExampleDependency]) -arbitraryComponentDeps (TestDb []) = return $ CD.fromList [] -arbitraryComponentDeps db = - -- dedupComponentNames removes components with duplicate names, for example, - -- 'ComponentExe x' and 'ComponentTest x', and then CD.fromList combines - -- duplicate unnamed components. - CD.fromList . dedupComponentNames <$> - boundedListOf 5 (arbitraryComponentDep db) - where - dedupComponentNames = - nubBy ((\x y -> isJust x && isJust y && x == y) `on` componentName . fst) - - componentName :: Component -> Maybe UnqualComponentName - componentName ComponentLib = Nothing - componentName ComponentSetup = Nothing - componentName (ComponentSubLib n) = Just n - componentName (ComponentFLib n) = Just n - componentName (ComponentExe n) = Just n - componentName (ComponentTest n) = Just n - componentName (ComponentBench n) = Just n - -arbitraryComponentDep :: TestDb -> Gen (ComponentDep [ExampleDependency]) -arbitraryComponentDep db = do - comp <- arbitrary - deps <- case comp of - ComponentSetup -> smallListOf (arbitraryExDep db SetupDep) - _ -> boundedListOf 5 (arbitraryExDep db NonSetupDep) - return (comp, deps) - --- | Location of an 'ExampleDependency'. It determines which values are valid. -data ExDepLocation = SetupDep | NonSetupDep - -arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency -arbitraryExDep db@(TestDb pkgs) level = - let flag = ExFlagged <$> arbitraryFlagName - <*> arbitraryDeps db - <*> arbitraryDeps db - other = - -- Package checks require dependencies on "base" to have bounds. - let notBase = filter ((/= PN "base") . getName) pkgs - in [ExAny . unPN <$> elements (map getName notBase) | not (null notBase)] - ++ [ - -- existing version - let fixed pkg = ExFix (unPN $ getName pkg) (unPV $ getVersion pkg) - in fixed <$> elements pkgs - - -- random version of an existing package - , ExFix . unPN . getName <$> elements pkgs <*> (unPV <$> arbitrary) - ] - in oneof $ - case level of - NonSetupDep -> flag : other - SetupDep -> other - -arbitraryDeps :: TestDb -> Gen Dependencies -arbitraryDeps db = frequency - [ (1, return NotBuildable) - , (20, Buildable <$> smallListOf (arbitraryExDep db NonSetupDep)) - ] - -arbitraryFlagName :: Gen String -arbitraryFlagName = (:[]) <$> elements ['A'..'E'] - -arbitraryConstraint :: [(PN, PV)] -> Gen ExConstraint -arbitraryConstraint pkgs = do - (PN pn, v) <- elements pkgs - let anyQualifier = ScopeAnyQualifier (mkPackageName pn) - oneof [ - ExVersionConstraint anyQualifier <$> arbitraryVersionRange v - , ExStanzaConstraint anyQualifier <$> sublistOf [TestStanzas, BenchStanzas] - ] - -arbitraryPreference :: [(PN, PV)] -> Gen ExPreference -arbitraryPreference pkgs = do - (PN pn, v) <- elements pkgs - oneof [ - ExStanzaPref pn <$> sublistOf [TestStanzas, BenchStanzas] - , ExPkgPref pn <$> arbitraryVersionRange v - ] - -arbitraryVersionRange :: PV -> Gen VersionRange -arbitraryVersionRange (PV v) = - let version = mkSimpleVersion v - in elements [ - thisVersion version - , notThisVersion version - , earlierVersion version - , orLaterVersion version - , noVersion - ] - -instance Arbitrary ReorderGoals where - arbitrary = ReorderGoals <$> arbitrary - - shrink (ReorderGoals reorder) = [ReorderGoals False | reorder] - -instance Arbitrary IndependentGoals where - arbitrary = IndependentGoals <$> arbitrary - - shrink (IndependentGoals indep) = [IndependentGoals False | indep] - -instance Arbitrary UnqualComponentName where - arbitrary = mkUnqualComponentName <$> (:[]) <$> elements "ABC" - -instance Arbitrary Component where - arbitrary = oneof [ return ComponentLib - , ComponentSubLib <$> arbitrary - , ComponentExe <$> arbitrary - , ComponentFLib <$> arbitrary - , ComponentTest <$> arbitrary - , ComponentBench <$> arbitrary - , return ComponentSetup - ] - - shrink ComponentLib = [] - shrink _ = [ComponentLib] - -instance Arbitrary ExampleInstalled where - arbitrary = error "arbitrary not implemented: ExampleInstalled" - - shrink ei = [ ei { exInstBuildAgainst = deps } - | deps <- shrinkList shrinkNothing (exInstBuildAgainst ei)] - -instance Arbitrary ExampleAvailable where - arbitrary = error "arbitrary not implemented: ExampleAvailable" - - shrink ea = [ea { exAvDeps = deps } | deps <- shrink (exAvDeps ea)] - -instance (Arbitrary a, Monoid a) => Arbitrary (ComponentDeps a) where - arbitrary = error "arbitrary not implemented: ComponentDeps" - - shrink = map CD.fromList . shrink . CD.toList - -instance Arbitrary ExampleDependency where - arbitrary = error "arbitrary not implemented: ExampleDependency" - - shrink (ExAny _) = [] - shrink (ExFix "base" _) = [] -- preserve bounds on base - shrink (ExFix pn _) = [ExAny pn] - shrink (ExFlagged flag th el) = - deps th ++ deps el - ++ [ExFlagged flag th' el | th' <- shrink th] - ++ [ExFlagged flag th el' | el' <- shrink el] - where - deps NotBuildable = [] - deps (Buildable ds) = ds - shrink dep = error $ "Dependency not handled: " ++ show dep - -instance Arbitrary Dependencies where - arbitrary = error "arbitrary not implemented: Dependencies" - - shrink NotBuildable = [Buildable []] - shrink (Buildable deps) = map Buildable (shrink deps) - -instance Arbitrary ExConstraint where - arbitrary = error "arbitrary not implemented: ExConstraint" - - shrink (ExStanzaConstraint scope stanzas) = - [ExStanzaConstraint scope stanzas' | stanzas' <- shrink stanzas] - shrink (ExVersionConstraint scope vr) = - [ExVersionConstraint scope vr' | vr' <- shrink vr] - shrink _ = [] - -instance Arbitrary ExPreference where - arbitrary = error "arbitrary not implemented: ExPreference" - - shrink (ExStanzaPref pn stanzas) = - [ExStanzaPref pn stanzas' | stanzas' <- shrink stanzas] - shrink (ExPkgPref pn vr) = [ExPkgPref pn vr' | vr' <- shrink vr] - -instance Arbitrary OptionalStanza where - arbitrary = error "arbitrary not implemented: OptionalStanza" - - shrink BenchStanzas = [TestStanzas] - shrink TestStanzas = [] - -instance Arbitrary VersionRange where - arbitrary = error "arbitrary not implemented: VersionRange" - - shrink vr = [noVersion | vr /= noVersion] - --- Randomly sorts solver variables using 'hash'. --- TODO: Sorting goals with this function is very slow. -instance Arbitrary VarOrdering where - arbitrary = do - f <- arbitrary :: Gen (Int -> Int) - return $ VarOrdering (comparing (f . hash)) - -instance Hashable pn => Hashable (Variable pn) -instance Hashable a => Hashable (P.Qualified a) -instance Hashable P.PackagePath -instance Hashable P.Qualifier -instance Hashable P.Namespace -instance Hashable OptionalStanza -instance Hashable FlagName -instance Hashable PackageName -instance Hashable ShortText - -deriving instance Generic (Variable pn) -deriving instance Generic (P.Qualified a) -deriving instance Generic P.PackagePath -deriving instance Generic P.Namespace -deriving instance Generic P.Qualifier - -randomSubset :: Int -> [a] -> Gen [a] -randomSubset n xs = take n <$> shuffle xs - -boundedListOf :: Int -> Gen a -> Gen [a] -boundedListOf n gen = take n <$> listOf gen - --- | Generates lists with average length less than 1. -smallListOf :: Gen a -> Gen [a] -smallListOf gen = - frequency [ (fr, vectorOf n gen) - | (fr, n) <- [(3, 0), (5, 1), (2, 2)]] diff --git a/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs b/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs +++ /dev/null @@ -1,33 +0,0 @@ -module UnitTests.Distribution.Solver.Modular.QuickCheck.Utils ( - testPropertyWithSeed - ) where - -import Data.Tagged (Tagged, retag) -import System.Random (getStdRandom, random) - -import Test.Tasty (TestTree) -import Test.Tasty.Options (OptionDescription, lookupOption, setOption) -import Test.Tasty.Providers (IsTest (..), singleTest) -import Test.Tasty.QuickCheck - ( QC (..), QuickCheckReplay (..), Testable, property ) - -import Distribution.Simple.Utils -import Distribution.Verbosity - --- | Create a QuickCheck test that prints the seed before testing the property. --- The seed can be useful for debugging non-terminating test cases. This is --- related to https://github.com/feuerbach/tasty/issues/86. -testPropertyWithSeed :: Testable a => String -> a -> TestTree -testPropertyWithSeed name = singleTest name . QCWithSeed . QC . property - -newtype QCWithSeed = QCWithSeed QC - -instance IsTest QCWithSeed where - testOptions = retag (testOptions :: Tagged QC [OptionDescription]) - - run options (QCWithSeed test) progress = do - replay <- case lookupOption options of - QuickCheckReplay (Just override) -> return override - QuickCheckReplay Nothing -> getStdRandom random - notice normal $ "Using --quickcheck-replay=" ++ show replay - run (setOption (QuickCheckReplay (Just replay)) options) test progress diff --git a/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs b/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module UnitTests.Distribution.Solver.Modular.RetryLog ( - tests - ) where - -import Distribution.Solver.Modular.Message -import Distribution.Solver.Modular.RetryLog -import Distribution.Solver.Types.Progress - -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase, (@?=)) -import Test.Tasty.QuickCheck - ( Arbitrary(..), Blind(..), listOf, oneof, testProperty, (===)) - -type Log a = Progress a String String - -tests :: [TestTree] -tests = [ - testProperty "'toProgress . fromProgress' is identity" $ \p -> - toProgress (fromProgress p) === (p :: Log Int) - - , testProperty "'mapFailure f' is like 'foldProgress Step (Fail . f) Done'" $ - let mapFailureProgress f = foldProgress Step (Fail . f) Done - in \(Blind f) p -> - toProgress (mapFailure f (fromProgress p)) - === mapFailureProgress (f :: String -> Int) (p :: Log Int) - - , testProperty "'retry p f' is like 'foldProgress Step f Done p'" $ - \p (Blind f) -> - toProgress (retry (fromProgress p) (fromProgress . f)) - === (foldProgress Step f Done (p :: Log Int) :: Log Int) - - , testProperty "failWith" $ \step failure -> - toProgress (failWith step failure) - === (Step step (Fail failure) :: Log Int) - - , testProperty "succeedWith" $ \step success -> - toProgress (succeedWith step success) - === (Step step (Done success) :: Log Int) - - , testProperty "continueWith" $ \step p -> - toProgress (continueWith step (fromProgress p)) - === (Step step p :: Log Int) - - , testCase "tryWith with failure" $ - let failure = Fail "Error" - s = Step Success - in toProgress (tryWith Success $ fromProgress (s (s failure))) - @?= (s (Step Enter (s (s (Step Leave failure)))) :: Log Message) - - , testCase "tryWith with success" $ - let done = Done "Done" - s = Step Success - in toProgress (tryWith Success $ fromProgress (s (s done))) - @?= (s (Step Enter (s (s done))) :: Log Message) - ] - -instance (Arbitrary step, Arbitrary fail, Arbitrary done) - => Arbitrary (Progress step fail done) where - arbitrary = do - steps <- listOf arbitrary - end <- oneof [Fail `fmap` arbitrary, Done `fmap` arbitrary] - return $ foldr Step end steps - -deriving instance (Eq step, Eq fail, Eq done) => Eq (Progress step fail done) - -deriving instance (Show step, Show fail, Show done) - => Show (Progress step fail done) - -deriving instance Eq Message -deriving instance Show Message diff --git a/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/tests/UnitTests/Distribution/Solver/Modular/Solver.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Solver/Modular/Solver.hs +++ /dev/null @@ -1,1578 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | This is a set of unit tests for the dependency solver, --- which uses the solver DSL ("UnitTests.Distribution.Solver.Modular.DSL") --- to more conveniently create package databases to run the solver tests on. -module UnitTests.Distribution.Solver.Modular.Solver (tests) - where - --- base -import Data.List (isInfixOf) - -import qualified Distribution.Version as V - --- test-framework -import Test.Tasty as TF - --- Cabal -import Language.Haskell.Extension ( Extension(..) - , KnownExtension(..), Language(..)) - --- cabal-install -import Distribution.Solver.Types.Flag -import Distribution.Solver.Types.OptionalStanza -import Distribution.Solver.Types.PackageConstraint -import qualified Distribution.Solver.Types.PackagePath as P -import UnitTests.Distribution.Solver.Modular.DSL -import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils - -tests :: [TF.TestTree] -tests = [ - testGroup "Simple dependencies" [ - runTest $ mkTest db1 "alreadyInstalled" ["A"] (solverSuccess []) - , runTest $ mkTest db1 "installLatest" ["B"] (solverSuccess [("B", 2)]) - , runTest $ mkTest db1 "simpleDep1" ["C"] (solverSuccess [("B", 1), ("C", 1)]) - , runTest $ mkTest db1 "simpleDep2" ["D"] (solverSuccess [("B", 2), ("D", 1)]) - , runTest $ mkTest db1 "failTwoVersions" ["C", "D"] anySolverFailure - , runTest $ indep $ mkTest db1 "indepTwoVersions" ["C", "D"] (solverSuccess [("B", 1), ("B", 2), ("C", 1), ("D", 1)]) - , runTest $ indep $ mkTest db1 "aliasWhenPossible1" ["C", "E"] (solverSuccess [("B", 1), ("C", 1), ("E", 1)]) - , runTest $ indep $ mkTest db1 "aliasWhenPossible2" ["D", "E"] (solverSuccess [("B", 2), ("D", 1), ("E", 1)]) - , runTest $ indep $ mkTest db2 "aliasWhenPossible3" ["C", "D"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("C", 1), ("D", 1)]) - , runTest $ mkTest db1 "buildDepAgainstOld" ["F"] (solverSuccess [("B", 1), ("E", 1), ("F", 1)]) - , runTest $ mkTest db1 "buildDepAgainstNew" ["G"] (solverSuccess [("B", 2), ("E", 1), ("G", 1)]) - , runTest $ indep $ mkTest db1 "multipleInstances" ["F", "G"] anySolverFailure - , runTest $ mkTest db21 "unknownPackage1" ["A"] (solverSuccess [("A", 1), ("B", 1)]) - , runTest $ mkTest db22 "unknownPackage2" ["A"] (solverFailure (isInfixOf "unknown package: C")) - , runTest $ mkTest db23 "unknownPackage3" ["A"] (solverFailure (isInfixOf "unknown package: B")) - ] - , testGroup "Flagged dependencies" [ - runTest $ mkTest db3 "forceFlagOn" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ mkTest db3 "forceFlagOff" ["D"] (solverSuccess [("A", 2), ("B", 1), ("D", 1)]) - , runTest $ indep $ mkTest db3 "linkFlags1" ["C", "D"] anySolverFailure - , runTest $ indep $ mkTest db4 "linkFlags2" ["C", "D"] anySolverFailure - , runTest $ indep $ mkTest db18 "linkFlags3" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)]) - ] - , testGroup "Lifting dependencies out of conditionals" [ - runTest $ commonDependencyLogMessage "common dependency log message" - , runTest $ twoLevelDeepCommonDependencyLogMessage "two level deep common dependency log message" - , runTest $ testBackjumpingWithCommonDependency "backjumping with common dependency" - ] - , testGroup "Manual flags" [ - runTest $ mkTest dbManualFlags "Use default value for manual flag" ["pkg"] $ - solverSuccess [("pkg", 1), ("true-dep", 1)] - - , let checkFullLog = - any $ isInfixOf "rejecting: pkg:-flag (manual flag can only be changed explicitly)" - in runTest $ constraints [ExVersionConstraint (ScopeAnyQualifier "true-dep") V.noVersion] $ - mkTest dbManualFlags "Don't toggle manual flag to avoid conflict" ["pkg"] $ - -- TODO: We should check the summarized log instead of the full log - -- for the manual flags error message, but it currently only - -- appears in the full log. - SolverResult checkFullLog (Left $ const True) - - , let cs = [ExFlagConstraint (ScopeAnyQualifier "pkg") "flag" False] - in runTest $ constraints cs $ - mkTest dbManualFlags "Toggle manual flag with flag constraint" ["pkg"] $ - solverSuccess [("false-dep", 1), ("pkg", 1)] - ] - , testGroup "Qualified manual flag constraints" [ - let name = "Top-level flag constraint does not constrain setup dep's flag" - cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False] - in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ - solverSuccess [ ("A", 1), ("B", 1), ("B", 2) - , ("b-1-false-dep", 1), ("b-2-true-dep", 1) ] - - , let name = "Solver can toggle setup dep's flag to match top-level constraint" - cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False - , ExVersionConstraint (ScopeAnyQualifier "b-2-true-dep") V.noVersion ] - in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ - solverSuccess [ ("A", 1), ("B", 1), ("B", 2) - , ("b-1-false-dep", 1), ("b-2-false-dep", 1) ] - - , let name = "User can constrain flags separately with qualified constraints" - cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True - , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False ] - in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $ - solverSuccess [ ("A", 1), ("B", 1), ("B", 2) - , ("b-1-true-dep", 1), ("b-2-false-dep", 1) ] - - -- Regression test for #4299 - , let name = "Solver can link deps when only one has constrained manual flag" - cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False] - in runTest $ constraints cs $ mkTest dbLinkedSetupDepWithManualFlag name ["A"] $ - solverSuccess [ ("A", 1), ("B", 1), ("b-1-false-dep", 1) ] - - , let name = "Solver cannot link deps that have conflicting manual flag constraints" - cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True - , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False ] - failureReason = "(constraint from unknown source requires opposite flag selection)" - checkFullLog lns = - all (\msg -> any (msg `isInfixOf`) lns) - [ "rejecting: B:-flag " ++ failureReason - , "rejecting: A:setup.B:+flag " ++ failureReason ] - in runTest $ constraints cs $ - mkTest dbLinkedSetupDepWithManualFlag name ["A"] $ - SolverResult checkFullLog (Left $ const True) - ] - , testGroup "Stanzas" [ - runTest $ enableAllTests $ mkTest db5 "simpleTest1" ["C"] (solverSuccess [("A", 2), ("C", 1)]) - , runTest $ enableAllTests $ mkTest db5 "simpleTest2" ["D"] anySolverFailure - , runTest $ enableAllTests $ mkTest db5 "simpleTest3" ["E"] (solverSuccess [("A", 1), ("E", 1)]) - , runTest $ enableAllTests $ mkTest db5 "simpleTest4" ["F"] anySolverFailure -- TODO - , runTest $ enableAllTests $ mkTest db5 "simpleTest5" ["G"] (solverSuccess [("A", 2), ("G", 1)]) - , runTest $ enableAllTests $ mkTest db5 "simpleTest6" ["E", "G"] anySolverFailure - , runTest $ indep $ enableAllTests $ mkTest db5 "simpleTest7" ["E", "G"] (solverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)]) - , runTest $ enableAllTests $ mkTest db6 "depsWithTests1" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ indep $ enableAllTests $ mkTest db6 "depsWithTests2" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)]) - , runTest $ testTestSuiteWithFlag "test suite with flag" - ] - , testGroup "Setup dependencies" [ - runTest $ mkTest db7 "setupDeps1" ["B"] (solverSuccess [("A", 2), ("B", 1)]) - , runTest $ mkTest db7 "setupDeps2" ["C"] (solverSuccess [("A", 2), ("C", 1)]) - , runTest $ mkTest db7 "setupDeps3" ["D"] (solverSuccess [("A", 1), ("D", 1)]) - , runTest $ mkTest db7 "setupDeps4" ["E"] (solverSuccess [("A", 1), ("A", 2), ("E", 1)]) - , runTest $ mkTest db7 "setupDeps5" ["F"] (solverSuccess [("A", 1), ("A", 2), ("F", 1)]) - , runTest $ mkTest db8 "setupDeps6" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1)]) - , runTest $ mkTest db9 "setupDeps7" ["F", "G"] (solverSuccess [("A", 1), ("B", 1), ("B",2 ), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)]) - , runTest $ mkTest db10 "setupDeps8" ["C"] (solverSuccess [("C", 1)]) - , runTest $ indep $ mkTest dbSetupDeps "setupDeps9" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)]) - ] - , testGroup "Base shim" [ - runTest $ mkTest db11 "baseShim1" ["A"] (solverSuccess [("A", 1)]) - , runTest $ mkTest db12 "baseShim2" ["A"] (solverSuccess [("A", 1)]) - , runTest $ mkTest db12 "baseShim3" ["B"] (solverSuccess [("B", 1)]) - , runTest $ mkTest db12 "baseShim4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ mkTest db12 "baseShim5" ["D"] anySolverFailure - , runTest $ mkTest db12 "baseShim6" ["E"] (solverSuccess [("E", 1), ("syb", 2)]) - ] - , testGroup "Base" [ - runTest $ mkTest dbBase "Refuse to install base without --allow-boot-library-installs" ["base"] $ - solverFailure (isInfixOf "only already installed instances can be used") - , runTest $ allowBootLibInstalls $ mkTest dbBase "Install base with --allow-boot-library-installs" ["base"] $ - solverSuccess [("base", 1), ("ghc-prim", 1), ("integer-gmp", 1), ("integer-simple", 1)] - ] - , testGroup "Cycles" [ - runTest $ mkTest db14 "simpleCycle1" ["A"] anySolverFailure - , runTest $ mkTest db14 "simpleCycle2" ["A", "B"] anySolverFailure - , runTest $ mkTest db14 "cycleWithFlagChoice1" ["C"] (solverSuccess [("C", 1), ("E", 1)]) - , runTest $ mkTest db15 "cycleThroughSetupDep1" ["A"] anySolverFailure - , runTest $ mkTest db15 "cycleThroughSetupDep2" ["B"] anySolverFailure - , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"] (solverSuccess [("C", 2), ("D", 1)]) - , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"] (solverSuccess [("D", 1)]) - , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"] (solverSuccess [("C", 2), ("D", 1), ("E", 1)]) - , runTest $ issue4161 "detect cycle between package and its setup script" - , runTest $ testCyclicDependencyErrorMessages "cyclic dependency error messages" - ] - , testGroup "Extensions" [ - runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] anySolverFailure - , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] anySolverFailure - , runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (solverSuccess [("A",1)]) - , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedIndirect" ["C"] (solverSuccess [("A",1),("B",1), ("C",1)]) - , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "disabledExtension" ["D"] anySolverFailure - , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "disabledExtension" ["D"] anySolverFailure - , runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedUnknown" ["E"] (solverSuccess [("A",1),("B",1),("C",1),("E",1)]) - ] - , testGroup "Languages" [ - runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupported" ["A"] anySolverFailure - , runTest $ mkTestLangs [Haskell98,Haskell2010] dbLangs1 "supported" ["A"] (solverSuccess [("A",1)]) - , runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] anySolverFailure - , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (solverSuccess [("A",1),("B",1),("C",1)]) - ] - , testGroup "Qualified Package Constraints" [ - runTest $ mkTest dbConstraints "install latest versions without constraints" ["A", "B", "C"] $ - solverSuccess [("A", 7), ("B", 8), ("C", 9), ("D", 7), ("D", 8), ("D", 9)] - - , let cs = [ ExVersionConstraint (ScopeAnyQualifier "D") $ mkVersionRange 1 4 ] - in runTest $ constraints cs $ - mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $ - solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)] - - , let cs = [ ExVersionConstraint (ScopeQualified P.QualToplevel "D") $ mkVersionRange 1 4 - , ExVersionConstraint (ScopeQualified (P.QualSetup "B") "D") $ mkVersionRange 4 7 - ] - in runTest $ constraints cs $ - mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $ - solverSuccess [("A", 1), ("B", 5), ("C", 9), ("D", 1), ("D", 5), ("D", 9)] - - , let cs = [ ExVersionConstraint (ScopeAnySetupQualifier "D") $ mkVersionRange 1 4 ] - in runTest $ constraints cs $ - mkTest dbConstraints "constrain package across setup scripts" ["A", "B", "C"] $ - solverSuccess [("A", 7), ("B", 2), ("C", 3), ("D", 2), ("D", 3), ("D", 7)] - ] - , testGroup "Package Preferences" [ - runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1] $ mkTest db13 "selectPreferredVersionSimple" ["A"] (solverSuccess [("A", 1)]) - , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (solverSuccess [("A", 2)]) - , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2 - , ExPkgPref "A" $ mkvrOrEarlier 1] $ mkTest db13 "selectPreferredVersionMultiple" ["A"] (solverSuccess [("A", 1)]) - , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 1 - , ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple2" ["A"] (solverSuccess [("A", 1)]) - , runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1 - , ExPkgPref "A" $ mkvrThis 2] $ mkTest db13 "selectPreferredVersionMultiple3" ["A"] (solverSuccess [("A", 2)]) - , runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1 - , ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple4" ["A"] (solverSuccess [("A", 1)]) - ] - , testGroup "Stanza Preferences" [ - runTest $ - mkTest dbStanzaPreferences1 "disable tests by default" ["pkg"] $ - solverSuccess [("pkg", 1)] - - , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $ - mkTest dbStanzaPreferences1 "enable tests with testing preference" ["pkg"] $ - solverSuccess [("pkg", 1), ("test-dep", 1)] - - , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $ - mkTest dbStanzaPreferences2 "disable testing when it's not possible" ["pkg"] $ - solverSuccess [("pkg", 1)] - - , testStanzaPreference "test stanza preference" - ] - , testGroup "Buildable Field" [ - testBuildable "avoid building component with unknown dependency" (ExAny "unknown") - , testBuildable "avoid building component with unknown extension" (ExExt (UnknownExtension "unknown")) - , testBuildable "avoid building component with unknown language" (ExLang (UnknownLanguage "unknown")) - , runTest $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (solverSuccess [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)]) - , runTest $ mkTest dbBuildable2 "choose version that sets buildable to false" ["A"] (solverSuccess [("A", 1), ("B", 2)]) - ] - , testGroup "Pkg-config dependencies" [ - runTest $ mkTestPCDepends [] dbPC1 "noPkgs" ["A"] anySolverFailure - , runTest $ mkTestPCDepends [("pkgA", "0")] dbPC1 "tooOld" ["A"] anySolverFailure - , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "1.0.0")] dbPC1 "pruneNotFound" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ mkTestPCDepends [("pkgA", "1.0.0"), ("pkgB", "2.0.0")] dbPC1 "chooseNewest" ["C"] (solverSuccess [("A", 1), ("B", 2), ("C", 1)]) - ] - , testGroup "Independent goals" [ - runTest $ indep $ mkTest db16 "indepGoals1" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("E", 1)]) - , runTest $ testIndepGoals2 "indepGoals2" - , runTest $ testIndepGoals3 "indepGoals3" - , runTest $ testIndepGoals4 "indepGoals4" - , runTest $ testIndepGoals5 "indepGoals5 - fixed goal order" FixedGoalOrder - , runTest $ testIndepGoals5 "indepGoals5 - default goal order" DefaultGoalOrder - , runTest $ testIndepGoals6 "indepGoals6 - fixed goal order" FixedGoalOrder - , runTest $ testIndepGoals6 "indepGoals6 - default goal order" DefaultGoalOrder - ] - -- Tests designed for the backjumping blog post - , testGroup "Backjumping" [ - runTest $ mkTest dbBJ1a "bj1a" ["A"] (solverSuccess [("A", 1), ("B", 1)]) - , runTest $ mkTest dbBJ1b "bj1b" ["A"] (solverSuccess [("A", 1), ("B", 1)]) - , runTest $ mkTest dbBJ1c "bj1c" ["A"] (solverSuccess [("A", 1), ("B", 1)]) - , runTest $ mkTest dbBJ2 "bj2" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ mkTest dbBJ3 "bj3" ["A"] (solverSuccess [("A", 1), ("Ba", 1), ("C", 1)]) - , runTest $ mkTest dbBJ4 "bj4" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ mkTest dbBJ5 "bj5" ["A"] (solverSuccess [("A", 1), ("B", 1), ("D", 1)]) - , runTest $ mkTest dbBJ6 "bj6" ["A"] (solverSuccess [("A", 1), ("B", 1)]) - , runTest $ mkTest dbBJ7 "bj7" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - , runTest $ indep $ mkTest dbBJ8 "bj8" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)]) - ] - -- build-tool-depends dependencies - , testGroup "build-tool-depends" [ - runTest $ mkTest dbBuildTools "simple exe dependency" ["A"] (solverSuccess [("A", 1), ("bt-pkg", 2)]) - - , runTest $ disableSolveExecutables $ - mkTest dbBuildTools "don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)]) - - , runTest $ mkTest dbBuildTools "flagged exe dependency" ["B"] (solverSuccess [("B", 1), ("bt-pkg", 2)]) - - , runTest $ enableAllTests $ - mkTest dbBuildTools "test suite exe dependency" ["C"] (solverSuccess [("C", 1), ("bt-pkg", 2)]) - - , runTest $ mkTest dbBuildTools "unknown exe" ["D"] $ - solverFailure (isInfixOf "does not contain executable unknown-exe, which is required by D") - - , runTest $ disableSolveExecutables $ - mkTest dbBuildTools "don't check for build tool executables in legacy mode" ["D"] $ solverSuccess [("D", 1)] - - , runTest $ mkTest dbBuildTools "unknown build tools package error mentions package, not exe" ["E"] $ - solverFailure (isInfixOf "unknown package: E:unknown-pkg:exe.unknown-pkg (dependency of E)") - - , runTest $ mkTest dbBuildTools "unknown flagged exe" ["F"] $ - solverFailure (isInfixOf "does not contain executable unknown-exe, which is required by F +flagF") - - , runTest $ enableAllTests $ mkTest dbBuildTools "unknown test suite exe" ["G"] $ - solverFailure (isInfixOf "does not contain executable unknown-exe, which is required by G *test") - - , runTest $ mkTest dbBuildTools "wrong exe for build tool package version" ["H"] $ - solverFailure $ isInfixOf $ - -- The solver reports the version conflict when a version conflict - -- and an executable conflict apply to the same package version. - "[__1] rejecting: H:bt-pkg:exe.bt-pkg-4.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)\n" - ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-3.0.0 (does not contain executable exe1, which is required by H)\n" - ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-2.0.0, H:bt-pkg:exe.bt-pkg-1.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)" - - , runTest $ chooseExeAfterBuildToolsPackage True "choose exe after choosing its package - success" - - , runTest $ chooseExeAfterBuildToolsPackage False "choose exe after choosing its package - failure" - - , runTest $ rejectInstalledBuildToolPackage "reject installed package for build-tool dependency" - - , runTest $ requireConsistentBuildToolVersions "build tool versions must be consistent within one package" - ] - -- build-tools dependencies - , testGroup "legacy build-tools" [ - runTest $ mkTest dbLegacyBuildTools1 "bt1" ["A"] (solverSuccess [("A", 1), ("alex", 1)]) - - , runTest $ disableSolveExecutables $ - mkTest dbLegacyBuildTools1 "bt1 - don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)]) - - , runTest $ mkTest dbLegacyBuildTools2 "bt2" ["A"] $ - solverFailure (isInfixOf "does not contain executable alex, which is required by A") - - , runTest $ disableSolveExecutables $ - mkTest dbLegacyBuildTools2 "bt2 - don't check for build tool executables in legacy mode" ["A"] (solverSuccess [("A", 1)]) - - , runTest $ mkTest dbLegacyBuildTools3 "bt3" ["A"] (solverSuccess [("A", 1)]) - - , runTest $ mkTest dbLegacyBuildTools4 "bt4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("alex", 1), ("alex", 2)]) - - , runTest $ mkTest dbLegacyBuildTools5 "bt5" ["B"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("alex", 1)]) - - , runTest $ mkTest dbLegacyBuildTools6 "bt6" ["A"] (solverSuccess [("A", 1), ("alex", 1), ("happy", 1)]) - ] - -- internal dependencies - , testGroup "internal dependencies" [ - runTest $ mkTest dbIssue3775 "issue #3775" ["B"] (solverSuccess [("A", 2), ("B", 2), ("warp", 1)]) - ] - -- Tests for the contents of the solver's log - , testGroup "Solver log" [ - -- See issue #3203. The solver should only choose a version for A once. - runTest $ - let db = [Right $ exAv "A" 1 []] - - p :: [String] -> Bool - p lg = elem "targets: A" lg - && length (filter ("trying: A" `isInfixOf`) lg) == 1 - in mkTest db "deduplicate targets" ["A", "A"] $ - SolverResult p $ Right [("A", 1)] - , runTest $ - let db = [Right $ exAv "A" 1 [ExAny "B"]] - msg = "After searching the rest of the dependency tree exhaustively, " - ++ "these were the goals I've had most trouble fulfilling: A, B" - in mkTest db "exhaustive search failure message" ["A"] $ - solverFailure (isInfixOf msg) - , testSummarizedLog "show conflicts from final conflict set after exhaustive search" Nothing $ - "Could not resolve dependencies:\n" - ++ "[__0] trying: A-1.0.0 (user goal)\n" - ++ "[__1] unknown package: D (dependency of A)\n" - ++ "[__1] fail (backjumping, conflict set: A, D)\n" - ++ "After searching the rest of the dependency tree exhaustively, " - ++ "these were the goals I've had most trouble fulfilling: A, D" - , testSummarizedLog "show first conflicts after inexhaustive search" (Just 2) $ - "Could not resolve dependencies:\n" - ++ "[__0] trying: A-1.0.0 (user goal)\n" - ++ "[__1] trying: B-3.0.0 (dependency of A)\n" - ++ "[__2] next goal: C (dependency of B)\n" - ++ "[__2] rejecting: C-1.0.0 (conflict: B => C==3.0.0)\n" - ++ "Backjump limit reached (currently 2, change with --max-backjumps " - ++ "or try to run with --reorder-goals).\n" - , testSummarizedLog "don't show summarized log when backjump limit is too low" (Just 1) $ - "Backjump limit reached (currently 1, change with --max-backjumps " - ++ "or try to run with --reorder-goals).\n" - ++ "Failed to generate a summarized dependency solver log due to low backjump limit." - ] - ] - where - indep = independentGoals - mkvrThis = V.thisVersion . makeV - mkvrOrEarlier = V.orEarlierVersion . makeV - makeV v = V.mkVersion [v,0,0] - -data GoalOrder = FixedGoalOrder | DefaultGoalOrder - -{------------------------------------------------------------------------------- - Specific example database for the tests --------------------------------------------------------------------------------} - -db1 :: ExampleDb -db1 = - let a = exInst "A" 1 "A-1" [] - in [ Left a - , Right $ exAv "B" 1 [ExAny "A"] - , Right $ exAv "B" 2 [ExAny "A"] - , Right $ exAv "C" 1 [ExFix "B" 1] - , Right $ exAv "D" 1 [ExFix "B" 2] - , Right $ exAv "E" 1 [ExAny "B"] - , Right $ exAv "F" 1 [ExFix "B" 1, ExAny "E"] - , Right $ exAv "G" 1 [ExFix "B" 2, ExAny "E"] - , Right $ exAv "Z" 1 [] - ] - --- In this example, we _can_ install C and D as independent goals, but we have --- to pick two diferent versions for B (arbitrarily) -db2 :: ExampleDb -db2 = [ - Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [] - , Right $ exAv "B" 1 [ExAny "A"] - , Right $ exAv "B" 2 [ExAny "A"] - , Right $ exAv "C" 1 [ExAny "B", ExFix "A" 1] - , Right $ exAv "D" 1 [ExAny "B", ExFix "A" 2] - ] - -db3 :: ExampleDb -db3 = [ - Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [] - , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "A" 1] [ExFix "A" 2]] - , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"] - , Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"] - ] - --- | Like db3, but the flag picks a different package rather than a --- different package version --- --- In db3 we cannot install C and D as independent goals because: --- --- * The multiple instance restriction says C and D _must_ share B --- * Since C relies on A-1, C needs B to be compiled with flagB on --- * Since D relies on A-2, D needs B to be compiled with flagB off --- * Hence C and D have incompatible requirements on B's flags. --- --- However, _even_ if we don't check explicitly that we pick the same flag --- assignment for 0.B and 1.B, we will still detect the problem because --- 0.B depends on 0.A-1, 1.B depends on 1.A-2, hence we cannot link 0.A to --- 1.A and therefore we cannot link 0.B to 1.B. --- --- In db4 the situation however is trickier. We again cannot install --- packages C and D as independent goals because: --- --- * As above, the multiple instance restriction says that C and D _must_ share B --- * Since C relies on Ax-2, it requires B to be compiled with flagB off --- * Since D relies on Ay-2, it requires B to be compiled with flagB on --- * Hence C and D have incompatible requirements on B's flags. --- --- But now this requirement is more indirect. If we only check dependencies --- we don't see the problem: --- --- * We link 0.B to 1.B --- * 0.B relies on Ay-1 --- * 1.B relies on Ax-1 --- --- We will insist that 0.Ay will be linked to 1.Ay, and 0.Ax to 1.Ax, but since --- we only ever assign to one of these, these constraints are never broken. -db4 :: ExampleDb -db4 = [ - Right $ exAv "Ax" 1 [] - , Right $ exAv "Ax" 2 [] - , Right $ exAv "Ay" 1 [] - , Right $ exAv "Ay" 2 [] - , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]] - , Right $ exAv "C" 1 [ExFix "Ax" 2, ExAny "B"] - , Right $ exAv "D" 1 [ExFix "Ay" 2, ExAny "B"] - ] - --- | Simple database containing one package with a manual flag. -dbManualFlags :: ExampleDb -dbManualFlags = [ - Right $ declareFlags [ExFlag "flag" True Manual] $ - exAv "pkg" 1 [exFlagged "flag" [ExAny "true-dep"] [ExAny "false-dep"]] - , Right $ exAv "true-dep" 1 [] - , Right $ exAv "false-dep" 1 [] - ] - --- | Database containing a setup dependency with a manual flag. A's library and --- setup script depend on two different versions of B. B's manual flag can be --- set to different values in the two places where it is used. -dbSetupDepWithManualFlag :: ExampleDb -dbSetupDepWithManualFlag = - let bFlags = [ExFlag "flag" True Manual] - in [ - Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 2] - , Right $ declareFlags bFlags $ - exAv "B" 1 [exFlagged "flag" [ExAny "b-1-true-dep"] - [ExAny "b-1-false-dep"]] - , Right $ declareFlags bFlags $ - exAv "B" 2 [exFlagged "flag" [ExAny "b-2-true-dep"] - [ExAny "b-2-false-dep"]] - , Right $ exAv "b-1-true-dep" 1 [] - , Right $ exAv "b-1-false-dep" 1 [] - , Right $ exAv "b-2-true-dep" 1 [] - , Right $ exAv "b-2-false-dep" 1 [] - ] - --- | A database similar to 'dbSetupDepWithManualFlag', except that the library --- and setup script both depend on B-1. B must be linked because of the Single --- Instance Restriction, and its flag can only have one value. -dbLinkedSetupDepWithManualFlag :: ExampleDb -dbLinkedSetupDepWithManualFlag = [ - Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 1] - , Right $ declareFlags [ExFlag "flag" True Manual] $ - exAv "B" 1 [exFlagged "flag" [ExAny "b-1-true-dep"] - [ExAny "b-1-false-dep"]] - , Right $ exAv "b-1-true-dep" 1 [] - , Right $ exAv "b-1-false-dep" 1 [] - ] - --- | Some tests involving testsuites --- --- Note that in this test framework test suites are always enabled; if you --- want to test without test suites just set up a test database without --- test suites. --- --- * C depends on A (through its test suite) --- * D depends on B-2 (through its test suite), but B-2 is unavailable --- * E depends on A-1 directly and on A through its test suite. We prefer --- to use A-1 for the test suite in this case. --- * F depends on A-1 directly and on A-2 through its test suite. In this --- case we currently fail to install F, although strictly speaking --- test suites should be considered independent goals. --- * G is like E, but for version A-2. This means that if we cannot install --- E and G together, unless we regard them as independent goals. -db5 :: ExampleDb -db5 = [ - Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [] - , Right $ exAv "B" 1 [] - , Right $ exAv "C" 1 [] `withTest` ExTest "testC" [ExAny "A"] - , Right $ exAv "D" 1 [] `withTest` ExTest "testD" [ExFix "B" 2] - , Right $ exAv "E" 1 [ExFix "A" 1] `withTest` ExTest "testE" [ExAny "A"] - , Right $ exAv "F" 1 [ExFix "A" 1] `withTest` ExTest "testF" [ExFix "A" 2] - , Right $ exAv "G" 1 [ExFix "A" 2] `withTest` ExTest "testG" [ExAny "A"] - ] - --- Now the _dependencies_ have test suites --- --- * Installing C is a simple example. C wants version 1 of A, but depends on --- B, and B's testsuite depends on an any version of A. In this case we prefer --- to link (if we don't regard test suites as independent goals then of course --- linking here doesn't even come into it). --- * Installing [C, D] means that we prefer to link B -- depending on how we --- set things up, this means that we should also link their test suites. -db6 :: ExampleDb -db6 = [ - Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [] - , Right $ exAv "B" 1 [] `withTest` ExTest "testA" [ExAny "A"] - , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"] - , Right $ exAv "D" 1 [ExAny "B"] - ] - --- | This test checks that the solver can backjump to disable a flag, even if --- the problematic dependency is also under a test suite. (issue #4390) --- --- The goal order forces the solver to choose the flag before enabling testing. --- Previously, the solver couldn't handle this case, because it only tried to --- disable testing, and when that failed, it backjumped past the flag choice. --- The solver should also try to set the flag to false, because that avoids the --- dependency on B. -testTestSuiteWithFlag :: String -> SolverTest -testTestSuiteWithFlag name = - goalOrder goals $ enableAllTests $ mkTest db name ["A", "B"] $ - solverSuccess [("A", 1), ("B", 1)] - where - db :: ExampleDb - db = [ - Right $ exAv "A" 1 [] - `withTest` - ExTest "test" [exFlagged "flag" [ExFix "B" 2] []] - , Right $ exAv "B" 1 [] - ] - - goals :: [ExampleVar] - goals = [ - P QualNone "B" - , P QualNone "A" - , F QualNone "A" "flag" - , S QualNone "A" TestStanzas - ] - --- Packages with setup dependencies --- --- Install.. --- * B: Simple example, just make sure setup deps are taken into account at all --- * C: Both the package and the setup script depend on any version of A. --- In this case we prefer to link --- * D: Variation on C.1 where the package requires a specific (not latest) --- version but the setup dependency is not fixed. Again, we prefer to --- link (picking the older version) --- * E: Variation on C.2 with the setup dependency the more inflexible. --- Currently, in this case we do not see the opportunity to link because --- we consider setup dependencies after normal dependencies; we will --- pick A.2 for E, then realize we cannot link E.setup.A to A.2, and pick --- A.1 instead. This isn't so easy to fix (if we want to fix it at all); --- in particular, considering setup dependencies _before_ other deps is --- not an improvement, because in general we would prefer to link setup --- setups to package deps, rather than the other way around. (For example, --- if we change this ordering then the test for D would start to install --- two versions of A). --- * F: The package and the setup script depend on different versions of A. --- This will only work if setup dependencies are considered independent. -db7 :: ExampleDb -db7 = [ - Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [] - , Right $ exAv "B" 1 [] `withSetupDeps` [ExAny "A"] - , Right $ exAv "C" 1 [ExAny "A" ] `withSetupDeps` [ExAny "A" ] - , Right $ exAv "D" 1 [ExFix "A" 1] `withSetupDeps` [ExAny "A" ] - , Right $ exAv "E" 1 [ExAny "A" ] `withSetupDeps` [ExFix "A" 1] - , Right $ exAv "F" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1] - ] - --- If we install C and D together (not as independent goals), we need to build --- both B.1 and B.2, both of which depend on A. -db8 :: ExampleDb -db8 = [ - Right $ exAv "A" 1 [] - , Right $ exAv "B" 1 [ExAny "A"] - , Right $ exAv "B" 2 [ExAny "A"] - , Right $ exAv "C" 1 [] `withSetupDeps` [ExFix "B" 1] - , Right $ exAv "D" 1 [] `withSetupDeps` [ExFix "B" 2] - ] - --- Extended version of `db8` so that we have nested setup dependencies -db9 :: ExampleDb -db9 = db8 ++ [ - Right $ exAv "E" 1 [ExAny "C"] - , Right $ exAv "E" 2 [ExAny "D"] - , Right $ exAv "F" 1 [] `withSetupDeps` [ExFix "E" 1] - , Right $ exAv "G" 1 [] `withSetupDeps` [ExFix "E" 2] - ] - --- Multiple already-installed packages with inter-dependencies, and one package --- (C) that depends on package A-1 for its setup script and package A-2 as a --- library dependency. -db10 :: ExampleDb -db10 = - let rts = exInst "rts" 1 "rts-inst" [] - ghc_prim = exInst "ghc-prim" 1 "ghc-prim-inst" [rts] - base = exInst "base" 1 "base-inst" [rts, ghc_prim] - a1 = exInst "A" 1 "A1-inst" [base] - a2 = exInst "A" 2 "A2-inst" [base] - in [ - Left rts - , Left ghc_prim - , Left base - , Left a1 - , Left a2 - , Right $ exAv "C" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1] - ] - --- | This database tests that a package's setup dependencies are correctly --- linked when the package is linked. See pull request #3268. --- --- When A and B are installed as independent goals, their dependencies on C must --- be linked, due to the single instance restriction. Since C depends on D, 0.D --- and 1.D must be linked. C also has a setup dependency on D, so 0.C-setup.D --- and 1.C-setup.D must be linked. However, D's two link groups must remain --- independent. The solver should be able to choose D-1 for C's library and D-2 --- for C's setup script. -dbSetupDeps :: ExampleDb -dbSetupDeps = [ - Right $ exAv "A" 1 [ExAny "C"] - , Right $ exAv "B" 1 [ExAny "C"] - , Right $ exAv "C" 1 [ExFix "D" 1] `withSetupDeps` [ExFix "D" 2] - , Right $ exAv "D" 1 [] - , Right $ exAv "D" 2 [] - ] - --- | Tests for dealing with base shims -db11 :: ExampleDb -db11 = - let base3 = exInst "base" 3 "base-3-inst" [base4] - base4 = exInst "base" 4 "base-4-inst" [] - in [ - Left base3 - , Left base4 - , Right $ exAv "A" 1 [ExFix "base" 3] - ] - --- | Slightly more realistic version of db11 where base-3 depends on syb --- This means that if a package depends on base-3 and on syb, then they MUST --- share the version of syb --- --- * Package A relies on base-3 (which relies on base-4) --- * Package B relies on base-4 --- * Package C relies on both A and B --- * Package D relies on base-3 and on syb-2, which is not possible because --- base-3 has a dependency on syb-1 (non-inheritance of the Base qualifier) --- * Package E relies on base-4 and on syb-2, which is fine. -db12 :: ExampleDb -db12 = - let base3 = exInst "base" 3 "base-3-inst" [base4, syb1] - base4 = exInst "base" 4 "base-4-inst" [] - syb1 = exInst "syb" 1 "syb-1-inst" [base4] - in [ - Left base3 - , Left base4 - , Left syb1 - , Right $ exAv "syb" 2 [ExFix "base" 4] - , Right $ exAv "A" 1 [ExFix "base" 3, ExAny "syb"] - , Right $ exAv "B" 1 [ExFix "base" 4, ExAny "syb"] - , Right $ exAv "C" 1 [ExAny "A", ExAny "B"] - , Right $ exAv "D" 1 [ExFix "base" 3, ExFix "syb" 2] - , Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2] - ] - -dbBase :: ExampleDb -dbBase = [ - Right $ exAv "base" 1 - [ExAny "ghc-prim", ExAny "integer-simple", ExAny "integer-gmp"] - , Right $ exAv "ghc-prim" 1 [] - , Right $ exAv "integer-simple" 1 [] - , Right $ exAv "integer-gmp" 1 [] - ] - -db13 :: ExampleDb -db13 = [ - Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [] - , Right $ exAv "A" 3 [] - ] - --- | A, B, and C have three different dependencies on D that can be set to --- different versions with qualified constraints. Each version of D can only --- be depended upon by one version of A, B, or C, so that the versions of A, B, --- and C in the install plan indicate which version of D was chosen for each --- dependency. The one-to-one correspondence between versions of A, B, and C and --- versions of D also prevents linking, which would complicate the solver's --- behavior. -dbConstraints :: ExampleDb -dbConstraints = - [Right $ exAv "A" v [ExFix "D" v] | v <- [1, 4, 7]] - ++ [Right $ exAv "B" v [] `withSetupDeps` [ExFix "D" v] | v <- [2, 5, 8]] - ++ [Right $ exAv "C" v [] `withSetupDeps` [ExFix "D" v] | v <- [3, 6, 9]] - ++ [Right $ exAv "D" v [] | v <- [1..9]] - -dbStanzaPreferences1 :: ExampleDb -dbStanzaPreferences1 = [ - Right $ exAv "pkg" 1 [] `withTest` ExTest "test" [ExAny "test-dep"] - , Right $ exAv "test-dep" 1 [] - ] - -dbStanzaPreferences2 :: ExampleDb -dbStanzaPreferences2 = [ - Right $ exAv "pkg" 1 [] `withTest` ExTest "test" [ExAny "unknown"] - ] - --- | This is a test case for a bug in stanza preferences (#3930). The solver --- should be able to install 'A' by enabling 'flag' and disabling testing. When --- it tries goals in the specified order and prefers testing, it encounters --- 'unknown-pkg2'. 'unknown-pkg2' is only introduced by testing and 'flag', so --- the conflict set should contain both of those variables. Before the fix, it --- only contained 'flag'. The solver backjumped past the choice to disable --- testing and failed to find the solution. -testStanzaPreference :: String -> TestTree -testStanzaPreference name = - let pkg = exAv "A" 1 [exFlagged "flag" - [] - [ExAny "unknown-pkg1"]] - `withTest` - ExTest "test" [exFlagged "flag" - [ExAny "unknown-pkg2"] - []] - goals = [ - P QualNone "A" - , F QualNone "A" "flag" - , S QualNone "A" TestStanzas - ] - in runTest $ goalOrder goals $ - preferences [ ExStanzaPref "A" [TestStanzas]] $ - mkTest [Right pkg] name ["A"] $ - solverSuccess [("A", 1)] - --- | Database with some cycles --- --- * Simplest non-trivial cycle: A -> B and B -> A --- * There is a cycle C -> D -> C, but it can be broken by picking the --- right flag assignment. -db14 :: ExampleDb -db14 = [ - Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAv "B" 1 [ExAny "A"] - , Right $ exAv "C" 1 [exFlagged "flagC" [ExAny "D"] [ExAny "E"]] - , Right $ exAv "D" 1 [ExAny "C"] - , Right $ exAv "E" 1 [] - ] - --- | Cycles through setup dependencies --- --- The first cycle is unsolvable: package A has a setup dependency on B, --- B has a regular dependency on A, and we only have a single version available --- for both. --- --- The second cycle can be broken by picking different versions: package C-2.0 --- has a setup dependency on D, and D has a regular dependency on C-*. However, --- version C-1.0 is already available (perhaps it didn't have this setup dep). --- Thus, we should be able to break this cycle even if we are installing package --- E, which explictly depends on C-2.0. -db15 :: ExampleDb -db15 = [ - -- First example (real cycle, no solution) - Right $ exAv "A" 1 [] `withSetupDeps` [ExAny "B"] - , Right $ exAv "B" 1 [ExAny "A"] - -- Second example (cycle can be broken by picking versions carefully) - , Left $ exInst "C" 1 "C-1-inst" [] - , Right $ exAv "C" 2 [] `withSetupDeps` [ExAny "D"] - , Right $ exAv "D" 1 [ExAny "C" ] - , Right $ exAv "E" 1 [ExFix "C" 2] - ] - --- | Detect a cycle between a package and its setup script. --- --- This type of cycle can easily occur when new-build adds default setup --- dependencies to packages without custom-setup stanzas. For example, cabal --- adds 'time' as a setup dependency for 'time'. The solver should detect the --- cycle when it attempts to link the setup and non-setup instances of the --- package and then choose a different version for the setup dependency. -issue4161 :: String -> SolverTest -issue4161 name = - mkTest db name ["target"] $ - SolverResult checkFullLog $ Right [("target", 1), ("time", 1), ("time", 2)] - where - db :: ExampleDb - db = [ - Right $ exAv "target" 1 [ExFix "time" 2] - , Right $ exAv "time" 2 [] `withSetupDeps` [ExAny "time"] - , Right $ exAv "time" 1 [] - ] - - checkFullLog :: [String] -> Bool - checkFullLog = any $ isInfixOf $ - "rejecting: time:setup.time~>time-2.0.0 (cyclic dependencies; " - ++ "conflict set: time:setup.time)" - --- | Packages pkg-A, pkg-B, and pkg-C form a cycle. The solver should backtrack --- as soon as it chooses the last package in the cycle, to avoid searching parts --- of the tree that have no solution. Since there is no way to break the cycle, --- it should fail with an error message describing the cycle. -testCyclicDependencyErrorMessages :: String -> SolverTest -testCyclicDependencyErrorMessages name = - goalOrder goals $ - mkTest db name ["pkg-A"] $ - SolverResult checkFullLog $ Left checkSummarizedLog - where - db :: ExampleDb - db = [ - Right $ exAv "pkg-A" 1 [ExAny "pkg-B"] - , Right $ exAv "pkg-B" 1 [ExAny "pkg-C"] - , Right $ exAv "pkg-C" 1 [ExAny "pkg-A", ExAny "pkg-D"] - , Right $ exAv "pkg-D" 1 [ExAny "pkg-E"] - , Right $ exAv "pkg-E" 1 [] - ] - - -- The solver should backtrack as soon as pkg-A, pkg-B, and pkg-C form a - -- cycle. It shouldn't try pkg-D or pkg-E. - checkFullLog :: [String] -> Bool - checkFullLog = - not . any (\l -> "pkg-D" `isInfixOf` l || "pkg-E" `isInfixOf` l) - - checkSummarizedLog :: String -> Bool - checkSummarizedLog = - isInfixOf "rejecting: pkg-C-1.0.0 (cyclic dependencies; conflict set: pkg-A, pkg-B, pkg-C)" - - -- Solve for pkg-D and pkg-E last. - goals :: [ExampleVar] - goals = [P QualNone ("pkg-" ++ [c]) | c <- ['A'..'E']] - --- | Check that the solver can backtrack after encountering the SIR (issue #2843) --- --- When A and B are installed as independent goals, the single instance --- restriction prevents B from depending on C. This database tests that the --- solver can backtrack after encountering the single instance restriction and --- choose the only valid flag assignment (-flagA +flagB): --- --- > flagA flagB B depends on --- > On _ C-* --- > Off On E-* <-- only valid flag assignment --- > Off Off D-2.0, C-* --- --- Since A depends on C-* and D-1.0, and C-1.0 depends on any version of D, --- we must build C-1.0 against D-1.0. Since B depends on D-2.0, we cannot have --- C in the transitive closure of B's dependencies, because that would mean we --- would need two instances of C: one built against D-1.0 and one built against --- D-2.0. -db16 :: ExampleDb -db16 = [ - Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1] - , Right $ exAv "B" 1 [ ExFix "D" 2 - , exFlagged "flagA" - [ExAny "C"] - [exFlagged "flagB" - [ExAny "E"] - [ExAny "C"]]] - , Right $ exAv "C" 1 [ExAny "D"] - , Right $ exAv "D" 1 [] - , Right $ exAv "D" 2 [] - , Right $ exAv "E" 1 [] - ] - --- | This test checks that when the solver discovers a constraint on a --- package's version after choosing to link that package, it can backtrack to --- try alternative versions for the linked-to package. See pull request #3327. --- --- When A and B are installed as independent goals, their dependencies on C --- must be linked. Since C depends on D, A and B's dependencies on D must also --- be linked. This test fixes the goal order so that the solver chooses D-2 for --- both 0.D and 1.D before it encounters the test suites' constraints. The --- solver must backtrack to try D-1 for both 0.D and 1.D. -testIndepGoals2 :: String -> SolverTest -testIndepGoals2 name = - goalOrder goals $ independentGoals $ - enableAllTests $ mkTest db name ["A", "B"] $ - solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)] - where - db :: ExampleDb - db = [ - Right $ exAv "A" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1] - , Right $ exAv "B" 1 [ExAny "C"] `withTest` ExTest "test" [ExFix "D" 1] - , Right $ exAv "C" 1 [ExAny "D"] - , Right $ exAv "D" 1 [] - , Right $ exAv "D" 2 [] - ] - - goals :: [ExampleVar] - goals = [ - P (QualIndep "A") "A" - , P (QualIndep "A") "C" - , P (QualIndep "A") "D" - , P (QualIndep "B") "B" - , P (QualIndep "B") "C" - , P (QualIndep "B") "D" - , S (QualIndep "B") "B" TestStanzas - , S (QualIndep "A") "A" TestStanzas - ] - --- | Issue #2834 --- When both A and B are installed as independent goals, their dependencies on --- C must be linked. The only combination of C's flags that is consistent with --- A and B's dependencies on D is -flagA +flagB. This database tests that the --- solver can backtrack to find the right combination of flags (requiring F, but --- not E or G) and apply it to both 0.C and 1.C. --- --- > flagA flagB C depends on --- > On _ D-1, E-* --- > Off On F-* <-- Only valid choice --- > Off Off D-2, G-* --- --- The single instance restriction means we cannot have one instance of C --- built against D-1 and one instance built against D-2; since A depends on --- D-1, and B depends on C-2, it is therefore important that C cannot depend --- on any version of D. -db18 :: ExampleDb -db18 = [ - Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1] - , Right $ exAv "B" 1 [ExAny "C", ExFix "D" 2] - , Right $ exAv "C" 1 [exFlagged "flagA" - [ExFix "D" 1, ExAny "E"] - [exFlagged "flagB" - [ExAny "F"] - [ExFix "D" 2, ExAny "G"]]] - , Right $ exAv "D" 1 [] - , Right $ exAv "D" 2 [] - , Right $ exAv "E" 1 [] - , Right $ exAv "F" 1 [] - , Right $ exAv "G" 1 [] - ] - --- | When both values for flagA introduce package B, the solver should be able --- to choose B before choosing a value for flagA. It should try to choose a --- version for B that is in the union of the version ranges required by +flagA --- and -flagA. -commonDependencyLogMessage :: String -> SolverTest -commonDependencyLogMessage name = - mkTest db name ["A"] $ solverFailure $ isInfixOf $ - "[__0] trying: A-1.0.0 (user goal)\n" - ++ "[__1] next goal: B (dependency of A +/-flagA)\n" - ++ "[__1] rejecting: B-2.0.0 (conflict: A +/-flagA => B==1.0.0 || ==3.0.0)" - where - db :: ExampleDb - db = [ - Right $ exAv "A" 1 [exFlagged "flagA" - [ExFix "B" 1] - [ExFix "B" 3]] - , Right $ exAv "B" 2 [] - ] - --- | Test lifting dependencies out of multiple levels of conditionals. -twoLevelDeepCommonDependencyLogMessage :: String -> SolverTest -twoLevelDeepCommonDependencyLogMessage name = - mkTest db name ["A"] $ solverFailure $ isInfixOf $ - "unknown package: B (dependency of A +/-flagA +/-flagB)" - where - db :: ExampleDb - db = [ - Right $ exAv "A" 1 [exFlagged "flagA" - [exFlagged "flagB" - [ExAny "B"] - [ExAny "B"]] - [exFlagged "flagB" - [ExAny "B"] - [ExAny "B"]]] - ] - --- | Test handling nested conditionals that are controlled by the same flag. --- The solver should treat flagA as introducing 'unknown' with value true, not --- both true and false. That means that when +flagA causes a conflict, the --- solver should try flipping flagA to false to resolve the conflict, rather --- than backjumping past flagA. -testBackjumpingWithCommonDependency :: String -> SolverTest -testBackjumpingWithCommonDependency name = - mkTest db name ["A"] $ solverSuccess [("A", 1), ("B", 1)] - where - db :: ExampleDb - db = [ - Right $ exAv "A" 1 [exFlagged "flagA" - [exFlagged "flagA" - [ExAny "unknown"] - [ExAny "unknown"]] - [ExAny "B"]] - , Right $ exAv "B" 1 [] - ] - --- | Tricky test case with independent goals (issue #2842) --- --- Suppose we are installing D, E, and F as independent goals: --- --- * D depends on A-* and C-1, requiring A-1 to be built against C-1 --- * E depends on B-* and C-2, requiring B-1 to be built against C-2 --- * F depends on A-* and B-*; this means we need A-1 and B-1 both to be built --- against the same version of C, violating the single instance restriction. --- --- We can visualize this DB as: --- --- > C-1 C-2 --- > /|\ /|\ --- > / | \ / | \ --- > / | X | \ --- > | | / \ | | --- > | |/ \| | --- > | + + | --- > | | | | --- > | A B | --- > \ |\ /| / --- > \ | \ / | / --- > \| V |/ --- > D F E -testIndepGoals3 :: String -> SolverTest -testIndepGoals3 name = - goalOrder goals $ independentGoals $ - mkTest db name ["D", "E", "F"] anySolverFailure - where - db :: ExampleDb - db = [ - Right $ exAv "A" 1 [ExAny "C"] - , Right $ exAv "B" 1 [ExAny "C"] - , Right $ exAv "C" 1 [] - , Right $ exAv "C" 2 [] - , Right $ exAv "D" 1 [ExAny "A", ExFix "C" 1] - , Right $ exAv "E" 1 [ExAny "B", ExFix "C" 2] - , Right $ exAv "F" 1 [ExAny "A", ExAny "B"] - ] - - goals :: [ExampleVar] - goals = [ - P (QualIndep "D") "D" - , P (QualIndep "D") "C" - , P (QualIndep "D") "A" - , P (QualIndep "E") "E" - , P (QualIndep "E") "C" - , P (QualIndep "E") "B" - , P (QualIndep "F") "F" - , P (QualIndep "F") "B" - , P (QualIndep "F") "C" - , P (QualIndep "F") "A" - ] - --- | This test checks that the solver correctly backjumps when dependencies --- of linked packages are not linked. It is an example where the conflict set --- from enforcing the single instance restriction is not sufficient. See pull --- request #3327. --- --- When A, B, and C are installed as independent goals with the specified goal --- order, the first choice that the solver makes for E is 0.E-2. Then, when it --- chooses dependencies for B and C, it links both 1.E and 2.E to 0.E. Finally, --- the solver discovers C's test's constraint on E. It must backtrack to try --- 1.E-1 and then link 2.E to 1.E. Backjumping all the way to 0.E does not lead --- to a solution, because 0.E's version is constrained by A and cannot be --- changed. -testIndepGoals4 :: String -> SolverTest -testIndepGoals4 name = - goalOrder goals $ independentGoals $ - enableAllTests $ mkTest db name ["A", "B", "C"] $ - solverSuccess [("A",1), ("B",1), ("C",1), ("D",1), ("E",1), ("E",2)] - where - db :: ExampleDb - db = [ - Right $ exAv "A" 1 [ExFix "E" 2] - , Right $ exAv "B" 1 [ExAny "D"] - , Right $ exAv "C" 1 [ExAny "D"] `withTest` ExTest "test" [ExFix "E" 1] - , Right $ exAv "D" 1 [ExAny "E"] - , Right $ exAv "E" 1 [] - , Right $ exAv "E" 2 [] - ] - - goals :: [ExampleVar] - goals = [ - P (QualIndep "A") "A" - , P (QualIndep "A") "E" - , P (QualIndep "B") "B" - , P (QualIndep "B") "D" - , P (QualIndep "B") "E" - , P (QualIndep "C") "C" - , P (QualIndep "C") "D" - , P (QualIndep "C") "E" - , S (QualIndep "C") "C" TestStanzas - ] - --- | Test the trace messages that we get when a package refers to an unknown pkg --- --- TODO: Currently we don't actually test the trace messages, and this particular --- test still suceeds. The trace can only be verified by hand. -db21 :: ExampleDb -db21 = [ - Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAv "A" 2 [ExAny "C"] -- A-2.0 will be tried first, but C unknown - , Right $ exAv "B" 1 [] - ] - --- | A variant of 'db21', which actually fails. -db22 :: ExampleDb -db22 = [ - Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAv "A" 2 [ExAny "C"] - ] - --- | Another test for the unknown package message. This database tests that --- filtering out redundant conflict set messages in the solver log doesn't --- interfere with generating a message about a missing package (part of issue --- #3617). The conflict set for the missing package is {A, B}. That conflict set --- is propagated up the tree to the level of A. Since the conflict set is the --- same at both levels, the solver only keeps one of the backjumping messages. -db23 :: ExampleDb -db23 = [ - Right $ exAv "A" 1 [ExAny "B"] - ] - --- | Database for (unsuccessfully) trying to expose a bug in the handling --- of implied linking constraints. The question is whether an implied linking --- constraint should only have the introducing package in its conflict set, --- or also its link target. --- --- It turns out that as long as the Single Instance Restriction is in place, --- it does not matter, because there will aways be an option that is failing --- due to the SIR, which contains the link target in its conflict set. --- --- Even if the SIR is not in place, if there is a solution, one will always --- be found, because without the SIR, linking is always optional, but never --- necessary. --- -testIndepGoals5 :: String -> GoalOrder -> SolverTest -testIndepGoals5 name fixGoalOrder = - case fixGoalOrder of - FixedGoalOrder -> goalOrder goals test - DefaultGoalOrder -> test - where - test :: SolverTest - test = independentGoals $ mkTest db name ["X", "Y"] $ - solverSuccess - [("A", 1), ("A", 2), ("B", 1), ("C", 1), ("C", 2), ("X", 1), ("Y", 1)] - - db :: ExampleDb - db = [ - Right $ exAv "X" 1 [ExFix "C" 2, ExAny "A"] - , Right $ exAv "Y" 1 [ExFix "C" 1, ExFix "A" 2] - , Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [ExAny "B"] - , Right $ exAv "B" 1 [ExAny "C"] - , Right $ exAv "C" 1 [] - , Right $ exAv "C" 2 [] - ] - - goals :: [ExampleVar] - goals = [ - P (QualIndep "X") "X" - , P (QualIndep "X") "A" - , P (QualIndep "X") "B" - , P (QualIndep "X") "C" - , P (QualIndep "Y") "Y" - , P (QualIndep "Y") "A" - , P (QualIndep "Y") "B" - , P (QualIndep "Y") "C" - ] - --- | A simplified version of 'testIndepGoals5'. -testIndepGoals6 :: String -> GoalOrder -> SolverTest -testIndepGoals6 name fixGoalOrder = - case fixGoalOrder of - FixedGoalOrder -> goalOrder goals test - DefaultGoalOrder -> test - where - test :: SolverTest - test = independentGoals $ mkTest db name ["X", "Y"] $ - solverSuccess - [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("X", 1), ("Y", 1)] - - db :: ExampleDb - db = [ - Right $ exAv "X" 1 [ExFix "B" 2, ExAny "A"] - , Right $ exAv "Y" 1 [ExFix "B" 1, ExFix "A" 2] - , Right $ exAv "A" 1 [] - , Right $ exAv "A" 2 [ExAny "B"] - , Right $ exAv "B" 1 [] - , Right $ exAv "B" 2 [] - ] - - goals :: [ExampleVar] - goals = [ - P (QualIndep "X") "X" - , P (QualIndep "X") "A" - , P (QualIndep "X") "B" - , P (QualIndep "Y") "Y" - , P (QualIndep "Y") "A" - , P (QualIndep "Y") "B" - ] - -dbExts1 :: ExampleDb -dbExts1 = [ - Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)] - , Right $ exAv "B" 1 [ExExt (EnableExtension CPP), ExAny "A"] - , Right $ exAv "C" 1 [ExAny "B"] - , Right $ exAv "D" 1 [ExExt (DisableExtension CPP), ExAny "B"] - , Right $ exAv "E" 1 [ExExt (UnknownExtension "custom"), ExAny "C"] - ] - -dbLangs1 :: ExampleDb -dbLangs1 = [ - Right $ exAv "A" 1 [ExLang Haskell2010] - , Right $ exAv "B" 1 [ExLang Haskell98, ExAny "A"] - , Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"] - ] - --- | cabal must set enable-exe to false in order to avoid the unavailable --- dependency. Flags are true by default. The flag choice causes "pkg" to --- depend on "false-dep". -testBuildable :: String -> ExampleDependency -> TestTree -testBuildable testName unavailableDep = - runTest $ - mkTestExtLangPC (Just []) (Just [Haskell98]) [] db testName ["pkg"] expected - where - expected = solverSuccess [("false-dep", 1), ("pkg", 1)] - db = [ - Right $ exAv "pkg" 1 [exFlagged "enable-exe" - [ExAny "true-dep"] - [ExAny "false-dep"]] - `withExe` - ExExe "exe" [ unavailableDep - , ExFlagged "enable-exe" (Buildable []) NotBuildable ] - , Right $ exAv "true-dep" 1 [] - , Right $ exAv "false-dep" 1 [] - ] - --- | cabal must choose -flag1 +flag2 for "pkg", which requires packages --- "flag1-false" and "flag2-true". -dbBuildable1 :: ExampleDb -dbBuildable1 = [ - Right $ exAv "pkg" 1 - [ exFlagged "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"] - , exFlagged "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]] - `withExes` - [ ExExe "exe1" - [ ExAny "unknown" - , ExFlagged "flag1" (Buildable []) NotBuildable - , ExFlagged "flag2" (Buildable []) NotBuildable] - , ExExe "exe2" - [ ExAny "unknown" - , ExFlagged "flag1" - (Buildable []) - (Buildable [ExFlagged "flag2" NotBuildable (Buildable [])])] - ] - , Right $ exAv "flag1-true" 1 [] - , Right $ exAv "flag1-false" 1 [] - , Right $ exAv "flag2-true" 1 [] - , Right $ exAv "flag2-false" 1 [] - ] - --- | cabal must pick B-2 to avoid the unknown dependency. -dbBuildable2 :: ExampleDb -dbBuildable2 = [ - Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAv "B" 1 [ExAny "unknown"] - , Right $ exAv "B" 2 [] - `withExe` - ExExe "exe" - [ ExAny "unknown" - , ExFlagged "disable-exe" NotBuildable (Buildable []) - ] - , Right $ exAv "B" 3 [ExAny "unknown"] - ] - --- | Package databases for testing @pkg-config@ dependencies. -dbPC1 :: ExampleDb -dbPC1 = [ - Right $ exAv "A" 1 [ExPkg ("pkgA", 1)] - , Right $ exAv "B" 1 [ExPkg ("pkgB", 1), ExAny "A"] - , Right $ exAv "B" 2 [ExPkg ("pkgB", 2), ExAny "A"] - , Right $ exAv "C" 1 [ExAny "B"] - ] - --- | Test for the solver's summarized log. The final conflict set is {A, D}, --- though the goal order forces the solver to find the (avoidable) conflict --- between B >= 2 and C first. When the solver reaches the backjump limit, it --- should only show the log to the first conflict. When the backjump limit is --- high enough to allow an exhaustive search, the solver should make use of the --- final conflict set to only show the conflict between A and D in the --- summarized log. -testSummarizedLog :: String -> Maybe Int -> String -> TestTree -testSummarizedLog testName mbj expectedMsg = - runTest $ maxBackjumps mbj $ goalOrder goals $ mkTest db testName ["A"] $ - solverFailure (== expectedMsg) - where - db = [ - Right $ exAv "A" 1 [ExAny "B", ExAny "D"] - , Right $ exAv "B" 3 [ExFix "C" 3] - , Right $ exAv "B" 2 [ExFix "C" 2] - , Right $ exAv "B" 1 [ExAny "C"] - , Right $ exAv "C" 1 [] - ] - - goals :: [ExampleVar] - goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]] - -{------------------------------------------------------------------------------- - Simple databases for the illustrations for the backjumping blog post --------------------------------------------------------------------------------} - --- | Motivate conflict sets -dbBJ1a :: ExampleDb -dbBJ1a = [ - Right $ exAv "A" 1 [ExFix "B" 1] - , Right $ exAv "A" 2 [ExFix "B" 2] - , Right $ exAv "B" 1 [] - ] - --- | Show that we can skip some decisions -dbBJ1b :: ExampleDb -dbBJ1b = [ - Right $ exAv "A" 1 [ExFix "B" 1] - , Right $ exAv "A" 2 [ExFix "B" 2, ExAny "C"] - , Right $ exAv "B" 1 [] - , Right $ exAv "C" 1 [] - , Right $ exAv "C" 2 [] - ] - --- | Motivate why both A and B need to be in the conflict set -dbBJ1c :: ExampleDb -dbBJ1c = [ - Right $ exAv "A" 1 [ExFix "B" 1] - , Right $ exAv "B" 1 [] - , Right $ exAv "B" 2 [] - ] - --- | Motivate the need for accumulating conflict sets while we walk the tree -dbBJ2 :: ExampleDb -dbBJ2 = [ - Right $ exAv "A" 1 [ExFix "B" 1] - , Right $ exAv "A" 2 [ExFix "B" 2] - , Right $ exAv "B" 1 [ExFix "C" 1] - , Right $ exAv "B" 2 [ExFix "C" 2] - , Right $ exAv "C" 1 [] - ] - --- | Motivate the need for `QGoalReason` -dbBJ3 :: ExampleDb -dbBJ3 = [ - Right $ exAv "A" 1 [ExAny "Ba"] - , Right $ exAv "A" 2 [ExAny "Bb"] - , Right $ exAv "Ba" 1 [ExFix "C" 1] - , Right $ exAv "Bb" 1 [ExFix "C" 2] - , Right $ exAv "C" 1 [] - ] - --- | `QGOalReason` not unique -dbBJ4 :: ExampleDb -dbBJ4 = [ - Right $ exAv "A" 1 [ExAny "B", ExAny "C"] - , Right $ exAv "B" 1 [ExAny "C"] - , Right $ exAv "C" 1 [] - ] - --- | Flags are represented somewhat strangely in the tree --- --- This example probably won't be in the blog post itself but as a separate --- bug report (#3409) -dbBJ5 :: ExampleDb -dbBJ5 = [ - Right $ exAv "A" 1 [exFlagged "flagA" [ExFix "B" 1] [ExFix "C" 1]] - , Right $ exAv "B" 1 [ExFix "D" 1] - , Right $ exAv "C" 1 [ExFix "D" 2] - , Right $ exAv "D" 1 [] - ] - --- | Conflict sets for cycles -dbBJ6 :: ExampleDb -dbBJ6 = [ - Right $ exAv "A" 1 [ExAny "B"] - , Right $ exAv "B" 1 [] - , Right $ exAv "B" 2 [ExAny "C"] - , Right $ exAv "C" 1 [ExAny "A"] - ] - --- | Conflicts not unique -dbBJ7 :: ExampleDb -dbBJ7 = [ - Right $ exAv "A" 1 [ExAny "B", ExFix "C" 1] - , Right $ exAv "B" 1 [ExFix "C" 1] - , Right $ exAv "C" 1 [] - , Right $ exAv "C" 2 [] - ] - --- | Conflict sets for SIR (C shared subgoal of independent goals A, B) -dbBJ8 :: ExampleDb -dbBJ8 = [ - Right $ exAv "A" 1 [ExAny "C"] - , Right $ exAv "B" 1 [ExAny "C"] - , Right $ exAv "C" 1 [] - ] - -{------------------------------------------------------------------------------- - Databases for build-tool-depends --------------------------------------------------------------------------------} - --- | Multiple packages depending on exes from 'bt-pkg'. -dbBuildTools :: ExampleDb -dbBuildTools = [ - Right $ exAv "A" 1 [ExBuildToolAny "bt-pkg" "exe1"] - , Right $ exAv "B" 1 [exFlagged "flagB" [ExAny "unknown"] - [ExBuildToolAny "bt-pkg" "exe1"]] - , Right $ exAv "C" 1 [] `withTest` ExTest "testC" [ExBuildToolAny "bt-pkg" "exe1"] - , Right $ exAv "D" 1 [ExBuildToolAny "bt-pkg" "unknown-exe"] - , Right $ exAv "E" 1 [ExBuildToolAny "unknown-pkg" "exe1"] - , Right $ exAv "F" 1 [exFlagged "flagF" [ExBuildToolAny "bt-pkg" "unknown-exe"] - [ExAny "unknown"]] - , Right $ exAv "G" 1 [] `withTest` ExTest "testG" [ExBuildToolAny "bt-pkg" "unknown-exe"] - , Right $ exAv "H" 1 [ExBuildToolFix "bt-pkg" "exe1" 3] - - , Right $ exAv "bt-pkg" 4 [] - , Right $ exAv "bt-pkg" 3 [] `withExe` ExExe "exe2" [] - , Right $ exAv "bt-pkg" 2 [] `withExe` ExExe "exe1" [] - , Right $ exAv "bt-pkg" 1 [] - ] - --- The solver should never choose an installed package for a build tool --- dependency. -rejectInstalledBuildToolPackage :: String -> SolverTest -rejectInstalledBuildToolPackage name = - mkTest db name ["A"] $ solverFailure $ isInfixOf $ - "rejecting: A:B:exe.B-1.0.0/installed-1 " - ++ "(does not contain executable exe, which is required by A)" - where - db :: ExampleDb - db = [ - Right $ exAv "A" 1 [ExBuildToolAny "B" "exe"] - , Left $ exInst "B" 1 "B-1" [] - ] - --- | This test forces the solver to choose B as a build-tool dependency before --- it sees the dependency on executable exe2 from B. The solver needs to check --- that the version that it already chose for B contains the necessary --- executable. This order causes a different "missing executable" error message --- than when the solver checks for the executable in the same step that it --- chooses the build-tool package. --- --- This case may become impossible if we ever add the executable name to the --- build-tool goal qualifier. Then this test would involve two qualified goals --- for B, one for exe1 and another for exe2. -chooseExeAfterBuildToolsPackage :: Bool -> String -> SolverTest -chooseExeAfterBuildToolsPackage shouldSucceed name = - goalOrder goals $ mkTest db name ["A"] $ - if shouldSucceed - then solverSuccess [("A", 1), ("B", 1)] - else solverFailure $ isInfixOf $ - "rejecting: A:+flagA (requires executable exe2 from A:B:exe.B, " - ++ "but the executable does not exist)" - where - db :: ExampleDb - db = [ - Right $ exAv "A" 1 [ ExBuildToolAny "B" "exe1" - , exFlagged "flagA" [ExBuildToolAny "B" "exe2"] - [ExAny "unknown"]] - , Right $ exAv "B" 1 [] - `withExes` - [ExExe exe [] | exe <- if shouldSucceed then ["exe1", "exe2"] else ["exe1"]] - ] - - goals :: [ExampleVar] - goals = [ - P QualNone "A" - , P (QualExe "A" "B") "B" - , F QualNone "A" "flagA" - ] - --- | Test that when one package depends on two executables from another package, --- both executables must come from the same instance of that package. We could --- lift this restriction in the future by adding the executable name to the goal --- qualifier. -requireConsistentBuildToolVersions :: String -> SolverTest -requireConsistentBuildToolVersions name = - mkTest db name ["A"] $ solverFailure $ isInfixOf $ - "[__1] rejecting: A:B:exe.B-2.0.0 (conflict: A => A:B:exe.B (exe exe1)==1.0.0)\n" - ++ "[__1] rejecting: A:B:exe.B-1.0.0 (conflict: A => A:B:exe.B (exe exe2)==2.0.0)" - where - db :: ExampleDb - db = [ - Right $ exAv "A" 1 [ ExBuildToolFix "B" "exe1" 1 - , ExBuildToolFix "B" "exe2" 2 ] - , Right $ exAv "B" 2 [] `withExes` exes - , Right $ exAv "B" 1 [] `withExes` exes - ] - - exes = [ExExe "exe1" [], ExExe "exe2" []] - -{------------------------------------------------------------------------------- - Databases for legacy build-tools --------------------------------------------------------------------------------} -dbLegacyBuildTools1 :: ExampleDb -dbLegacyBuildTools1 = [ - Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [], - Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"] - ] - --- Test that a recognized build tool dependency specifies the name of both the --- package and the executable. This db has no solution. -dbLegacyBuildTools2 :: ExampleDb -dbLegacyBuildTools2 = [ - Right $ exAv "alex" 1 [] `withExe` ExExe "other-exe" [], - Right $ exAv "other-package" 1 [] `withExe` ExExe "alex" [], - Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"] - ] - --- Test that build-tools on a random thing doesn't matter (only --- the ones we recognize need to be in db) -dbLegacyBuildTools3 :: ExampleDb -dbLegacyBuildTools3 = [ - Right $ exAv "A" 1 [ExLegacyBuildToolAny "otherdude"] - ] - --- Test that we can solve for different versions of executables -dbLegacyBuildTools4 :: ExampleDb -dbLegacyBuildTools4 = [ - Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [], - Right $ exAv "alex" 2 [] `withExe` ExExe "alex" [], - Right $ exAv "A" 1 [ExLegacyBuildToolFix "alex" 1], - Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 2], - Right $ exAv "C" 1 [ExAny "A", ExAny "B"] - ] - --- Test that exe is not related to library choices -dbLegacyBuildTools5 :: ExampleDb -dbLegacyBuildTools5 = [ - Right $ exAv "alex" 1 [ExFix "A" 1] `withExe` ExExe "alex" [], - Right $ exAv "A" 1 [], - Right $ exAv "A" 2 [], - Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 1, ExFix "A" 2] - ] - --- Test that build-tools on build-tools works -dbLegacyBuildTools6 :: ExampleDb -dbLegacyBuildTools6 = [ - Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [], - Right $ exAv "happy" 1 [ExLegacyBuildToolAny "alex"] `withExe` ExExe "happy" [], - Right $ exAv "A" 1 [ExLegacyBuildToolAny "happy"] - ] - --- Test that build-depends on library/executable package works. --- Extracted from https://github.com/haskell/cabal/issues/3775 -dbIssue3775 :: ExampleDb -dbIssue3775 = [ - Right $ exAv "warp" 1 [], - -- NB: the warp build-depends refers to the package, not the internal - -- executable! - Right $ exAv "A" 2 [ExFix "warp" 1] `withExe` ExExe "warp" [ExAny "A"], - Right $ exAv "B" 2 [ExAny "A", ExAny "warp"] - ] diff --git a/tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs b/tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs deleted file mode 100644 --- a/tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE ParallelListComp #-} -module UnitTests.Distribution.Solver.Modular.WeightedPSQ ( - tests - ) where - -import qualified Distribution.Solver.Modular.WeightedPSQ as W - -import Data.List (sort) - -import Test.Tasty (TestTree) -import Test.Tasty.HUnit (testCase, (@?=)) -import Test.Tasty.QuickCheck (Blind(..), testProperty) - -tests :: [TestTree] -tests = [ - testProperty "'toList . fromList' preserves elements" $ \xs -> - sort (xs :: [(Int, Char, Bool)]) == sort (W.toList (W.fromList xs)) - - , testProperty "'toList . fromList' sorts stably" $ \xs -> - let indexAsValue :: [(Int, (), Int)] - indexAsValue = [(x, (), i) | x <- xs | i <- [0..]] - in isSorted $ W.toList $ W.fromList indexAsValue - - , testProperty "'mapWeightsWithKey' sorts by weight" $ \xs (Blind f) -> - isSorted $ W.weights $ - W.mapWeightsWithKey (f :: Int -> Int -> Int) $ - W.fromList (xs :: [(Int, Int, Int)]) - - , testCase "applying 'mapWeightsWithKey' twice sorts twice" $ - let indexAsKey :: [((), Int, ())] - indexAsKey = [((), i, ()) | i <- [0..10]] - actual = W.toList $ - W.mapWeightsWithKey (\_ _ -> ()) $ - W.mapWeightsWithKey (\i _ -> -i) $ -- should not be ignored - W.fromList indexAsKey - in reverse indexAsKey @?= actual - - , testProperty "'union' sorts by weight" $ \xs ys -> - isSorted $ W.weights $ - W.union (W.fromList xs) (W.fromList (ys :: [(Int, Int, Int)])) - - , testProperty "'union' preserves elements" $ \xs ys -> - let union = W.union (W.fromList xs) - (W.fromList (ys :: [(Int, Int, Int)])) - in sort (xs ++ ys) == sort (W.toList union) - - , testCase "'lookup' returns first occurrence" $ - let xs = W.fromList [((), False, 'A'), ((), True, 'C'), ((), True, 'B')] - in Just 'C' @?= W.lookup True xs - ] - -isSorted :: Ord a => [a] -> Bool -isSorted (x1 : xs@(x2 : _)) = x1 <= x2 && isSorted xs -isSorted _ = True diff --git a/tests/UnitTests/Options.hs b/tests/UnitTests/Options.hs deleted file mode 100644 --- a/tests/UnitTests/Options.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module UnitTests.Options ( OptionShowSolverLog(..) - , OptionMtimeChangeDelay(..) - , extraOptions ) - where - -import Data.Proxy -import Data.Typeable - -import Test.Tasty.Options - -{------------------------------------------------------------------------------- - Test options --------------------------------------------------------------------------------} - -extraOptions :: [OptionDescription] -extraOptions = - [ Option (Proxy :: Proxy OptionShowSolverLog) - , Option (Proxy :: Proxy OptionMtimeChangeDelay) - ] - -newtype OptionShowSolverLog = OptionShowSolverLog Bool - deriving Typeable - -instance IsOption OptionShowSolverLog where - defaultValue = OptionShowSolverLog False - parseValue = fmap OptionShowSolverLog . safeRead - optionName = return "show-solver-log" - optionHelp = return "Show full log from the solver" - optionCLParser = flagCLParser Nothing (OptionShowSolverLog True) - -newtype OptionMtimeChangeDelay = OptionMtimeChangeDelay Int - deriving Typeable - -instance IsOption OptionMtimeChangeDelay where - defaultValue = OptionMtimeChangeDelay 0 - parseValue = fmap OptionMtimeChangeDelay . safeRead - optionName = return "mtime-change-delay" - optionHelp = return $ "How long to wait before attempting to detect" - ++ "file modification, in microseconds"