packages feed

cabal-install 2.2.0.0 → 2.4.0.0

raw patch · 103 files changed

+4517/−10188 lines, 103 filesdep +parsecdep +textdep +zip-archivedep −QuickCheckdep −cabal-installdep −pretty-showdep ~Cabaldep ~arraydep ~asyncbinary-added

Dependencies added: parsec, text, zip-archive

Dependencies removed: QuickCheck, cabal-install, pretty-show, tagged, tasty, tasty-hunit, tasty-quickcheck

Dependency ranges changed: Cabal, array, async, base, binary, bytestring, containers, deepseq, directory, edit-distance, filepath, hashable, mtl, network, network-uri, process, random, stm, tar, time, zlib

Files

Distribution/Client/Check.hs view
@@ -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)
Distribution/Client/CmdBench.hs view
@@ -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
Distribution/Client/CmdBuild.hs view
@@ -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
+ Distribution/Client/CmdClean.hs view
@@ -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
Distribution/Client/CmdErrorMessages.hs view
@@ -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 "
Distribution/Client/CmdFreeze.hs view
@@ -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
Distribution/Client/CmdHaddock.hs view
@@ -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
Distribution/Client/CmdInstall.hs view
@@ -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=<path>"-    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=<path>"+      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
+ Distribution/Client/CmdLegacy.hs view
@@ -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+            }
Distribution/Client/CmdRepl.hs view
@@ -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,
Distribution/Client/CmdRun.hs view
@@ -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 =
+ Distribution/Client/CmdSdist.hs view
@@ -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."+
Distribution/Client/CmdTest.hs view
@@ -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
Distribution/Client/CmdUpdate.hs view
@@ -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 ()
Distribution/Client/Compat/ExecutablePath.hs view
@@ -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.
Distribution/Client/Compat/Prelude.hs view
@@ -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
Distribution/Client/Compat/Process.hs view
@@ -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))
Distribution/Client/Config.hs view
@@ -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
Distribution/Client/Configure.hs view
@@ -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
Distribution/Client/Dependency.hs view
@@ -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"
Distribution/Client/DistDirLayout.hs view
@@ -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"
Distribution/Client/Fetch.hs view
@@ -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 ()
Distribution/Client/FetchUtils.hs view
@@ -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)
Distribution/Client/FileMonitor.hs view
@@ -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
Distribution/Client/GenBounds.hs view
@@ -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
Distribution/Client/Get.hs view
@@ -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)+
Distribution/Client/Haddock.hs view
@@ -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, _, _) <-
Distribution/Client/Init.hs view
@@ -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
Distribution/Client/Install.hs view
@@ -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
Distribution/Client/InstallPlan.hs view
@@ -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.
Distribution/Client/List.hs view
@@ -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)
Distribution/Client/Outdated.hs view
@@ -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
Distribution/Client/PackageHash.hs view
@@ -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/<libraryname>/libHS<libraryname>.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<very short libraryname>.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"-
Distribution/Client/PackageUtils.hs view
@@ -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).
Distribution/Client/ProjectBuilding.hs view
@@ -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-
Distribution/Client/ProjectBuilding/Types.hs view
@@ -204,4 +204,3 @@                         | BenchFailed     SomeException                         | InstallFailed   SomeException   deriving Show-
Distribution/Client/ProjectConfig.hs view
@@ -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
Distribution/Client/ProjectConfig/Legacy.hs view
@@ -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
Distribution/Client/ProjectConfig/Types.hs view
@@ -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
Distribution/Client/ProjectOrchestration.hs view
@@ -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 {
Distribution/Client/ProjectPlanOutput.hs view
@@ -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-
Distribution/Client/ProjectPlanning.hs view
@@ -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"-
Distribution/Client/ProjectPlanning/Types.hs view
@@ -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
Distribution/Client/RebuildMonad.hs view
@@ -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
Distribution/Client/Run.hs view
@@ -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
Distribution/Client/Setup.hs view
@@ -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 ->
Distribution/Client/SetupWrapper.hs view
@@ -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
Distribution/Client/SrcDist.hs view
@@ -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 ()
Distribution/Client/TargetSelector.hs view
@@ -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 ]
Distribution/Client/Targets.hs view
@@ -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
Distribution/Client/Types.hs view
@@ -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)
Distribution/Client/Upload.hs view
@@ -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.
Distribution/Client/Utils.hs view
@@ -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    "
+ Distribution/Client/VCS.hs view
@@ -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+        _ -> ""+  }+
Distribution/Solver/Modular.hs view
@@ -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 [])
Distribution/Solver/Modular/Builder.hs view
@@ -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
Distribution/Solver/Modular/ConflictSet.hs view
@@ -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
Distribution/Solver/Modular/Dependency.hs view
@@ -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
Distribution/Solver/Modular/Explore.hs view
@@ -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
Distribution/Solver/Modular/Index.hs view
@@ -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     }
Distribution/Solver/Modular/IndexConversion.hs view
@@ -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
Distribution/Solver/Modular/Linking.hs view
@@ -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
Distribution/Solver/Modular/Log.hs view
@@ -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  = ""
Distribution/Solver/Modular/Message.hs view
@@ -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
Distribution/Solver/Modular/Solver.hs view
@@ -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
Distribution/Solver/Modular/Tree.hs view
@@ -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'
Distribution/Solver/Modular/Validate.hs view
@@ -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   }
bootstrap.sh view
@@ -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}
cabal-install.cabal view
@@ -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
changelog view
@@ -1,7 +1,58 @@ -*-change-log-*- +2.4.0.0 Mikhail Glushenkov <mikhail.glushenkov@gmail.com> 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 <mikhail.glushenkov@gmail.com> 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 <mikhail.glushenkov@gmail.com> December 2017 	* Support for GHC's numeric -g debug levels (#4673).
main/Main.hs view
@@ -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)
− tests/IntegrationTests2.hs 
@@ -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 <https://github.com/haskell/cabal/issues/3324>----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"
+ tests/IntegrationTests2/build/local-tarball/cabal.project view
@@ -0,0 +1,2 @@+packages: p-0.1.tar.gz+          q/
+ tests/IntegrationTests2/build/local-tarball/p-0.1.tar.gz view

binary file changed (absent → 319 bytes)

+ tests/IntegrationTests2/build/local-tarball/q/Q.hs view
@@ -0,0 +1,5 @@+module Q where++import P++q = p ++ " world"
+ tests/IntegrationTests2/build/local-tarball/q/q.cabal view
@@ -0,0 +1,8 @@+name: q+version: 0.1+build-type: Simple+cabal-version: >= 1.2++library+  exposed-modules: Q+  build-depends: base, p
− tests/MemoryUsageTests.hs 
@@ -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
− tests/SolverQuickCheck.hs 
@@ -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
− tests/UnitTests.hs 
@@ -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')-
− tests/UnitTests/Distribution/Client/ArbitraryInstances.hs 
@@ -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)-                          ]
− tests/UnitTests/Distribution/Client/FileMonitor.hs 
@@ -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
− tests/UnitTests/Distribution/Client/GZipUtils.hs 
@@ -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
− tests/UnitTests/Distribution/Client/Glob.hs 
@@ -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'] \\ "*{},/\\"-
− tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs 
@@ -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)
− tests/UnitTests/Distribution/Client/InstallPlan.hs 
@@ -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 <http://stackoverflow.com/questions/12790337/generating-a-random-dag>------ 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];"--}
− tests/UnitTests/Distribution/Client/JobControl.hs 
@@ -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')-
− tests/UnitTests/Distribution/Client/ProjectConfig.hs 
@@ -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')) ]
− tests/UnitTests/Distribution/Client/Sandbox.hs 
@@ -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'
− tests/UnitTests/Distribution/Client/Sandbox/Timestamp.hs 
@@ -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
− tests/UnitTests/Distribution/Client/Store.hs 
@@ -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-
− tests/UnitTests/Distribution/Client/Tar.hs 
@@ -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
− tests/UnitTests/Distribution/Client/Targets.hs 
@@ -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]
− tests/UnitTests/Distribution/Client/UserConfig.hs 
@@ -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"]
− tests/UnitTests/Distribution/Solver/Modular/Builder.hs 
@@ -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
− tests/UnitTests/Distribution/Solver/Modular/DSL.hs 
@@ -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 "<<path>>"-          , 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)
− tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs 
@@ -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))
− tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs 
@@ -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
− tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs 
@@ -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)]]
− tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs 
@@ -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
− tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs 
@@ -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
− tests/UnitTests/Distribution/Solver/Modular/Solver.hs 
@@ -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"]-  ]
− tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs 
@@ -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
− tests/UnitTests/Options.hs 
@@ -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"