cabal-install 3.0.0.0 → 3.2.0.0
raw patch · 105 files changed
+2905/−1640 lines, 105 filesdep +lukkodep +semigroupsdep +transformersdep ~Cabaldep ~basedep ~hackage-securitynew-uploader
Dependencies added: lukko, semigroups, transformers
Dependency ranges changed: Cabal, base, hackage-security
Files
- Distribution/Client/BuildReports/Storage.hs +2/−0
- Distribution/Client/BuildReports/Types.hs +2/−0
- Distribution/Client/CmdBench.hs +9/−5
- Distribution/Client/CmdBuild.hs +11/−6
- Distribution/Client/CmdConfigure.hs +9/−6
- Distribution/Client/CmdErrorMessages.hs +6/−4
- Distribution/Client/CmdExec.hs +12/−10
- Distribution/Client/CmdFreeze.hs +9/−5
- Distribution/Client/CmdHaddock.hs +9/−6
- Distribution/Client/CmdInstall.hs +219/−141
- Distribution/Client/CmdInstall/ClientInstallFlags.hs +14/−7
- Distribution/Client/CmdLegacy.hs +14/−11
- Distribution/Client/CmdRepl.hs +34/−24
- Distribution/Client/CmdRun.hs +87/−42
- Distribution/Client/CmdRun/ClientRunFlags.hs +39/−0
- Distribution/Client/CmdSdist.hs +8/−10
- Distribution/Client/CmdTest.hs +9/−5
- Distribution/Client/CmdUpdate.hs +11/−6
- Distribution/Client/Compat/FileLock.hsc +0/−201
- Distribution/Client/Compat/Orphans.hs +40/−0
- Distribution/Client/Compat/Prelude.hs +1/−0
- Distribution/Client/Compat/Semaphore.hs +4/−2
- Distribution/Client/Config.hs +185/−110
- Distribution/Client/Configure.hs +9/−6
- Distribution/Client/Dependency.hs +16/−4
- Distribution/Client/Dependency/Types.hs +8/−12
- Distribution/Client/DistDirLayout.hs +2/−2
- Distribution/Client/Exec.hs +1/−1
- Distribution/Client/Fetch.hs +3/−0
- Distribution/Client/FetchUtils.hs +6/−3
- Distribution/Client/FileMonitor.hs +37/−26
- Distribution/Client/Freeze.hs +3/−0
- Distribution/Client/GZipUtils.hs +3/−1
- Distribution/Client/GenBounds.hs +4/−3
- Distribution/Client/Get.hs +52/−16
- Distribution/Client/Glob.hs +4/−0
- Distribution/Client/GlobalFlags.hs +30/−10
- Distribution/Client/HashValue.hs +86/−0
- Distribution/Client/HttpUtils.hs +14/−11
- Distribution/Client/IndexUtils.hs +227/−72
- Distribution/Client/IndexUtils/Timestamp.hs +8/−9
- Distribution/Client/Init.hs +12/−9
- Distribution/Client/Init/Heuristics.hs +10/−7
- Distribution/Client/Install.hs +36/−26
- Distribution/Client/InstallPlan.hs +32/−26
- Distribution/Client/InstallSymlink.hs +12/−7
- Distribution/Client/List.hs +28/−22
- Distribution/Client/Outdated.hs +6/−4
- Distribution/Client/PackageHash.hs +3/−78
- Distribution/Client/ParseUtils.hs +114/−22
- Distribution/Client/ProjectBuilding.hs +26/−30
- Distribution/Client/ProjectConfig.hs +76/−39
- Distribution/Client/ProjectConfig/Legacy.hs +122/−84
- Distribution/Client/ProjectConfig/Types.hs +25/−11
- Distribution/Client/ProjectOrchestration.hs +9/−3
- Distribution/Client/ProjectPlanOutput.hs +13/−10
- Distribution/Client/ProjectPlanning.hs +85/−75
- Distribution/Client/ProjectPlanning/Types.hs +14/−7
- Distribution/Client/RebuildMonad.hs +1/−1
- Distribution/Client/Sandbox.hs +6/−5
- Distribution/Client/Security/HTTP.hs +8/−2
- Distribution/Client/Setup.hs +78/−23
- Distribution/Client/SetupWrapper.hs +4/−1
- Distribution/Client/SolverInstallPlan.hs +12/−29
- Distribution/Client/SourceRepo.hs +97/−0
- Distribution/Client/SourceRepoParse.hs +0/−23
- Distribution/Client/Store.hs +32/−6
- Distribution/Client/TargetSelector.hs +7/−3
- Distribution/Client/Targets.hs +3/−0
- Distribution/Client/Types.hs +70/−29
- Distribution/Client/Update.hs +1/−0
- Distribution/Client/Utils/Parsec.hs +1/−1
- Distribution/Client/VCS.hs +64/−82
- Distribution/Deprecated/Text.hs +0/−1
- Distribution/Deprecated/ViewAsFieldDescr.hs +3/−2
- Distribution/Solver/Modular.hs +1/−1
- Distribution/Solver/Modular/Builder.hs +3/−1
- Distribution/Solver/Modular/ConfiguredConversion.hs +1/−1
- Distribution/Solver/Modular/ConflictSet.hs +71/−33
- Distribution/Solver/Modular/Dependency.hs +64/−8
- Distribution/Solver/Modular/Explore.hs +161/−34
- Distribution/Solver/Modular/IndexConversion.hs +1/−1
- Distribution/Solver/Modular/Linking.hs +5/−3
- Distribution/Solver/Modular/Message.hs +112/−0
- Distribution/Solver/Modular/Package.hs +7/−8
- Distribution/Solver/Modular/Preference.hs +3/−1
- Distribution/Solver/Modular/Solver.hs +3/−0
- Distribution/Solver/Modular/Validate.hs +47/−8
- Distribution/Solver/Types/ComponentDeps.hs +3/−1
- Distribution/Solver/Types/ConstraintSource.hs +3/−1
- Distribution/Solver/Types/InstSolverPackage.hs +3/−1
- Distribution/Solver/Types/OptionalStanza.hs +3/−1
- Distribution/Solver/Types/PackageConstraint.hs +3/−1
- Distribution/Solver/Types/PackageIndex.hs +4/−3
- Distribution/Solver/Types/PkgConfigDb.hs +29/−22
- Distribution/Solver/Types/ResolverPackage.hs +3/−1
- Distribution/Solver/Types/Settings.hs +19/−1
- Distribution/Solver/Types/SolverId.hs +3/−1
- Distribution/Solver/Types/SolverPackage.hs +3/−1
- Distribution/Solver/Types/SourcePackage.hs +4/−2
- bootstrap.sh +8/−8
- cabal-install.cabal +25/−10
- changelog +37/−2
- main/Main.hs +19/−13
- tests/README.md +0/−27
Distribution/Client/BuildReports/Storage.hs view
@@ -1,3 +1,5 @@+-- TODO+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Reporting
Distribution/Client/BuildReports/Types.hs view
@@ -27,12 +27,14 @@ ( isAlpha, toLower ) import GHC.Generics (Generic) import Distribution.Compat.Binary (Binary)+import Distribution.Utils.Structured (Structured) data ReportLevel = NoReports | AnonymousReports | DetailedReports deriving (Eq, Ord, Enum, Show, Generic) instance Binary ReportLevel+instance Structured ReportLevel instance Text.Text ReportLevel where disp NoReports = Disp.text "none"
Distribution/Client/CmdBench.hs view
@@ -20,7 +20,7 @@ ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup- ( HaddockFlags, TestFlags, fromFlagOrDefault )+ ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Deprecated.Text@@ -33,7 +33,9 @@ import Control.Monad (when) -benchCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)+benchCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags+ ) benchCommand = Client.installCommand { commandName = "v2-bench", commandSynopsis = "Run benchmarks",@@ -73,9 +75,11 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---benchAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)+benchAction :: ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO ()-benchAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags)+benchAction ( configFlags, configExFlags, installFlags+ , haddockFlags, testFlags, benchmarkFlags ) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand@@ -119,7 +123,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here- haddockFlags testFlags+ haddockFlags testFlags benchmarkFlags -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
Distribution/Client/CmdBuild.hs view
@@ -11,16 +11,18 @@ selectComponentTarget ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages -import Distribution.Compat.Semigroup ((<>)) import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags , liftOptions, yesNoOpt ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup- ( HaddockFlags, TestFlags+ ( HaddockFlags, TestFlags, BenchmarkFlags , Flag(..), toFlag, fromFlag, fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives, option )@@ -35,7 +37,8 @@ buildCommand :: CommandUI (BuildFlags, ( ConfigFlags, ConfigExFlags- , InstallFlags, HaddockFlags, TestFlags))+ , InstallFlags, HaddockFlags+ , TestFlags, BenchmarkFlags )) buildCommand = CommandUI { commandName = "v2-build", commandSynopsis = "Compile targets within the project.",@@ -103,11 +106,13 @@ -- buildAction :: ( BuildFlags- , (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags))+ , ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags )) -> [String] -> GlobalFlags -> IO () buildAction ( buildFlags- , (configFlags, configExFlags, installFlags, haddockFlags, testFlags))+ , ( configFlags, configExFlags, installFlags+ , haddockFlags, testFlags, benchmarkFlags )) targetStrings globalFlags = do -- TODO: This flags defaults business is ugly let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags@@ -159,7 +164,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here- haddockFlags testFlags+ haddockFlags testFlags benchmarkFlags -- | This defines what a 'TargetSelector' means for the @bench@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
Distribution/Client/CmdConfigure.hs view
@@ -16,7 +16,7 @@ import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import Distribution.Simple.Setup- ( HaddockFlags, TestFlags, fromFlagOrDefault )+ ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) import Distribution.Verbosity ( normal ) @@ -26,8 +26,9 @@ ( wrapText, notice ) import qualified Distribution.Client.Setup as Client -configureCommand :: CommandUI (ConfigFlags, ConfigExFlags- ,InstallFlags, HaddockFlags, TestFlags)+configureCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags+ ) configureCommand = Client.installCommand { commandName = "v2-configure", commandSynopsis = "Add extra project configuration",@@ -78,9 +79,11 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---configureAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)+configureAction :: ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO ()-configureAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags)+configureAction ( configFlags, configExFlags, installFlags+ , haddockFlags, testFlags, benchmarkFlags ) _extraArgs globalFlags = do --TODO: deal with _extraArgs, since flags with wrong syntax end up there @@ -123,5 +126,5 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here- haddockFlags testFlags+ haddockFlags testFlags benchmarkFlags
Distribution/Client/CmdErrorMessages.hs view
@@ -7,6 +7,9 @@ module Distribution.Client.TargetSelector, ) where +import Distribution.Client.Compat.Prelude+import Prelude ()+ import Distribution.Client.ProjectOrchestration import Distribution.Client.TargetSelector ( ComponentKindFilter, componentKind, showTargetSelector )@@ -22,8 +25,7 @@ import Distribution.Deprecated.Text ( display ) -import Data.Maybe (isNothing)-import Data.List (sortBy, groupBy, nub)+import qualified Data.List.NonEmpty as NE import Data.Function (on) @@ -77,8 +79,8 @@ -- > | (pkgname, components) <- sortGroupOn packageName allcomponents ] -- sortGroupOn :: Ord b => (a -> b) -> [a] -> [(b, [a])]-sortGroupOn key = map (\xs@(x:_) -> (key x, xs))- . groupBy ((==) `on` key)+sortGroupOn key = map (\(x:|xs) -> (key x, x:xs))+ . NE.groupBy ((==) `on` key) . sortBy (compare `on` key)
Distribution/Client/CmdExec.hs view
@@ -76,11 +76,13 @@ import Distribution.Simple.Setup ( HaddockFlags , TestFlags+ , BenchmarkFlags , fromFlagOrDefault ) import Distribution.Simple.Utils ( die' , info+ , createDirectoryIfMissingVerbose , withTempDirectory , wrapText )@@ -92,11 +94,12 @@ import Prelude () import Distribution.Client.Compat.Prelude -import Data.Set (Set) import qualified Data.Set as S import qualified Data.Map as M -execCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)+execCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags+ ) execCommand = CommandUI { commandName = "v2-exec" , commandSynopsis = "Give a command access to the store."@@ -121,9 +124,11 @@ , commandDefaultFlags = commandDefaultFlags Client.installCommand } -execAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)+execAction :: ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO ()-execAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags)+execAction ( configFlags, configExFlags, installFlags+ , haddockFlags, testFlags, benchmarkFlags ) extraArgs globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand@@ -197,7 +202,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here- haddockFlags testFlags+ haddockFlags testFlags benchmarkFlags withOverrides env args program = program { programOverrideEnv = programOverrideEnv program ++ env , programDefaultArgs = programDefaultArgs program ++ args}@@ -219,11 +224,8 @@ -> PostBuildProjectStatus -> ([(String, Maybe String)] -> IO a) -> IO a-withTempEnvFile verbosity- baseCtx- buildCtx- buildStatus- action =+withTempEnvFile verbosity baseCtx buildCtx buildStatus action = do+ createDirectoryIfMissingVerbose verbosity True (distTempDirectory (distDirLayout baseCtx)) withTempDirectory verbosity (distTempDirectory (distDirLayout baseCtx))
Distribution/Client/CmdFreeze.hs view
@@ -33,7 +33,7 @@ import Distribution.Client.Setup ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import Distribution.Simple.Setup- ( HaddockFlags, TestFlags, fromFlagOrDefault )+ ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) import Distribution.Simple.Utils ( die', notice, wrapText ) import Distribution.Verbosity@@ -49,7 +49,9 @@ import qualified Distribution.Client.Setup as Client -freezeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)+freezeCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags+ ) freezeCommand = Client.installCommand { commandName = "v2-freeze", commandSynopsis = "Freeze dependencies.",@@ -99,9 +101,11 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---freezeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)+freezeAction :: ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO ()-freezeAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags)+freezeAction ( configFlags, configExFlags, installFlags+ , haddockFlags, testFlags, benchmarkFlags ) extraArgs globalFlags = do unless (null extraArgs) $@@ -132,7 +136,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here- haddockFlags testFlags+ haddockFlags testFlags benchmarkFlags
Distribution/Client/CmdHaddock.hs view
@@ -20,7 +20,7 @@ ( GlobalFlags, ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup- ( HaddockFlags(..), TestFlags, fromFlagOrDefault )+ ( HaddockFlags(..), TestFlags, BenchmarkFlags(..), fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Verbosity@@ -31,8 +31,9 @@ import Control.Monad (when) -haddockCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags- ,HaddockFlags, TestFlags)+haddockCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags+ ) haddockCommand = Client.installCommand { commandName = "v2-haddock", commandSynopsis = "Build Haddock documentation",@@ -69,9 +70,11 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---haddockAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)+haddockAction :: ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO ()-haddockAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags)+haddockAction ( configFlags, configExFlags, installFlags+ , haddockFlags, testFlags, benchmarkFlags ) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand@@ -113,7 +116,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here- haddockFlags testFlags+ haddockFlags testFlags benchmarkFlags -- | This defines what a 'TargetSelector' means for the @haddock@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
Distribution/Client/CmdInstall.hs view
@@ -32,7 +32,7 @@ import Distribution.Client.Setup ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..) , configureExOptions, haddockOptions, installOptions, testOptions- , configureOptions, liftOptions )+ , benchmarkOptions, configureOptions, liftOptions ) import Distribution.Solver.Types.ConstraintSource ( ConstraintSource(..) ) import Distribution.Client.Types@@ -73,7 +73,7 @@ ( getSourcePackages, getInstalledPackages ) import Distribution.Client.ProjectConfig ( readGlobalConfig, projectConfigWithBuilderRepoContext- , resolveBuildTimeSettings, withProjectOrGlobalConfig )+ , resolveBuildTimeSettings, withProjectOrGlobalConfigIgn ) import Distribution.Client.ProjectPlanning ( storePackageInstallDirs' ) import qualified Distribution.Simple.InstallDirs as InstallDirs@@ -87,7 +87,8 @@ import Distribution.Client.InstallSymlink ( OverwritePolicy(..), symlinkBinary ) import Distribution.Simple.Setup- ( Flag(..), HaddockFlags, TestFlags, fromFlagOrDefault, flagToMaybe )+ ( Flag(..), HaddockFlags, TestFlags, BenchmarkFlags+ , fromFlagOrDefault, flagToMaybe ) import Distribution.Solver.Types.SourcePackage ( SourcePackage(..) ) import Distribution.Simple.Command@@ -107,7 +108,7 @@ import Distribution.Types.UnitId ( UnitId ) import Distribution.Types.UnqualComponentName- ( UnqualComponentName, unUnqualComponentName, mkUnqualComponentName )+ ( UnqualComponentName, unUnqualComponentName ) import Distribution.Verbosity ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils@@ -115,7 +116,7 @@ , withTempDirectory, createDirectoryIfMissingVerbose , ordNub ) import Distribution.Utils.Generic- ( writeFileAtomic )+ ( safeHead, writeFileAtomic ) import Distribution.Deprecated.Text ( simpleParse ) import Distribution.Pretty@@ -124,7 +125,7 @@ import Control.Exception ( catch ) import Control.Monad- ( mapM, mapM_ )+ ( mapM, forM_ ) import qualified Data.ByteString.Lazy.Char8 as BS import Data.Either ( partitionEithers )@@ -142,7 +143,8 @@ installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags- , HaddockFlags, TestFlags, ClientInstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags+ , ClientInstallFlags ) installCommand = CommandUI { commandName = "v2-install"@@ -178,7 +180,8 @@ (filter ((`notElem` ["constraint", "dependency" , "exact-configuration"]) . optionName) $ configureOptions showOrParseArgs)- ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)+ ++ liftOptions get2 set2 (configureExOptions showOrParseArgs+ ConstraintSourceCommandlineFlag) ++ liftOptions get3 set3 -- hide "target-package-db" and "symlink-bindir" flags from the -- install options.@@ -193,16 +196,19 @@ . optionName) $ haddockOptions showOrParseArgs) ++ liftOptions get5 set5 (testOptions showOrParseArgs)- ++ liftOptions get6 set6 (clientInstallOptions showOrParseArgs)- , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, defaultClientInstallFlags)+ ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs)+ ++ liftOptions get7 set7 (clientInstallOptions showOrParseArgs)+ , commandDefaultFlags = ( mempty, mempty, mempty, mempty, mempty, mempty+ , defaultClientInstallFlags ) } where- get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f)- get2 (_,b,_,_,_,_) = b; set2 b (a,_,c,d,e,f) = (a,b,c,d,e,f)- get3 (_,_,c,_,_,_) = c; set3 c (a,b,_,d,e,f) = (a,b,c,d,e,f)- get4 (_,_,_,d,_,_) = d; set4 d (a,b,c,_,e,f) = (a,b,c,d,e,f)- get5 (_,_,_,_,e,_) = e; set5 e (a,b,c,d,_,f) = (a,b,c,d,e,f)- get6 (_,_,_,_,_,f) = f; set6 f (a,b,c,d,e,_) = (a,b,c,d,e,f)+ get1 (a,_,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f,g) = (a,b,c,d,e,f,g)+ get2 (_,b,_,_,_,_,_) = b; set2 b (a,_,c,d,e,f,g) = (a,b,c,d,e,f,g)+ get3 (_,_,c,_,_,_,_) = c; set3 c (a,b,_,d,e,f,g) = (a,b,c,d,e,f,g)+ get4 (_,_,_,d,_,_,_) = d; set4 d (a,b,c,_,e,f,g) = (a,b,c,d,e,f,g)+ get5 (_,_,_,_,e,_,_) = e; set5 e (a,b,c,d,_,f,g) = (a,b,c,d,e,f,g)+ get6 (_,_,_,_,_,f,_) = f; set6 f (a,b,c,d,e,_,g) = (a,b,c,d,e,f,g)+ get7 (_,_,_,_,_,_,g) = g; set7 g (a,b,c,d,e,f,_) = (a,b,c,d,e,f,g) -- | The @install@ command actually serves four different needs. It installs:@@ -222,10 +228,16 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, ClientInstallFlags)- -> [String] -> GlobalFlags -> IO ()-installAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags, clientInstallFlags')- targetStrings globalFlags = do+installAction+ :: ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags+ , ClientInstallFlags)+ -> [String] -> GlobalFlags+ -> IO ()+installAction ( configFlags, configExFlags, installFlags+ , haddockFlags, testFlags, benchmarkFlags+ , clientInstallFlags' )+ 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 -- enabled.@@ -245,38 +257,49 @@ pure $ savedClientInstallFlags savedConfig `mappend` clientInstallFlags' let- installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags)- targetFilter = if installLibs then Just LibKind else Just ExeKind+ installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags)+ targetFilter = if installLibs then Just LibKind else Just ExeKind targetStrings' = if null targetStrings then ["."] else targetStrings + withProject :: IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector], ProjectConfig) withProject = do let verbosity' = lessVerbose verbosity -- First, we need to learn about what's available to be installed.- localBaseCtx <- establishProjectBaseContext verbosity' cliConfig InstallCommand+ localBaseCtx <- establishProjectBaseContext verbosity'+ cliConfig InstallCommand let localDistDirLayout = distDirLayout localBaseCtx- pkgDb <- projectConfigWithBuilderRepoContext verbosity' (buildSettings localBaseCtx) (getSourcePackages verbosity)+ pkgDb <- projectConfigWithBuilderRepoContext verbosity'+ (buildSettings localBaseCtx) (getSourcePackages verbosity) let- (targetStrings'', packageIds) = partitionEithers . flip fmap targetStrings' $+ (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+ _ -> Left str+ packageSpecifiers =+ flip fmap packageIds $ \case PackageIdentifier{..} | pkgVersion == nullVersion -> NamedPackage pkgName []- | otherwise ->- NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)]- packageTargets = flip TargetPackageNamed targetFilter . pkgName <$> packageIds+ | otherwise -> NamedPackage pkgName+ [PackagePropertyVersion+ (thisVersion pkgVersion)]+ packageTargets =+ flip TargetPackageNamed targetFilter . pkgName <$> packageIds if null targetStrings' then return (packageSpecifiers, packageTargets, projectConfig localBaseCtx) else do- targetSelectors <- either (reportTargetSelectorProblems verbosity) return- =<< readTargetSelectors (localPackages localBaseCtx) Nothing targetStrings''+ targetSelectors <-+ either (reportTargetSelectorProblems verbosity) return+ =<< readTargetSelectors (localPackages localBaseCtx)+ Nothing targetStrings'' - (specs, selectors) <- withInstallPlan verbosity' localBaseCtx $ \elaboratedPlan _ -> do+ (specs, selectors) <-+ withInstallPlan verbosity' localBaseCtx $ \elaboratedPlan _ -> do -- Split into known targets and hackage packages. (targets, hackageNames) <- case resolveTargets@@ -286,10 +309,10 @@ elaboratedPlan (Just pkgDb) targetSelectors of- Right targets -> do+ Right targets -> -- Everything is a local dependency. return (targets, [])- Left errs -> do+ Left errs -> do -- Not everything is local. let (errs', hackageNames) = partitionEithers . flip fmap errs $ \case@@ -316,10 +339,13 @@ | name `elem` hackageNames -> False TargetPackageNamed name _ | name `elem` hackageNames -> False- _ -> True+ _ -> True - -- This can't fail, because all of the errors are removed (or we've given up).- targets <- either (reportTargetProblems verbosity) return $ resolveTargets+ -- 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@@ -333,7 +359,8 @@ planMap = InstallPlan.toMap elaboratedPlan targetIds = Map.keys targets - sdistize (SpecificSourcePackage spkg@SourcePackage{..}) = SpecificSourcePackage spkg'+ sdistize (SpecificSourcePackage spkg@SourcePackage{..}) =+ SpecificSourcePackage spkg' where sdistPath = distSdistFile localDistDirLayout packageInfoId spkg' = spkg { packageSource = LocalTarballPackage sdistPath }@@ -344,31 +371,35 @@ gatherTargets :: UnitId -> TargetSelector gatherTargets targetId = TargetPackageNamed pkgName targetFilter where- Just targetUnit = Map.lookup targetId planMap+ targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap PackageIdentifier{..} = packageId targetUnit targets' = fmap gatherTargets targetIds hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage] hackagePkgs = flip NamedPackage [] <$> hackageNames+ hackageTargets :: [TargetSelector]- hackageTargets = flip TargetPackageNamed targetFilter <$> hackageNames+ hackageTargets =+ flip TargetPackageNamed targetFilter <$> hackageNames createDirectoryIfMissing True (distSdistDirectory localDistDirLayout) - unless (Map.null targets) $- mapM_- (\(SpecificSourcePackage pkg) -> packageToSdist verbosity+ unless (Map.null targets) $ forM_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of+ SpecificSourcePackage pkg -> packageToSdist verbosity (distProjectRootDirectory localDistDirLayout) TarGzArchive (distSdistFile localDistDirLayout (packageId pkg)) pkg- ) (localPackages localBaseCtx)+ NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName if null targets then return (hackagePkgs, hackageTargets) else return (local ++ hackagePkgs, targets' ++ hackageTargets) - return (specs ++ packageSpecifiers, selectors ++ packageTargets, projectConfig localBaseCtx)+ return ( specs ++ packageSpecifiers+ , selectors ++ packageTargets+ , projectConfig localBaseCtx ) + withoutProject :: ProjectConfig -> IO ([PackageSpecifier pkg], [TargetSelector], ProjectConfig) withoutProject globalConfig = do let parsePkg pkgName@@ -415,21 +446,29 @@ packageSpecifiers = flip fmap packageIds $ \case PackageIdentifier{..} | pkgVersion == nullVersion -> NamedPackage pkgName []- | otherwise ->- NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)]+ | otherwise -> NamedPackage pkgName+ [PackagePropertyVersion+ (thisVersion pkgVersion)] packageTargets = flip TargetPackageNamed Nothing . pkgName <$> packageIds return (packageSpecifiers, packageTargets, projectConfig) - (specs, selectors, config) <- withProjectOrGlobalConfig verbosity globalConfigFlag- withProject withoutProject+ let+ ignoreProject = fromFlagOrDefault False (cinstIgnoreProject clientInstallFlags) + (specs, selectors, config) <-+ withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag withProject withoutProject+ home <- getHomeDirectory let ProjectConfig {+ projectConfigBuildOnly = ProjectConfigBuildOnly {+ projectConfigLogsDir+ }, projectConfigShared = ProjectConfigShared { projectConfigHcFlavor, projectConfigHcPath,- projectConfigHcPkg+ projectConfigHcPkg,+ projectConfigStoreDir }, projectConfigLocalPackages = PackageConfig { packageConfigProgramPaths,@@ -461,20 +500,21 @@ home </> ".ghc" </> ghcPlatformAndVersionString platform compilerVersion </> "environments" </> name localEnv dir =- dir </> ".ghc.environment." ++ ghcPlatformAndVersionString platform compilerVersion+ 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+ _ -> False envFile <- case flagToMaybe (cinstEnvironmentPath clientInstallFlags) 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+ | otherwise -> do spec' <- makeAbsolute spec isDir <- doesDirectoryExist spec' if isDir@@ -483,7 +523,7 @@ then return (localEnv spec') -- Otherwise, treat it like a literal file path. else return spec'- Nothing -> return (globalEnv "default")+ Nothing -> return (globalEnv "default") envFileExists <- doesFileExist envFile envEntries <- filterEnvEntries <$> if@@ -495,20 +535,29 @@ else return [] cabalDir <- getCabalDir- mstoreDir <- sequenceA $ makeAbsolute <$> flagToMaybe (globalStoreDir globalFlags)+ mstoreDir <-+ sequenceA $ makeAbsolute <$> flagToMaybe projectConfigStoreDir let- mlogsDir = flagToMaybe (globalLogsDir globalFlags)+ mlogsDir = flagToMaybe projectConfigLogsDir cabalLayout = mkCabalDirLayout cabalDir mstoreDir mlogsDir packageDbs = storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId installedIndex <- getInstalledPackages verbosity compiler packageDbs progDb - let (envSpecs, envEntries') = environmentFileToSpecifiers installedIndex envEntries+ 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++ -- if we are installing executables, we shouldn't take into account+ -- environment specifiers.+ let envSpecs' :: [PackageSpecifier a]+ envSpecs' | installLibs = envSpecs+ | otherwise = []+ withTempDirectory verbosity globalTmp@@ -518,7 +567,7 @@ verbosity config tmpDir- (envSpecs ++ specs)+ (envSpecs' ++ specs) InstallCommand buildCtx <-@@ -560,65 +609,78 @@ -- Then, install! when (not dryRun) $ if installLibs- then installLibraries verbosity buildCtx compiler packageDbs progDb envFile envEntries'- else installExes verbosity baseCtx buildCtx platform compiler clientInstallFlags+ then installLibraries verbosity+ buildCtx compiler packageDbs progDb envFile envEntries'+ else installExes verbosity+ baseCtx buildCtx platform compiler configFlags clientInstallFlags where configFlags' = disableTestsBenchsByDefault configFlags verbosity = fromFlagOrDefault normal (configVerbosity configFlags') cliConfig = commandLineFlagsToProjectConfig globalFlags configFlags' configExFlags installFlags clientInstallFlags'- haddockFlags testFlags+ haddockFlags testFlags benchmarkFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) -- | Install any built exe by symlinking/copying it -- we don't use BuildOutcomes because we also need the component names-installExes :: Verbosity- -> ProjectBaseContext- -> ProjectBuildContext- -> Platform- -> Compiler- -> ClientInstallFlags- -> IO ()+installExes+ :: Verbosity+ -> ProjectBaseContext+ -> ProjectBuildContext+ -> Platform+ -> Compiler+ -> ConfigFlags+ -> ClientInstallFlags+ -> IO () installExes verbosity baseCtx buildCtx platform compiler- clientInstallFlags = do+ configFlags clientInstallFlags = do let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx- let mkUnitBinDir :: UnitId -> FilePath- mkUnitBinDir = InstallDirs.bindir .- storePackageInstallDirs'- storeDirLayout- (compilerId compiler)++ prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags))+ suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags))++ mkUnitBinDir :: UnitId -> FilePath+ mkUnitBinDir =+ InstallDirs.bindir .+ storePackageInstallDirs' storeDirLayout (compilerId compiler)+ mkExeName :: UnqualComponentName -> FilePath mkExeName exe = unUnqualComponentName exe <.> exeExtension platform++ mkFinalExeName :: UnqualComponentName -> FilePath+ mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform installdirUnknown = "installdir is not defined. Set it in your cabal config file " ++ "or use --installdir=<path>"- installdir <- fromFlagOrDefault (die' verbosity installdirUnknown)- $ pure <$> cinstInstalldir clientInstallFlags++ installdir <- fromFlagOrDefault (die' verbosity installdirUnknown) $+ pure <$> cinstInstalldir clientInstallFlags createDirectoryIfMissingVerbose verbosity False installdir warnIfNoExes verbosity buildCtx let doInstall = installUnitExes verbosity overwritePolicy- mkUnitBinDir mkExeName+ mkUnitBinDir mkExeName mkFinalExeName installdir installMethod in traverse_ doInstall $ Map.toList $ targetsMap buildCtx where- overwritePolicy = fromFlagOrDefault NeverOverwrite- $ cinstOverwritePolicy clientInstallFlags- installMethod = fromFlagOrDefault InstallMethodSymlink- $ cinstInstallMethod clientInstallFlags+ overwritePolicy = fromFlagOrDefault NeverOverwrite $+ cinstOverwritePolicy clientInstallFlags+ installMethod = fromFlagOrDefault InstallMethodSymlink $+ cinstInstallMethod clientInstallFlags -- | Install any built library by adding it to the default ghc environment-installLibraries :: Verbosity- -> ProjectBuildContext- -> Compiler- -> PackageDBStack- -> ProgramDb- -> FilePath -- ^ Environment file- -> [GhcEnvironmentFileEntry]- -> IO ()+installLibraries+ :: Verbosity+ -> ProjectBuildContext+ -> Compiler+ -> PackageDBStack+ -> ProgramDb+ -> FilePath -- ^ Environment file+ -> [GhcEnvironmentFileEntry]+ -> IO () installLibraries verbosity buildCtx compiler packageDbs programDb envFile envEntries = do -- Why do we get it again? If we updated a globalPackage then we need@@ -627,7 +689,8 @@ if supportsPkgEnvFiles $ getImplInfo compiler then do let- getLatest = fmap (head . snd) . take 1 . sortBy (comparing (Down . fst))+ getLatest :: PackageName -> [InstalledPackageInfo]+ getLatest = (=<<) (maybeToList . safeHead . snd) . take 1 . sortBy (comparing (Down . fst)) . PI.lookupPackageName installedIndex globalLatest = concat (getLatest <$> globalPackages) @@ -650,19 +713,19 @@ warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO () warnIfNoExes verbosity buildCtx = when noExes $- warn verbosity $ "You asked to install executables, "- <> "but there are no executables in "- <> plural (listPlural selectors) "target" "targets" <> ": "- <> intercalate ", " (showTargetSelector <$> selectors) <> ". "- <> "Perhaps you want to use --lib "- <> "to install libraries instead."+ warn verbosity $+ "You asked to install executables, but there are no executables in "+ <> plural (listPlural selectors) "target" "targets" <> ": "+ <> intercalate ", " (showTargetSelector <$> selectors) <> ". "+ <> "Perhaps you want to use --lib to install libraries instead." where- targets = concat $ Map.elems $ targetsMap buildCtx+ targets = concat $ Map.elems $ targetsMap buildCtx components = fst <$> targets- selectors = concatMap snd targets- noExes = null $ catMaybes $ exeMaybe <$> components+ selectors = concatMap snd targets+ noExes = null $ catMaybes $ exeMaybe <$> components+ exeMaybe (ComponentTarget (CExeName exe) _) = Just exe- exeMaybe _ = Nothing+ exeMaybe _ = Nothing globalPackages :: [PackageName] globalPackages = mkPackageName <$>@@ -673,13 +736,16 @@ , "bin-package-db" ] -environmentFileToSpecifiers :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry]- -> ([PackageSpecifier a], [GhcEnvironmentFileEntry])+environmentFileToSpecifiers+ :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry]+ -> ([PackageSpecifier a], [GhcEnvironmentFileEntry]) environmentFileToSpecifiers ipi = foldMap $ \case (GhcEnvFilePackageId unitId)- | Just InstalledPackageInfo{ sourcePackageId = PackageIdentifier{..}, installedUnitId }+ | Just InstalledPackageInfo+ { sourcePackageId = PackageIdentifier{..}, installedUnitId } <- PI.lookupUnitId ipi unitId- , let pkgSpec = NamedPackage pkgName [PackagePropertyVersion (thisVersion pkgVersion)]+ , let pkgSpec = NamedPackage pkgName+ [PackagePropertyVersion (thisVersion pkgVersion)] -> if pkgName `elem` globalPackages then ([pkgSpec], []) else ([pkgSpec], [GhcEnvFilePackageId installedUnitId])@@ -693,19 +759,23 @@ , configBenchmarks = Flag False <> configBenchmarks configFlags } -- | Symlink/copy every exe from a package from the store to a given location-installUnitExes :: Verbosity- -> OverwritePolicy -- ^ Whether to overwrite existing files- -> (UnitId -> FilePath) -- ^ A function to get an UnitId's- -- store directory- -> (UnqualComponentName -> FilePath) -- ^ A function to get- -- ^ an exe's filename- -> FilePath- -> InstallMethod- -> ( UnitId- , [(ComponentTarget, [TargetSelector])] )- -> IO ()+installUnitExes+ :: Verbosity+ -> OverwritePolicy -- ^ Whether to overwrite existing files+ -> (UnitId -> FilePath) -- ^ A function to get an UnitId's+ -- ^ store directory+ -> (UnqualComponentName -> FilePath) -- ^ A function to get an+ -- ^ exe's filename+ -> (UnqualComponentName -> FilePath) -- ^ A function to get an+ -- ^ exe's final possibly+ -- ^ different to the name in the store.+ -> FilePath+ -> InstallMethod+ -> ( UnitId+ , [(ComponentTarget, [TargetSelector])] )+ -> IO () installUnitExes verbosity overwritePolicy- mkSourceBinDir mkExeName+ mkSourceBinDir mkExeName mkFinalExeName installdir installMethod (unit, components) = traverse_ installAndWarn exes@@ -717,38 +787,42 @@ success <- installBuiltExe verbosity overwritePolicy (mkSourceBinDir unit) (mkExeName exe)+ (mkFinalExeName exe) installdir installMethod let errorMessage = case overwritePolicy of- NeverOverwrite ->- "Path '" <> (installdir </> prettyShow exe) <> "' already exists. "- <> "Use --overwrite-policy=always to overwrite."- -- This shouldn't even be possible, but we keep it in case- -- symlinking/copying logic changes- AlwaysOverwrite -> case installMethod of- InstallMethodSymlink -> "Symlinking"- InstallMethodCopy -> "Copying"- <> " '" <> prettyShow exe <> "' failed."+ NeverOverwrite ->+ "Path '" <> (installdir </> prettyShow exe) <> "' already exists. "+ <> "Use --overwrite-policy=always to overwrite."+ -- This shouldn't even be possible, but we keep it in case+ -- symlinking/copying logic changes+ AlwaysOverwrite ->+ case installMethod of+ InstallMethodSymlink -> "Symlinking"+ InstallMethodCopy ->+ "Copying" <> " '" <> prettyShow exe <> "' failed." unless success $ die' verbosity errorMessage -- | Install a specific exe.-installBuiltExe :: Verbosity -> OverwritePolicy- -> FilePath -- ^ The directory where the built exe is located- -> FilePath -- ^ The exe's filename- -> FilePath -- ^ the directory where it should be installed- -> InstallMethod- -> IO Bool -- ^ Whether the installation was successful+installBuiltExe+ :: Verbosity -> OverwritePolicy+ -> FilePath -- ^ The directory where the built exe is located+ -> FilePath -- ^ The exe's filename+ -> FilePath -- ^ The exe's filename in the public install directory+ -> FilePath -- ^ the directory where it should be installed+ -> InstallMethod+ -> IO Bool -- ^ Whether the installation was successful installBuiltExe verbosity overwritePolicy- sourceDir exeName+ sourceDir exeName finalExeName installdir InstallMethodSymlink = do notice verbosity $ "Symlinking '" <> exeName <> "'" symlinkBinary overwritePolicy installdir sourceDir- (mkUnqualComponentName exeName)+ finalExeName exeName installBuiltExe verbosity overwritePolicy- sourceDir exeName+ sourceDir exeName finalExeName installdir InstallMethodCopy = do notice verbosity $ "Copying '" <> exeName <> "'" exists <- doesPathExist destination@@ -758,7 +832,7 @@ (False, _ ) -> copy where source = sourceDir </> exeName- destination = installdir </> exeName+ destination = installdir </> finalExeName remove = do isDir <- doesDirectoryExist destination if isDir@@ -774,7 +848,9 @@ hasLib (ComponentTarget (CLibName _) _, _) = True hasLib _ = False - go :: UnitId -> [(ComponentTarget, [TargetSelector])] -> [GhcEnvironmentFileEntry]+ go :: UnitId+ -> [(ComponentTarget, [TargetSelector])]+ -> [GhcEnvironmentFileEntry] go unitId targets | any hasLib targets = [GhcEnvFilePackageId unitId] | otherwise = []@@ -845,8 +921,9 @@ -- and disabled tests\/benchmarks, fail if there are no such -- components ---selectPackageTargets :: TargetSelector- -> [AvailableTarget k] -> Either TargetProblem [k]+selectPackageTargets+ :: TargetSelector+ -> [AvailableTarget k] -> Either TargetProblem [k] selectPackageTargets targetSelector targets -- If there are any buildable targets then we select those@@ -878,8 +955,9 @@ -- -- For the @build@ command we just need the basic checks on being buildable etc. ---selectComponentTarget :: SubComponentTarget- -> AvailableTarget k -> Either TargetProblem k+selectComponentTarget+ :: SubComponentTarget+ -> AvailableTarget k -> Either TargetProblem k selectComponentTarget subtarget = either (Left . TargetProblemCommon) Right . selectComponentTargetBasic subtarget
Distribution/Client/CmdInstall/ClientInstallFlags.hs view
@@ -25,13 +25,15 @@ deriving (Eq, Show, Generic, Bounded, Enum) instance Binary InstallMethod+instance Structured InstallMethod data ClientInstallFlags = ClientInstallFlags- { cinstInstallLibs :: Flag Bool+ { cinstInstallLibs :: Flag Bool+ , cinstIgnoreProject :: Flag Bool , cinstEnvironmentPath :: Flag FilePath , cinstOverwritePolicy :: Flag OverwritePolicy- , cinstInstallMethod :: Flag InstallMethod- , cinstInstalldir :: Flag FilePath+ , cinstInstallMethod :: Flag InstallMethod+ , cinstInstalldir :: Flag FilePath } deriving (Eq, Show, Generic) instance Monoid ClientInstallFlags where@@ -42,14 +44,16 @@ (<>) = gmappend instance Binary ClientInstallFlags+instance Structured ClientInstallFlags defaultClientInstallFlags :: ClientInstallFlags defaultClientInstallFlags = ClientInstallFlags- { cinstInstallLibs = toFlag False+ { cinstInstallLibs = toFlag False+ , cinstIgnoreProject = toFlag False , cinstEnvironmentPath = mempty , cinstOverwritePolicy = mempty- , cinstInstallMethod = mempty- , cinstInstalldir = mempty+ , cinstInstallMethod = mempty+ , cinstInstalldir = mempty } clientInstallOptions :: ShowOrParseArgs -> [OptionField ClientInstallFlags]@@ -58,6 +62,10 @@ "Install libraries rather than executables from the target package." cinstInstallLibs (\v flags -> flags { cinstInstallLibs = v }) trueArg+ , option "z" ["ignore-project"]+ "Ignore local project configuration"+ cinstIgnoreProject (\v flags -> flags { cinstIgnoreProject = v })+ trueArg , option [] ["package-env", "env"] "Set the environment file that may be modified." cinstEnvironmentPath (\pf flags -> flags { cinstEnvironmentPath = pf })@@ -103,4 +111,3 @@ showInstallMethodFlag (Flag InstallMethodCopy) = ["copy"] showInstallMethodFlag (Flag InstallMethodSymlink) = ["symlink"] showInstallMethodFlag NoFlag = []-
Distribution/Client/CmdLegacy.hs view
@@ -68,6 +68,9 @@ instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e) where verbosity (a, _, _, _, _) = verbosity a +instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e, f) where+ verbosity (a, _, _, _, _, _) = verbosity a+ instance HasVerbosity Setup.BuildFlags where verbosity = verbosity . Setup.buildVerbosity @@ -108,22 +111,22 @@ "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" +++ " Please file a bug if you cannot replicate a working v1- use case with the nix-style" ++ " commands.\n\n" ++ - "For more information, see: https://wiki.haskell.org/Cabal/NewBuild\n"+ "For more information, see: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html" toLegacyCmd :: CommandSpec (globals -> IO action) -> [CommandSpec (globals -> IO action)] toLegacyCmd mkSpec = [toLegacy mkSpec]- where- 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- }+ where+ 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+ } legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)] legacyCmd ui action = toLegacyCmd (regularCmd ui action)
Distribution/Client/CmdRepl.hs view
@@ -30,22 +30,21 @@ import Distribution.Client.ProjectBuilding ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages ) import Distribution.Client.ProjectConfig- ( ProjectConfig(..), withProjectOrGlobalConfig- , projectConfigConfigFile, readGlobalConfig )+ ( ProjectConfig(..), withProjectOrGlobalConfigIgn+ , projectConfigConfigFile ) import Distribution.Client.ProjectOrchestration import Distribution.Client.ProjectPlanning ( ElaboratedSharedConfig(..), ElaboratedInstallPlan ) import Distribution.Client.ProjectPlanning.Types ( elabOrderExeDependencies )-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, TestFlags, fromFlagOrDefault, replOptions+ ( HaddockFlags, TestFlags, BenchmarkFlags+ , fromFlagOrDefault, replOptions , Flag(..), toFlag, trueArg, falseArg ) import Distribution.Simple.Command ( CommandUI(..), liftOption, usageAlternatives, option@@ -90,6 +89,8 @@ ( anyVersion ) import Distribution.Deprecated.Text ( display )+import Distribution.Utils.Generic+ ( safeHead ) import Distribution.Verbosity ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils@@ -143,7 +144,10 @@ ("couldn't parse dependency: " ++) (parsecCommaList parsec) -replCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, ReplFlags, EnvFlags)+replCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags+ , ReplFlags, EnvFlags+ ) replCommand = Client.installCommand { commandName = "v2-repl", commandSynopsis = "Open an interactive session for the given component.",@@ -181,27 +185,31 @@ ++ "to the default component (or no component if there is no project present)\n" ++ cmdCommonHelpTextNewBuildBeta,- commandDefaultFlags = (configFlags,configExFlags,installFlags,haddockFlags,testFlags,[],defaultEnvFlags),+ commandDefaultFlags = ( configFlags, configExFlags, installFlags+ , haddockFlags, testFlags, benchmarkFlags+ , [], defaultEnvFlags+ ), commandOptions = \showOrParseArgs -> map liftOriginal (commandOptions Client.installCommand showOrParseArgs) ++ map liftReplOpts (replOptions showOrParseArgs) ++ map liftEnvOpts (envOptions showOrParseArgs) } where- (configFlags,configExFlags,installFlags,haddockFlags,testFlags) = commandDefaultFlags Client.installCommand+ (configFlags,configExFlags,installFlags,haddockFlags,testFlags,benchmarkFlags)+ = commandDefaultFlags Client.installCommand liftOriginal = liftOption projectOriginal updateOriginal liftReplOpts = liftOption projectReplOpts updateReplOpts liftEnvOpts = liftOption projectEnvOpts updateEnvOpts - projectOriginal (a,b,c,d,e,_,_) = (a,b,c,d,e)- updateOriginal (a,b,c,d,e) (_,_,_,_,_,f,g) = (a,b,c,d,e,f,g)+ projectOriginal (a,b,c,d,e,f,_,_) = (a,b,c,d,e,f)+ updateOriginal (a,b,c,d,e,f) (_,_,_,_,_,_,g,h) = (a,b,c,d,e,f,g,h) - projectReplOpts (_,_,_,_,_,f,_) = f- updateReplOpts f (a,b,c,d,e,_,g) = (a,b,c,d,e,f,g)+ projectReplOpts (_,_,_,_,_,_,g,_) = g+ updateReplOpts g (a,b,c,d,e,f,_,h) = (a,b,c,d,e,f,g,h) - projectEnvOpts (_,_,_,_,_,_,g) = g- updateEnvOpts g (a,b,c,d,e,f,_) = (a,b,c,d,e,f,g)+ projectEnvOpts (_,_,_,_,_,_,_,h) = h+ updateEnvOpts h (a,b,c,d,e,f,g,_) = (a,b,c,d,e,f,g,h) -- | 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@@ -214,20 +222,21 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---replAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags, ReplFlags, EnvFlags)+replAction :: ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags+ , ReplFlags, EnvFlags ) -> [String] -> GlobalFlags -> IO ()-replAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags, replFlags, envFlags)+replAction ( configFlags, configExFlags, installFlags+ , haddockFlags, testFlags, benchmarkFlags+ , replFlags, envFlags ) targetStrings globalFlags = do let ignoreProject = fromFlagOrDefault False (envIgnoreProject envFlags) with = withProject cliConfig verbosity targetStrings without config = withoutProject (config <> cliConfig) verbosity targetStrings - (baseCtx, targetSelectors, finalizer, replType) <- if ignoreProject- then do- globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag- without globalConfig- else withProjectOrGlobalConfig verbosity globalConfigFlag with without+ (baseCtx, targetSelectors, finalizer, replType) <-+ withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag with without when (buildSettingOnlyDeps (buildSettings baseCtx)) $ die' verbosity $ "The repl command does not support '--only-dependencies'. "@@ -241,13 +250,14 @@ -- 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 should be non-empty map, but there's no NonEmptyMap yet. targets <- validatedTargets elaboratedPlan targetSelectors let- (unitId, _) = head $ Map.toList targets+ (unitId, _) = fromMaybe (error "panic: targets should be non-empty") $ safeHead $ Map.toList targets originalDeps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan unitId oci = OriginalComponentInfo unitId originalDeps- Just pkgId = packageId <$> InstallPlan.lookup elaboratedPlan unitId + pkgId = fromMaybe (error $ "cannot find " ++ prettyShow unitId) $ packageId <$> InstallPlan.lookup elaboratedPlan unitId baseCtx' = addDepsToProjectTarget (envPackages envFlags) pkgId baseCtx return (Just oci, baseCtx')@@ -322,7 +332,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here- haddockFlags testFlags+ haddockFlags testFlags benchmarkFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) validatedTargets elaboratedPlan targetSelectors = do
Distribution/Client/CmdRun.hs view
@@ -18,20 +18,25 @@ ) where import Prelude ()-import Distribution.Client.Compat.Prelude+import Distribution.Client.Compat.Prelude hiding (toList) import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages +import Distribution.Client.CmdRun.ClientRunFlags+ import Distribution.Client.Setup- ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags )+ ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags(..)+ , configureExOptions, haddockOptions, installOptions, testOptions+ , benchmarkOptions, configureOptions, liftOptions )+import Distribution.Solver.Types.ConstraintSource+ ( ConstraintSource(..) ) import Distribution.Client.GlobalFlags ( defaultGlobalFlags )-import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup- ( HaddockFlags, TestFlags, fromFlagOrDefault )+ ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) import Distribution.Simple.Command- ( CommandUI(..), usageAlternatives )+ ( CommandUI(..), OptionField (..), usageAlternatives ) import Distribution.Types.ComponentName ( showComponentName ) import Distribution.Deprecated.Text@@ -45,7 +50,7 @@ ( establishDummyProjectBaseContext ) import Distribution.Client.ProjectConfig ( ProjectConfig(..), ProjectConfigShared(..)- , withProjectOrGlobalConfig )+ , withProjectOrGlobalConfigIgn ) import Distribution.Client.ProjectPlanning ( ElaboratedConfiguredPackage(..) , ElaboratedInstallPlan, binDirectoryFor )@@ -107,44 +112,77 @@ ( (</>), isValid, isPathSeparator, takeExtension ) -runCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)-runCommand = Client.installCommand {- commandName = "v2-run",- commandSynopsis = "Run an executable.",- commandUsage = usageAlternatives "v2-run"- [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ],- commandDescription = Just $ \pname -> wrapText $- "Runs the specified executable-like component (an executable, a test, "- ++ "or a benchmark), first ensuring it is up to date.\n\n"+runCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags+ , ClientRunFlags+ )+runCommand = CommandUI+ { commandName = "v2-run"+ , commandSynopsis = "Run an executable."+ , commandUsage = usageAlternatives "v2-run"+ [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ]+ , commandDescription = Just $ \pname -> wrapText $+ "Runs the specified executable-like component (an executable, a test, "+ ++ "or a benchmark), first ensuring it is up to date.\n\n" - ++ "Any executable-like component in any package in the project can be "- ++ "specified. A package can be specified if contains just one "- ++ "executable-like. The default is to use the package in the current "- ++ "directory if it contains just one executable-like.\n\n"+ ++ "Any executable-like component in any package in the project can be "+ ++ "specified. A package can be specified if contains just one "+ ++ "executable-like. The default is to use the package in the current "+ ++ "directory if it contains just one executable-like.\n\n" - ++ "Extra arguments can be passed to the program, but use '--' to "- ++ "separate arguments for the program from arguments for " ++ pname- ++ ". The executable is run in an environment where it can find its "- ++ "data files inplace in the build tree.\n\n"+ ++ "Extra arguments can be passed to the program, but use '--' to "+ ++ "separate arguments for the program from arguments for " ++ pname+ ++ ". The executable is run in an environment where it can find its "+ ++ "data files inplace in the build tree.\n\n" - ++ "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.",- commandNotes = Just $ \pname ->- "Examples:\n"- ++ " " ++ pname ++ " v2-run\n"- ++ " Run the executable-like in the package in the current directory\n"- ++ " " ++ pname ++ " v2-run foo-tool\n"- ++ " Run the named executable-like (in any package in the project)\n"- ++ " " ++ pname ++ " v2-run pkgfoo:foo-tool\n"- ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n"- ++ " " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n"- ++ " Build with '-O2' and run the program, passing it extra arguments.\n\n"+ ++ "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."+ , commandNotes = Just $ \pname ->+ "Examples:\n"+ ++ " " ++ pname ++ " v2-run\n"+ ++ " Run the executable-like in the package in the current directory\n"+ ++ " " ++ pname ++ " v2-run foo-tool\n"+ ++ " Run the named executable-like (in any package in the project)\n"+ ++ " " ++ pname ++ " v2-run pkgfoo:foo-tool\n"+ ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n"+ ++ " " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n"+ ++ " Build with '-O2' and run the program, passing it extra arguments.\n\n" - ++ cmdCommonHelpTextNewBuildBeta+ ++ cmdCommonHelpTextNewBuildBeta+ , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty, mempty)+ , 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 (haddockOptions showOrParseArgs)+ ++ liftOptions get5 set5 (testOptions showOrParseArgs)+ ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs)+ ++ liftOptions get7 set7 (clientRunOptions showOrParseArgs) }+ where+ get1 (a,_,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f,g) = (a,b,c,d,e,f,g)+ get2 (_,b,_,_,_,_,_) = b; set2 b (a,_,c,d,e,f,g) = (a,b,c,d,e,f,g)+ get3 (_,_,c,_,_,_,_) = c; set3 c (a,b,_,d,e,f,g) = (a,b,c,d,e,f,g)+ get4 (_,_,_,d,_,_,_) = d; set4 d (a,b,c,_,e,f,g) = (a,b,c,d,e,f,g)+ get5 (_,_,_,_,e,_,_) = e; set5 e (a,b,c,d,_,f,g) = (a,b,c,d,e,f,g)+ get6 (_,_,_,_,_,f,_) = f; set6 f (a,b,c,d,e,_,g) = (a,b,c,d,e,f,g)+ get7 (_,_,_,_,_,_,g) = g; set7 g (a,b,c,d,e,f,_) = (a,b,c,d,e,f,g) + -- | 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@@ -153,9 +191,13 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---runAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)+runAction :: ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags+ , ClientRunFlags ) -> [String] -> GlobalFlags -> IO ()-runAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags)+runAction ( configFlags, configExFlags, installFlags+ , haddockFlags, testFlags, benchmarkFlags+ , clientRunFlags ) targetStrings globalFlags = do globalTmp <- getTemporaryDirectory tempDir <- createTempDirectory globalTmp "cabal-repl."@@ -166,8 +208,11 @@ without config = establishDummyProjectBaseContext verbosity (config <> cliConfig) tempDir [] OtherCommand - baseCtx <- withProjectOrGlobalConfig verbosity globalConfigFlag with without+ let+ ignoreProject = fromFlagOrDefault False (crunIgnoreProject clientRunFlags) + baseCtx <- withProjectOrGlobalConfigIgn ignoreProject verbosity globalConfigFlag with without+ let scriptOrError script err = do exists <- doesFileExist script@@ -299,7 +344,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here- haddockFlags testFlags+ haddockFlags testFlags benchmarkFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) -- | Used by the main CLI parser as heuristic to decide whether @cabal@ was
+ Distribution/Client/CmdRun/ClientRunFlags.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+module Distribution.Client.CmdRun.ClientRunFlags+( ClientRunFlags(..)+, defaultClientRunFlags+, clientRunOptions+) where++import Distribution.Client.Compat.Prelude++import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs (..), option)+import Distribution.Simple.Setup (Flag (..), toFlag, trueArg)++data ClientRunFlags = ClientRunFlags+ { crunIgnoreProject :: Flag Bool+ } deriving (Eq, Show, Generic)++instance Monoid ClientRunFlags where+ mempty = gmempty+ mappend = (<>)++instance Semigroup ClientRunFlags where+ (<>) = gmappend++instance Binary ClientRunFlags+instance Structured ClientRunFlags++defaultClientRunFlags :: ClientRunFlags+defaultClientRunFlags = ClientRunFlags+ { crunIgnoreProject = toFlag False+ }++clientRunOptions :: ShowOrParseArgs -> [OptionField ClientRunFlags]+clientRunOptions _ =+ [ option "z" ["ignore-project"]+ "Ignore local project configuration"+ crunIgnoreProject (\v flags -> flags { crunIgnoreProject = v })+ trueArg+ ]
Distribution/Client/CmdSdist.hs view
@@ -9,6 +9,9 @@ , SdistFlags(..), defaultSdistFlags , OutputFormat(..)) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Distribution.Client.CmdErrorMessages ( Plural(..), renderComponentKind ) import Distribution.Client.ProjectOrchestration@@ -29,9 +32,6 @@ import Distribution.Client.ProjectConfig ( findProjectRoot, readProjectConfig ) -import Distribution.Compat.Semigroup- ((<>))- import Distribution.Package ( Package(packageId) ) import Distribution.PackageDescription.Configuration@@ -64,8 +64,6 @@ import qualified Codec.Compression.GZip as GZip import Control.Exception ( throwIO )-import Control.Monad- ( when, forM_ ) import Control.Monad.Trans ( liftIO ) import Control.Monad.State.Lazy@@ -77,7 +75,7 @@ import Data.Either ( partitionEithers ) import Data.List- ( find, sortOn, nub )+ ( sortOn ) import qualified Data.Set as Set import System.Directory ( getCurrentDirectory, setCurrentDirectory@@ -192,7 +190,7 @@ | 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+ traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distLayout) format (outputPath pkg) pkg) pkgs data IsExec = Exec | NoExec deriving (Show, Eq)@@ -256,7 +254,7 @@ Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err) Right path -> tell [Tar.directoryEntry path] - forM_ files $ \(perm, file) -> do+ for_ files $ \(perm, file) -> do let fileDir = takeDirectory (prefix </> file) perm' = case perm of Exec -> Tar.executableFilePermissions@@ -276,9 +274,9 @@ entries <- execWriterT (evalStateT entriesM mempty) let -- Pretend our GZip file is made on Unix.- normalize bs = BSL.concat [first, "\x03", rest']+ normalize bs = BSL.concat [pfx, "\x03", rest'] where- (first, rest) = BSL.splitAt 9 bs+ (pfx, rest) = BSL.splitAt 9 bs rest' = BSL.tail rest -- The Unix epoch, which is the default value, is -- unsuitable because it causes unpacking problems on
Distribution/Client/CmdTest.hs view
@@ -20,7 +20,7 @@ ( GlobalFlags(..), ConfigFlags(..), ConfigExFlags, InstallFlags ) import qualified Distribution.Client.Setup as Client import Distribution.Simple.Setup- ( HaddockFlags, TestFlags(..), fromFlagOrDefault )+ ( HaddockFlags, TestFlags(..), BenchmarkFlags(..), fromFlagOrDefault ) import Distribution.Simple.Command ( CommandUI(..), usageAlternatives ) import Distribution.Simple.Flag@@ -36,7 +36,9 @@ import qualified System.Exit (exitSuccess) -testCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)+testCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags+ ) testCommand = Client.installCommand { commandName = "v2-test" , commandSynopsis = "Run test-suites"@@ -84,9 +86,11 @@ -- For more details on how this works, see the module -- "Distribution.Client.ProjectOrchestration" ---testAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)+testAction :: ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO ()-testAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags)+testAction ( configFlags, configExFlags, installFlags+ , haddockFlags, testFlags, benchmarkFlags ) targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand@@ -131,7 +135,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here- haddockFlags testFlags+ haddockFlags testFlags benchmarkFlags -- | This defines what a 'TargetSelector' means for the @test@ command. -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
Distribution/Client/CmdUpdate.hs view
@@ -36,7 +36,7 @@ , UpdateFlags, defaultUpdateFlags , RepoContext(..) ) import Distribution.Simple.Setup- ( HaddockFlags, TestFlags, fromFlagOrDefault )+ ( HaddockFlags, TestFlags, BenchmarkFlags, fromFlagOrDefault ) import Distribution.Simple.Utils ( die', notice, wrapText, writeFileAtomic, noticeNoWrap ) import Distribution.Verbosity@@ -64,7 +64,9 @@ import qualified Hackage.Security.Client as Sec updateCommand :: CommandUI ( ConfigFlags, ConfigExFlags- , InstallFlags, HaddockFlags, TestFlags )+ , InstallFlags, HaddockFlags+ , TestFlags, BenchmarkFlags+ ) updateCommand = Client.installCommand { commandName = "v2-update", commandSynopsis = "Updates list of known packages.",@@ -114,9 +116,11 @@ name <- ReadP.manyTill (ReadP.satisfy (\c -> c /= ',')) ReadP.eof return (UpdateRequest name IndexStateHead) -updateAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)+updateAction :: ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> GlobalFlags -> IO ()-updateAction (configFlags, configExFlags, installFlags, haddockFlags, testFlags)+updateAction ( configFlags, configExFlags, installFlags+ , haddockFlags, testFlags, benchmarkFlags ) extraArgs globalFlags = do projectConfig <- withProjectOrGlobalConfig verbosity globalConfigFlag (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand)@@ -174,7 +178,7 @@ globalFlags configFlags configExFlags installFlags mempty -- ClientInstallFlags, not needed here- haddockFlags testFlags+ haddockFlags testFlags benchmarkFlags globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig) updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, IndexState)@@ -182,7 +186,8 @@ updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do transport <- repoContextGetTransport repoCtxt case repo of- RepoLocal{..} -> return ()+ RepoLocal{} -> return ()+ RepoLocalNoIndex{} -> return () RepoRemote{..} -> do downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir
− Distribution/Client/Compat/FileLock.hsc
@@ -1,201 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE InterruptibleFFI #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE DeriveDataTypeable #-}---- | This compat module can be removed once base-4.10 (ghc-8.2) is the minimum--- required version. Though note that the locking functionality is not in--- public modules in base-4.10, just in the "GHC.IO.Handle.Lock" module.-module Distribution.Client.Compat.FileLock (- FileLockingNotSupported(..)- , LockMode(..)- , hLock- , hTryLock- ) where--#if MIN_VERSION_base(4,10,0)--import GHC.IO.Handle.Lock--#else---- The remainder of this file is a modified copy--- of GHC.IO.Handle.Lock from ghc-8.2.x------ The modifications were just to the imports and the CPP, since we do not have--- access to the HAVE_FLOCK from the ./configure script. We approximate the--- lack of HAVE_FLOCK with defined(solaris2_HOST_OS) instead since that is the--- only known major Unix platform lacking flock().--import Control.Exception (Exception)-import Data.Typeable--#if defined(solaris2_HOST_OS)--import Control.Exception (throwIO)-import System.IO (Handle)--#else--import Data.Bits-import Data.Function-import Control.Concurrent.MVar--import Foreign.C.Error-import Foreign.C.Types--import GHC.IO.Handle.Types-import GHC.IO.FD-import GHC.IO.Exception--#if defined(mingw32_HOST_OS)--#if defined(i386_HOST_ARCH)-## define WINDOWS_CCONV stdcall-#elif defined(x86_64_HOST_ARCH)-## define WINDOWS_CCONV ccall-#else-# error Unknown mingw32 arch-#endif--#include <windows.h>--import Foreign.Marshal.Alloc-import Foreign.Marshal.Utils-import Foreign.Ptr-import GHC.Windows--#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */--#include <sys/file.h>--#endif /* !defined(mingw32_HOST_OS) */--#endif /* !defined(solaris2_HOST_OS) */----- | Exception thrown by 'hLock' on non-Windows platforms that don't support--- 'flock'.-data FileLockingNotSupported = FileLockingNotSupported- deriving (Typeable, Show)--instance Exception FileLockingNotSupported----- | Indicates a mode in which a file should be locked.-data LockMode = SharedLock | ExclusiveLock---- | If a 'Handle' references a file descriptor, attempt to lock contents of the--- underlying file in appropriate mode. If the file is already locked in--- incompatible mode, this function blocks until the lock is established. The--- lock is automatically released upon closing a 'Handle'.------ Things to be aware of:------ 1) This function may block inside a C call. If it does, in order to be able--- to interrupt it with asynchronous exceptions and/or for other threads to--- continue working, you MUST use threaded version of the runtime system.------ 2) The implementation uses 'LockFileEx' on Windows and 'flock' otherwise,--- hence all of their caveats also apply here.------ 3) On non-Windows plaftorms that don't support 'flock' (e.g. Solaris) this--- function throws 'FileLockingNotImplemented'. We deliberately choose to not--- provide fcntl based locking instead because of its broken semantics.------ @since 4.10.0.0-hLock :: Handle -> LockMode -> IO ()-hLock h mode = lockImpl h "hLock" mode True >> return ()---- | Non-blocking version of 'hLock'.------ @since 4.10.0.0-hTryLock :: Handle -> LockMode -> IO Bool-hTryLock h mode = lockImpl h "hTryLock" mode False--------------------------------------------#if defined(solaris2_HOST_OS)---- | No-op implementation.-lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool-lockImpl _ _ _ _ = throwIO FileLockingNotSupported--#else /* !defined(solaris2_HOST_OS) */--#if defined(mingw32_HOST_OS)--lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool-lockImpl h ctx mode block = do- FD{fdFD = fd} <- handleToFd h- wh <- throwErrnoIf (== iNVALID_HANDLE_VALUE) ctx $ c_get_osfhandle fd- allocaBytes sizeof_OVERLAPPED $ \ovrlpd -> do- fillBytes ovrlpd (fromIntegral sizeof_OVERLAPPED) 0- let flags = cmode .|. (if block then 0 else #{const LOCKFILE_FAIL_IMMEDIATELY})- -- We want to lock the whole file without looking up its size to be- -- consistent with what flock does. According to documentation of LockFileEx- -- "locking a region that goes beyond the current end-of-file position is- -- not an error", however e.g. Windows 10 doesn't accept maximum possible- -- value (a pair of MAXDWORDs) for mysterious reasons. Work around that by- -- trying 2^32-1.- fix $ \retry -> c_LockFileEx wh flags 0 0xffffffff 0x0 ovrlpd >>= \case- True -> return True- False -> getLastError >>= \err -> if- | not block && err == #{const ERROR_LOCK_VIOLATION} -> return False- | err == #{const ERROR_OPERATION_ABORTED} -> retry- | otherwise -> failWith ctx err- where- sizeof_OVERLAPPED = #{size OVERLAPPED}-- cmode = case mode of- SharedLock -> 0- ExclusiveLock -> #{const LOCKFILE_EXCLUSIVE_LOCK}---- https://msdn.microsoft.com/en-us/library/aa297958.aspx-foreign import ccall unsafe "_get_osfhandle"- c_get_osfhandle :: CInt -> IO HANDLE---- https://msdn.microsoft.com/en-us/library/windows/desktop/aa365203.aspx-foreign import WINDOWS_CCONV interruptible "LockFileEx"- c_LockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> Ptr () -> IO BOOL--#else /* !defined(mingw32_HOST_OS), so assume unix with flock() */--lockImpl :: Handle -> String -> LockMode -> Bool -> IO Bool-lockImpl h ctx mode block = do- FD{fdFD = fd} <- handleToFd h- let flags = cmode .|. (if block then 0 else #{const LOCK_NB})- fix $ \retry -> c_flock fd flags >>= \case- 0 -> return True- _ -> getErrno >>= \errno -> if- | not block && errno == eWOULDBLOCK -> return False- | errno == eINTR -> retry- | otherwise -> ioException $ errnoToIOError ctx errno (Just h) Nothing- where- cmode = case mode of- SharedLock -> #{const LOCK_SH}- ExclusiveLock -> #{const LOCK_EX}--foreign import ccall interruptible "flock"- c_flock :: CInt -> CInt -> IO CInt--#endif /* !defined(mingw32_HOST_OS) */---- | Turn an existing Handle into a file descriptor. This function throws an--- IOError if the Handle does not reference a file descriptor.-handleToFd :: Handle -> IO FD-handleToFd h = case h of- FileHandle _ mv -> do- Handle__{haDevice = dev} <- readMVar mv- case cast dev of- Just fd -> return fd- Nothing -> throwErr "not a file descriptor"- DuplexHandle{} -> throwErr "not a file handle"- where- throwErr msg = ioException $ IOError (Just h)- InappropriateType "handleToFd" msg Nothing Nothing--#endif /* defined(solaris2_HOST_OS) */--#endif /* MIN_VERSION_base */
+ Distribution/Client/Compat/Orphans.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Distribution.Client.Compat.Orphans () where++import Control.Exception (SomeException)+import Distribution.Compat.Binary (Binary (..))+import Distribution.Compat.Typeable (typeRep)+import Distribution.Utils.Structured (Structure (Nominal), Structured (..))+import Network.URI (URI (..), URIAuth (..))++-------------------------------------------------------------------------------+-- network-uri+-------------------------------------------------------------------------------++-- note, network-uri-2.6.0.3+ provide a Generic instance but earlier+-- versions do not, so we use manual Binary instances here+instance Binary URI where+ put (URI a b c d e) = do put a; put b; put c; put d; put e+ get = do !a <- get; !b <- get; !c <- get; !d <- get; !e <- get+ return (URI a b c d e)++instance Structured URI where+ structure p = Nominal (typeRep p) 0 "URI" []++instance Binary URIAuth where+ put (URIAuth a b c) = do put a; put b; put c+ get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c)++-------------------------------------------------------------------------------+-- base+-------------------------------------------------------------------------------++--FIXME: Duncan Coutts: this is a total cheat+--Added in 46aa019ec85e313e257d122a3549cce01996c566+instance Binary SomeException where+ put _ = return ()+ get = fail "cannot serialise exceptions"++instance Structured SomeException where+ structure p = Nominal (typeRep p) 0 "SomeException" []
Distribution/Client/Compat/Prelude.hs view
@@ -17,3 +17,4 @@ import Prelude (IO) import Distribution.Compat.Prelude.Internal hiding (IO)+import Distribution.Client.Compat.Orphans ()
Distribution/Client/Compat/Semaphore.hs view
@@ -12,6 +12,8 @@ import Control.Exception (mask_, onException) import Control.Monad (join, unless) import Data.Typeable (Typeable)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE -- | 'QSem' is a quantity semaphore in which the resource is aqcuired -- and released in units of one. It provides guaranteed FIFO ordering@@ -97,8 +99,8 @@ checkwake2 [] = do writeTVar q 1 return (return ())- checkwake2 ys = do- let (z:zs) = reverse ys+ checkwake2 (y:ys) = do+ let (z:|zs) = NE.reverse (y:|ys) writeTVar b1 zs writeTVar b2 [] return (wake s z)
Distribution/Client/Config.hs view
@@ -41,7 +41,8 @@ userConfigUpdate, createDefaultConfigFile, - remoteRepoFields+ remoteRepoFields,+ postProcessRepo, ) where import Language.Haskell.Extension ( Language(Haskell2010) )@@ -50,7 +51,7 @@ ( viewAsFieldDescr ) import Distribution.Client.Types- ( RemoteRepo(..), Username(..), Password(..), emptyRemoteRepo+ ( RemoteRepo(..), LocalRepo (..), Username(..), Password(..), emptyRemoteRepo , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps ) import Distribution.Client.BuildReports.Types@@ -64,7 +65,7 @@ , InstallFlags(..), installOptions, defaultInstallFlags , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand- , showRepo, parseRepo, readRepo )+ , showRemoteRepo, parseRemoteRepo, readRemoteRepo ) import Distribution.Client.CmdInstall.ClientInstallFlags ( ClientInstallFlags(..), defaultClientInstallFlags , clientInstallOptions )@@ -79,6 +80,7 @@ ( ConfigFlags(..), configureOptions, defaultConfigFlags , HaddockFlags(..), haddockOptions, defaultHaddockFlags , TestFlags(..), defaultTestFlags+ , BenchmarkFlags(..), defaultBenchmarkFlags , installDirsOptions, optionDistPref , programDbPaths', programDbOptions , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault )@@ -91,7 +93,7 @@ , locatedErrorMsg, showPWarning , readFields, warning, lineNo , simpleField, listField, spaceListField- , parseFilePathQ, parseOptCommaList, parseTokenQ )+ , parseFilePathQ, parseOptCommaList, parseTokenQ, syntaxError) import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection ) import Distribution.Client.HttpUtils@@ -169,7 +171,8 @@ savedUploadFlags :: UploadFlags, savedReportFlags :: ReportFlags, savedHaddockFlags :: HaddockFlags,- savedTestFlags :: TestFlags+ savedTestFlags :: TestFlags,+ savedBenchmarkFlags :: BenchmarkFlags } deriving Generic instance Monoid SavedConfig where@@ -189,7 +192,8 @@ savedUploadFlags = combinedSavedUploadFlags, savedReportFlags = combinedSavedReportFlags, savedHaddockFlags = combinedSavedHaddockFlags,- savedTestFlags = combinedSavedTestFlags+ savedTestFlags = combinedSavedTestFlags,+ savedBenchmarkFlags = combinedSavedBenchmarkFlags } where -- This is ugly, but necessary. If we're mappending two config files, we@@ -225,7 +229,8 @@ in case b' of [] -> a' _ -> b' - lastNonMempty' :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a+ lastNonMempty'+ :: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a lastNonMempty' field subfield = let a' = subfield . field $ a b' = subfield . field $ b@@ -248,6 +253,7 @@ globalRemoteRepos = lastNonEmptyNL globalRemoteRepos, globalCacheDir = combine globalCacheDir, globalLocalRepos = lastNonEmptyNL globalLocalRepos,+ globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos, globalLogsDir = combine globalLogsDir, globalWorldFile = combine globalWorldFile, globalRequireSandbox = combine globalRequireSandbox,@@ -306,6 +312,7 @@ installMaxBackjumps = combine installMaxBackjumps, installReorderGoals = combine installReorderGoals, installCountConflicts = combine installCountConflicts,+ installFineGrainedConflicts = combine installFineGrainedConflicts, installMinimizeConflictSet = combine installMinimizeConflictSet, installIndependentGoals = combine installIndependentGoals, installShadowPkgs = combine installShadowPkgs,@@ -337,12 +344,13 @@ combine = combine' savedInstallFlags lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags - combinedSavedClientInstallFlags = ClientInstallFlags {- cinstInstallLibs = combine cinstInstallLibs,- cinstEnvironmentPath = combine cinstEnvironmentPath,- cinstOverwritePolicy = combine cinstOverwritePolicy,- cinstInstallMethod = combine cinstInstallMethod,- cinstInstalldir = combine cinstInstalldir+ combinedSavedClientInstallFlags = ClientInstallFlags+ { cinstInstallLibs = combine cinstInstallLibs+ , cinstIgnoreProject = combine cinstIgnoreProject+ , cinstEnvironmentPath = combine cinstEnvironmentPath+ , cinstOverwritePolicy = combine cinstOverwritePolicy+ , cinstInstallMethod = combine cinstInstallMethod+ , cinstInstalldir = combine cinstInstalldir } where combine = combine' savedClientInstallFlags@@ -414,7 +422,8 @@ configFlagError = combine configFlagError, configRelocatable = combine configRelocatable, configUseResponseFiles = combine configUseResponseFiles,- configAllowDependingOnPrivateLibs = combine configAllowDependingOnPrivateLibs+ configAllowDependingOnPrivateLibs =+ combine configAllowDependingOnPrivateLibs } where combine = combine' savedConfigureFlags@@ -429,8 +438,10 @@ -- TODO: NubListify configPreferences = lastNonEmpty configPreferences, configSolver = combine configSolver,- configAllowNewer = combineMonoid savedConfigureExFlags configAllowNewer,- configAllowOlder = combineMonoid savedConfigureExFlags configAllowOlder,+ configAllowNewer =+ combineMonoid savedConfigureExFlags configAllowNewer,+ configAllowOlder =+ combineMonoid savedConfigureExFlags configAllowOlder, configWriteGhcEnvironmentFilesPolicy = combine configWriteGhcEnvironmentFilesPolicy }@@ -509,7 +520,16 @@ combine = combine' savedTestFlags lastNonEmpty = lastNonEmpty' savedTestFlags + combinedSavedBenchmarkFlags = BenchmarkFlags {+ benchmarkDistPref = combine benchmarkDistPref,+ benchmarkVerbosity = combine benchmarkVerbosity,+ benchmarkOptions = lastNonEmpty benchmarkOptions+ }+ where+ combine = combine' savedBenchmarkFlags+ lastNonEmpty = lastNonEmpty' savedBenchmarkFlags + -- -- * Default config --@@ -724,7 +744,8 @@ minp <- readConfigFile mempty configFile case minp of Nothing -> do- notice verbosity $ "Config file path source is " ++ sourceMsg source ++ "."+ notice verbosity $+ "Config file path source is " ++ sourceMsg source ++ "." notice verbosity $ "Config file " ++ configFile ++ " not found." createDefaultConfigFile verbosity [] configFile Just (ParseOk ws conf) -> do@@ -764,7 +785,8 @@ getSource ((source,action): xs) = action >>= maybe (getSource xs) (return . (,) source) -readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))+readConfigFile+ :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) readConfigFile initial file = handleNotExists $ fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial) (readFile file)@@ -788,7 +810,8 @@ writeConfigFile file comments vals = do let tmpFile = file <.> "tmp" createDirectoryIfMissing True (takeDirectory file)- writeFile tmpFile $ explanation ++ showConfigWithComments comments vals ++ "\n"+ writeFile tmpFile $+ explanation ++ showConfigWithComments comments vals ++ "\n" renameFile tmpFile file where explanation = unlines@@ -843,7 +866,8 @@ savedUploadFlags = commandDefaultFlags uploadCommand, savedReportFlags = commandDefaultFlags reportCommand, savedHaddockFlags = defaultHaddockFlags,- savedTestFlags = defaultTestFlags+ savedTestFlags = defaultTestFlags,+ savedBenchmarkFlags = defaultBenchmarkFlags } conf1 <- extendToEffectiveConfig conf0 let globalFlagsConf1 = savedGlobalFlags conf1@@ -901,7 +925,8 @@ | str == "1" -> ParseOk [] (Flag NormalOptimisation) | str == "2" -> ParseOk [] (Flag MaximumOptimisation) | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)- | lstr == "true" -> ParseOk [caseWarning] (Flag NormalOptimisation)+ | lstr == "true" -> ParseOk [caseWarning]+ (Flag NormalOptimisation) | otherwise -> ParseFailed (NoParse name line) where lstr = lowercase str@@ -937,16 +962,20 @@ ++ toSavedConfig liftConfigExFlag (configureExOptions ParseArgs src) []- [let pkgs = (Just . AllowOlder . RelaxDepsSome) `fmap` parseOptCommaList Text.parse- parseAllowOlder = ((Just . AllowOlder . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in- simpleField "allow-older"- (showRelaxDeps . fmap unAllowOlder) parseAllowOlder- configAllowOlder (\v flags -> flags { configAllowOlder = v })- ,let pkgs = (Just . AllowNewer . RelaxDepsSome) `fmap` parseOptCommaList Text.parse- parseAllowNewer = ((Just . AllowNewer . toRelaxDeps) `fmap` Text.parse) Parse.<++ pkgs in- simpleField "allow-newer"- (showRelaxDeps . fmap unAllowNewer) parseAllowNewer- configAllowNewer (\v flags -> flags { configAllowNewer = v })+ [let pkgs = (Just . AllowOlder . RelaxDepsSome)+ `fmap` parseOptCommaList Text.parse+ parseAllowOlder = ((Just . AllowOlder . toRelaxDeps)+ `fmap` Text.parse) Parse.<++ pkgs+ in simpleField "allow-older"+ (showRelaxDeps . fmap unAllowOlder) parseAllowOlder+ configAllowOlder (\v flags -> flags { configAllowOlder = v })+ ,let pkgs = (Just . AllowNewer . RelaxDepsSome)+ `fmap` parseOptCommaList Text.parse+ parseAllowNewer = ((Just . AllowNewer . toRelaxDeps)+ `fmap` Text.parse) Parse.<++ pkgs+ in simpleField "allow-newer"+ (showRelaxDeps . fmap unAllowNewer) parseAllowNewer+ configAllowNewer (\v flags -> flags { configAllowNewer = v }) ] ++ toSavedConfig liftInstallFlag@@ -1008,7 +1037,7 @@ deprecatedFieldDescriptions = [ liftGlobalFlag $ listField "repos"- (Disp.text . showRepo) parseRepo+ (Disp.text . showRemoteRepo) parseRemoteRepo (fromNubList . globalRemoteRepos) (\rs cfg -> cfg { globalRemoteRepos = toNubList rs }) , liftGlobalFlag $@@ -1031,8 +1060,10 @@ (fromFlagOrDefault [] . uploadPasswordCmd) (\d cfg -> cfg { uploadPasswordCmd = Flag d }) ]- ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) installDirsFields- ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) installDirsFields+ ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs)+ installDirsFields+ ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs)+ installDirsFields where optional = Parse.option mempty . fmap toFlag modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a@@ -1045,8 +1076,9 @@ liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) -> FieldDescr SavedConfig-liftGlobalInstallDirs = liftField- savedGlobalInstallDirs (\flags conf -> conf { savedGlobalInstallDirs = flags })+liftGlobalInstallDirs =+ liftField savedGlobalInstallDirs+ (\flags conf -> conf { savedGlobalInstallDirs = flags }) liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig liftGlobalFlag = liftField@@ -1065,8 +1097,9 @@ savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags }) liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig-liftClientInstallFlag = liftField- savedClientInstallFlags (\flags conf -> conf { savedClientInstallFlags = flags })+liftClientInstallFlag =+ liftField savedClientInstallFlags+ (\flags conf -> conf { savedClientInstallFlags = flags }) liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig liftUploadFlag = liftField@@ -1087,9 +1120,9 @@ let init0 = savedInitFlags config user0 = savedUserInstallDirs config global0 = savedGlobalInstallDirs config- (remoteRepoSections0, haddockFlags, initFlags, user, global, paths, args) <-+ (remoteRepoSections0, localRepoSections0, haddockFlags, initFlags, user, global, paths, args) <- foldM parseSections- ([], savedHaddockFlags config, init0, user0, global0, [], [])+ ([], [], savedHaddockFlags config, init0, user0, global0, [], []) knownSections let remoteRepoSections =@@ -1097,9 +1130,15 @@ . nubBy ((==) `on` remoteRepoName) $ remoteRepoSections0 + let localRepoSections =+ reverse+ . nubBy ((==) `on` localRepoName)+ $ localRepoSections0+ return . fixConfigMultilines $ config { savedGlobalFlags = (savedGlobalFlags config) { globalRemoteRepos = toNubList remoteRepoSections,+ globalLocalNoIndexRepos = toNubList localRepoSections, -- the global extra prog path comes from the configure flag prog path globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config) },@@ -1123,86 +1162,89 @@ isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True isKnownSection _ = False - -- attempt to split fields that can represent lists of paths into actual lists- -- on failure, leave the field untouched+ -- Attempt to split fields that can represent lists of paths into+ -- actual lists on failure, leave the field untouched. splitMultiPath :: [String] -> [String] splitMultiPath [s] = case runP 0 "" (parseOptCommaList parseTokenQ) s of ParseOk _ res -> res _ -> [s] splitMultiPath xs = xs - -- This is a fixup, pending a full config parser rewrite, to ensure that- -- config fields which can be comma seperated lists actually parse as comma seperated lists+ -- This is a fixup, pending a full config parser rewrite, to+ -- ensure that config fields which can be comma-separated lists+ -- actually parse as comma-separated lists. fixConfigMultilines conf = conf { savedConfigureFlags = let scf = savedConfigureFlags conf in scf {- configProgramPathExtra = toNubList $ splitMultiPath (fromNubList $ configProgramPathExtra scf)- , configExtraLibDirs = splitMultiPath (configExtraLibDirs scf)- , configExtraFrameworkDirs = splitMultiPath (configExtraFrameworkDirs scf)- , configExtraIncludeDirs = splitMultiPath (configExtraIncludeDirs scf)- , configConfigureArgs = splitMultiPath (configConfigureArgs scf)+ configProgramPathExtra =+ toNubList $ splitMultiPath+ (fromNubList $ configProgramPathExtra scf)+ , configExtraLibDirs = splitMultiPath+ (configExtraLibDirs scf)+ , configExtraFrameworkDirs = splitMultiPath+ (configExtraFrameworkDirs scf)+ , configExtraIncludeDirs = splitMultiPath+ (configExtraIncludeDirs scf)+ , configConfigureArgs = splitMultiPath+ (configConfigureArgs scf) } } parse = parseFields (configFieldDescriptions src ++ deprecatedFieldDescriptions) initial - parseSections (rs, h, i, u, g, p, a)- (ParseUtils.Section _ "repository" name fs) = do+ parseSections (rs, ls, h, i, u, g, p, a)+ (ParseUtils.Section lineno "repository" name fs) = do r' <- parseFields remoteRepoFields (emptyRemoteRepo name) fs- when (remoteRepoKeyThreshold r' > length (remoteRepoRootKeys r')) $- warning $ "'key-threshold' for repository " ++ show (remoteRepoName r')- ++ " higher than number of keys"- when (not (null (remoteRepoRootKeys r'))- && remoteRepoSecure r' /= Just True) $- warning $ "'root-keys' for repository " ++ show (remoteRepoName r')- ++ " non-empty, but 'secure' not set to True."- return (r':rs, h, i, u, g, p, a)+ r'' <- postProcessRepo lineno name r'+ case r'' of+ Left local -> return (rs, local:ls, h, i, u, g, p, a)+ Right remote -> return (remote:rs, ls, h, i, u, g, p, a) - parseSections (rs, h, i, u, g, p, a)+ parseSections (rs, ls, h, i, u, g, p, a) (ParseUtils.F lno "remote-repo" raw) = do- let mr' = readRepo raw+ let mr' = readRemoteRepo raw r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr'- return (r':rs, h, i, u, g, p, a)+ return (r':rs, ls, h, i, u, g, p, a) - parseSections accum@(rs, h, i, u, g, p, a)+ parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "haddock" name fs) | name == "" = do h' <- parseFields haddockFlagsFields h fs- return (rs, h', i, u, g, p, a)+ return (rs, ls, h', i, u, g, p, a) | otherwise = do warning "The 'haddock' section should be unnamed" return accum - parseSections accum@(rs, h, i, u, g, p, a)+ parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "init" name fs) | name == "" = do i' <- parseFields initFlagsFields i fs- return (rs, h, i', u, g, p, a)+ return (rs, ls, h, i', u, g, p, a) | otherwise = do warning "The 'init' section should be unnamed" return accum - parseSections accum@(rs, h, i, u, g, p, a)+ parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "install-dirs" name fs) | name' == "user" = do u' <- parseFields installDirsFields u fs- return (rs, h, i, u', g, p, a)+ return (rs, ls, h, i, u', g, p, a) | name' == "global" = do g' <- parseFields installDirsFields g fs- return (rs, h, i, u, g', p, a)+ return (rs, ls, h, i, u, g', p, a) | otherwise = do warning "The 'install-paths' section should be for 'user' or 'global'" return accum where name' = lowercase name- parseSections accum@(rs, h, i, u, g, p, a)+ parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "program-locations" name fs) | name == "" = do p' <- parseFields withProgramsFields p fs- return (rs, h, i, u, g, p', a)+ return (rs, ls, h, i, u, g, p', a) | otherwise = do warning "The 'program-locations' section should be unnamed" return accum- parseSections accum@(rs, h, i, u, g, p, a)+ parseSections accum@(rs, ls, h, i, u, g, p, a) (ParseUtils.Section _ "program-default-options" name fs) | name == "" = do a' <- parseFields withProgramOptionsFields a fs- return (rs, h, i, u, g, p, a')+ return (rs, ls, h, i, u, g, p, a') | otherwise = do warning "The 'program-default-options' section should be unnamed" return accum@@ -1210,6 +1252,34 @@ warning $ "Unrecognized stanza on line " ++ show (lineNo f) return accum +postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo)+postProcessRepo lineno reponame repo0 = do+ when (null reponame) $+ syntaxError lineno $ "a 'repository' section requires the "+ ++ "repository name as an argument"++ case uriScheme (remoteRepoURI repo0) of+ -- TODO: check that there are no authority, query or fragment+ -- Note: the trailing colon is important+ "file+noindex:" -> do+ let uri = remoteRepoURI repo0+ return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache")++ _ -> do+ let repo = repo0 { remoteRepoName = reponame }++ when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $+ warning $ "'key-threshold' for repository "+ ++ show (remoteRepoName repo)+ ++ " higher than number of keys"++ when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $+ warning $ "'root-keys' for repository "+ ++ show (remoteRepoName repo)+ ++ " non-empty, but 'secure' not set to True."++ return $ Right repo+ showConfig :: SavedConfig -> String showConfig = showConfigWithComments mempty @@ -1220,8 +1290,9 @@ [] -> Disp.text "" (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs $+$ Disp.text ""- $+$ ppFields (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown))- mcomment vals+ $+$ ppFields+ (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown))+ mcomment vals $+$ Disp.text "" $+$ ppSection "haddock" "" haddockFlagsFields (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals)@@ -1259,23 +1330,23 @@ ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc ppRemoteRepoSection def vals = ppSection "repository" (remoteRepoName vals)- remoteRepoFields (Just def) vals+ remoteRepoFields (Just def) vals remoteRepoFields :: [FieldDescr RemoteRepo] remoteRepoFields =- [ simpleField "url"- (text . show) (parseTokenQ >>= parseURI')- remoteRepoURI (\x repo -> repo { remoteRepoURI = x })- , simpleField "secure"- showSecure (Just `fmap` Text.parse)- remoteRepoSecure (\x repo -> repo { remoteRepoSecure = x })- , listField "root-keys"- text parseTokenQ- remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x })- , simpleField "key-threshold"- showThreshold Text.parse- remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x })- ]+ [ simpleField "url"+ (text . show) (parseTokenQ >>= parseURI')+ remoteRepoURI (\x repo -> repo { remoteRepoURI = x })+ , simpleField "secure"+ showSecure (Just `fmap` Text.parse)+ remoteRepoSecure (\x repo -> repo { remoteRepoSecure = x })+ , listField "root-keys"+ text parseTokenQ+ remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x })+ , simpleField "key-threshold"+ showThreshold Text.parse+ remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x })+ ] where parseURI' uriString = case parseURI uriString of@@ -1312,12 +1383,13 @@ , name `notElem` exclusions ] where exclusions =- ["author", "email", "quiet", "no-comments", "minimal", "overwrite",- "package-dir", "packagedir", "package-name", "version", "homepage",- "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe",- "simple", "main-is", "expose-module", "exposed-modules", "extension",- "dependency", "build-tool", "with-compiler",- "verbose"]+ [ "author", "email", "quiet", "no-comments", "minimal", "overwrite"+ , "package-dir", "packagedir", "package-name", "version", "homepage"+ , "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe"+ , "simple", "main-is", "expose-module", "exposed-modules", "extension"+ , "dependency", "build-tool", "with-compiler"+ , "verbose"+ ] -- | Fields for the 'program-locations' section. withProgramsFields :: [FieldDescr [(String, FilePath)]]@@ -1334,16 +1406,17 @@ parseExtraLines :: Verbosity -> [String] -> IO SavedConfig parseExtraLines verbosity extraLines =- case parseConfig (ConstraintSourceMainConfig "additional lines")- mempty (unlines extraLines) of- ParseFailed err ->- let (line, msg) = locatedErrorMsg err- in die' verbosity $- "Error parsing additional config lines\n"- ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg- ParseOk [] r -> return r- ParseOk ws _ -> die' verbosity $- unlines (map (showPWarning "Error parsing additional config lines") ws)+ case parseConfig (ConstraintSourceMainConfig "additional lines")+ mempty (unlines extraLines) of+ ParseFailed err ->+ let (line, msg) = locatedErrorMsg err+ in die' verbosity $+ "Error parsing additional config lines\n"+ ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg+ ParseOk [] r -> return r+ ParseOk ws _ ->+ die' verbosity $+ unlines (map (showPWarning "Error parsing additional config lines") ws) -- | Get the differences (as a pseudo code diff) between the user's -- '~/.cabal/config' and the one that cabal would generate if it didn't exist.@@ -1352,10 +1425,11 @@ userConfig <- loadRawConfig normal (globalConfigFile globalFlags) extraConfig <- parseExtraLines verbosity extraLines testConfig <- initialSavedConfig- return $ reverse . foldl' createDiff [] . M.toList- $ M.unionWith combine- (M.fromList . map justFst $ filterShow testConfig)- (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig))+ return $+ reverse . foldl' createDiff [] . M.toList+ $ M.unionWith combine+ (M.fromList . map justFst $ filterShow testConfig)+ (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig)) where justFst (a, b) = (a, (Just b, Nothing)) justSnd (a, b) = (a, (Nothing, Just b))@@ -1404,4 +1478,5 @@ notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "." renameFile cabalFile backup notice verbosity $ "Writing merged config to " ++ cabalFile ++ "."- writeConfigFile cabalFile commentConf (newConfig `mappend` userConfig `mappend` extraConfig)+ writeConfigFile cabalFile commentConf+ (newConfig `mappend` userConfig `mappend` extraConfig)
Distribution/Client/Configure.hs view
@@ -24,6 +24,7 @@ import Prelude () import Distribution.Client.Compat.Prelude+import Distribution.Utils.Generic (safeHead) import Distribution.Client.Dependency import qualified Distribution.Client.InstallPlan as InstallPlan@@ -85,6 +86,8 @@ import Distribution.Verbosity as Verbosity ( Verbosity ) +import Data.Foldable+ ( forM_ ) import System.FilePath ( (</>) ) -- | Choose the Cabal version such that the setup scripts compiled against this@@ -272,12 +275,12 @@ -> ConfigExFlags -> IO () checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do- unless (null unknownConstraints) $ warn verbosity $- "Constraint refers to an unknown package: "- ++ showConstraint (head unknownConstraints)- unless (null unknownPreferences) $ warn verbosity $- "Preference refers to an unknown package: "- ++ display (head unknownPreferences)+ forM_ (safeHead unknownConstraints) $ \h ->+ warn verbosity $ "Constraint refers to an unknown package: "+ ++ showConstraint h+ forM_ (safeHead unknownPreferences) $ \h ->+ warn verbosity $ "Preference refers to an unknown package: "+ ++ display h where unknownConstraints = filter (unknown . userConstraintPackageName . fst) $ configExConstraints flags
Distribution/Client/Dependency.hs view
@@ -47,6 +47,7 @@ setPreferenceDefault, setReorderGoals, setCountConflicts,+ setFineGrainedConflicts, setMinimizeConflictSet, setIndependentGoals, setAvoidReinstalls,@@ -159,6 +160,7 @@ depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage, depResolverReorderGoals :: ReorderGoals, depResolverCountConflicts :: CountConflicts,+ depResolverFineGrainedConflicts :: FineGrainedConflicts, depResolverMinimizeConflictSet :: MinimizeConflictSet, depResolverIndependentGoals :: IndependentGoals, depResolverAvoidReinstalls :: AvoidReinstalls,@@ -197,6 +199,7 @@ ++ "\nstrategy: " ++ show (depResolverPreferenceDefault p) ++ "\nreorder goals: " ++ show (asBool (depResolverReorderGoals p)) ++ "\ncount conflicts: " ++ show (asBool (depResolverCountConflicts p))+ ++ "\nfine grained conflicts: " ++ show (asBool (depResolverFineGrainedConflicts p)) ++ "\nminimize conflict set: " ++ show (asBool (depResolverMinimizeConflictSet p)) ++ "\nindependent goals: " ++ show (asBool (depResolverIndependentGoals p)) ++ "\navoid reinstalls: " ++ show (asBool (depResolverAvoidReinstalls p))@@ -254,6 +257,7 @@ depResolverSourcePkgIndex = sourcePkgIndex, depResolverReorderGoals = ReorderGoals False, depResolverCountConflicts = CountConflicts True,+ depResolverFineGrainedConflicts = FineGrainedConflicts True, depResolverMinimizeConflictSet = MinimizeConflictSet False, depResolverIndependentGoals = IndependentGoals False, depResolverAvoidReinstalls = AvoidReinstalls False,@@ -310,6 +314,12 @@ depResolverCountConflicts = count } +setFineGrainedConflicts :: FineGrainedConflicts -> DepResolverParams -> DepResolverParams+setFineGrainedConflicts fineGrained params =+ params {+ depResolverFineGrainedConflicts = fineGrained+ }+ setMinimizeConflictSet :: MinimizeConflictSet -> DepResolverParams -> DepResolverParams setMinimizeConflictSet minimize params = params {@@ -755,7 +765,8 @@ Step (showDepResolverParams finalparams) $ fmap (validateSolverResult platform comp indGoals)- $ runSolver solver (SolverConfig reordGoals cntConflicts minimize indGoals noReinstalls+ $ runSolver solver (SolverConfig reordGoals cntConflicts fineGrained minimize+ indGoals noReinstalls shadowing strFlags allowBootLibs onlyConstrained_ maxBkjumps enableBj solveExes order verbosity (PruneAfterFirstSuccess False)) platform comp installedPkgIndex sourcePkgIndex@@ -769,6 +780,7 @@ sourcePkgIndex reordGoals cntConflicts+ fineGrained minimize indGoals noReinstalls@@ -1015,9 +1027,9 @@ -> Either [ResolveNoDepsError] [UnresolvedSourcePackage] resolveWithoutDependencies (DepResolverParams targets constraints prefs defpref installedPkgIndex sourcePkgIndex- _reorderGoals _countConflicts _minimizeConflictSet- _indGoals _avoidReinstalls _shadowing _strFlags- _maxBjumps _enableBj _solveExes+ _reorderGoals _countConflicts _fineGrained+ _minimizeConflictSet _indGoals _avoidReinstalls+ _shadowing _strFlags _maxBjumps _enableBj _solveExes _allowBootLibInstalls _onlyConstrained _order _verbosity) = collectEithers $ map selectPackage (Set.toList targets) where
Distribution/Client/Dependency/Types.hs view
@@ -2,23 +2,16 @@ module Distribution.Client.Dependency.Types ( PreSolver(..), Solver(..),- PackagesPreferenceDefault(..),- ) where -import Data.Char- ( isAlpha, toLower )+import Distribution.Client.Compat.Prelude+import Prelude () -import qualified Distribution.Deprecated.ReadP as Parse- ( pfail, munch1 )-import Distribution.Deprecated.Text- ( Text(..) )+import Distribution.Deprecated.Text (Text (..))+import Text.PrettyPrint (text) -import Text.PrettyPrint- ( text )-import GHC.Generics (Generic)-import Distribution.Compat.Binary (Binary(..))+import qualified Distribution.Deprecated.ReadP as Parse (munch1, pfail) -- | All the solvers that can be selected.@@ -31,6 +24,9 @@ instance Binary PreSolver instance Binary Solver++instance Structured PreSolver+instance Structured Solver instance Text PreSolver where disp AlwaysModular = text "modular"
Distribution/Client/DistDirLayout.hs view
@@ -155,11 +155,11 @@ -- | Information about the root directory of the project. ----- It can either be an implict project root in the current dir if no+-- It can either be an implicit project root in the current dir if no -- @cabal.project@ file is found, or an explicit root if the file is found. -- data ProjectRoot =- -- | -- ^ An implict project root. It contains the absolute project+ -- | -- ^ An implicit project root. It contains the absolute project -- root dir. ProjectRootImplicit FilePath
Distribution/Client/Exec.hs view
@@ -89,7 +89,7 @@ Windows -> "PATH" _ -> "LD_LIBRARY_PATH" env getGlobalPackageDB hcProgram packagePathEnvVar = do- let Just program = lookupProgram hcProgram programDb+ let program = fromMaybe (error "failed to find hcProgram") $ lookupProgram hcProgram programDb gDb <- getGlobalPackageDB verbosity program sandboxConfigFilePath <- getSandboxConfigFilePath mempty let sandboxPackagePath = sandboxPackageDBPath sandboxDir comp platform
Distribution/Client/Fetch.hs view
@@ -162,6 +162,8 @@ . setCountConflicts countConflicts + . setFineGrainedConflicts fineGrainedConflicts+ . setMinimizeConflictSet minimizeConflictSet . setShadowPkgs shadowPkgs@@ -199,6 +201,7 @@ reorderGoals = fromFlag (fetchReorderGoals fetchFlags) countConflicts = fromFlag (fetchCountConflicts fetchFlags)+ fineGrainedConflicts = fromFlag (fetchFineGrainedConflicts fetchFlags) minimizeConflictSet = fromFlag (fetchMinimizeConflictSet fetchFlags) independentGoals = fromFlag (fetchIndependentGoals fetchFlags) shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags)
Distribution/Client/FetchUtils.hs view
@@ -162,7 +162,7 @@ -- | Fetch a repo package if we don't have it already. -- fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath-fetchRepoTarball verbosity repoCtxt repo pkgid = do+fetchRepoTarball verbosity' repoCtxt repo pkgid = do fetched <- doesFileExist (packageFile repo pkgid) if fetched then do info verbosity $ display pkgid ++ " has already been downloaded."@@ -171,11 +171,13 @@ res <- downloadRepoPackage progressMessage verbosity ProgressDownloaded (display pkgid) return res-- where+ -- whether we download or not is non-deterministic+ verbosity = verboseUnmarkOutput verbosity'+ downloadRepoPackage = case repo of RepoLocal{..} -> return (packageFile repo pkgid)+ RepoLocalNoIndex{..} -> return (packageFile repo pkgid) RepoRemote{..} -> do transport <- repoContextGetTransport repoCtxt@@ -291,6 +293,7 @@ -- the tarball for a given @PackageIdentifer@ is stored. -- packageDir :: Repo -> PackageId -> FilePath+packageDir (RepoLocalNoIndex (LocalRepo _ dir _) _) _pkgid = dir packageDir repo pkgid = repoLocalDir repo </> display (packageName pkgid) </> display (packageVersion pkgid)
Distribution/Client/FileMonitor.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving, NamedFieldPuns, BangPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -34,6 +35,11 @@ updateFileMonitor, MonitorTimestamp, beginUpdateFileMonitor,++ -- * Internal+ MonitorStateFileSet,+ MonitorStateFile,+ MonitorStateGlob, ) where import Prelude ()@@ -41,7 +47,6 @@ import qualified Data.Map.Strict as Map import qualified Data.ByteString.Lazy as BS-import qualified Distribution.Compat.Binary as Binary import qualified Data.Hashable as Hashable import Control.Monad@@ -56,7 +61,7 @@ import Distribution.Client.Glob import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic) import Distribution.Client.Utils (mergeBy, MergeResult(..))-+import Distribution.Utils.Structured (structuredDecodeOrFailIO, structuredEncode) import System.FilePath import System.Directory import System.IO@@ -99,6 +104,10 @@ instance Binary MonitorKindFile instance Binary MonitorKindDir +instance Structured MonitorFilePath+instance Structured MonitorKindFile+instance Structured MonitorKindDir+ -- | Monitor a single file for changes, based on its modification time. -- The monitored file is considered to have changed if it no longer -- exists or if its modification time has changed.@@ -202,8 +211,11 @@ -- there is also no particular gain either. That said, we do preserve the -- order of the lists just to reduce confusion (and have predictable I/O -- patterns).- deriving Show+ deriving (Show, Generic) +instance Binary MonitorStateFileSet+instance Structured MonitorStateFileSet+ type Hash = Int -- | The state necessary to determine whether a monitored file has changed.@@ -232,6 +244,8 @@ instance Binary MonitorStateFile instance Binary MonitorStateFileStatus+instance Structured MonitorStateFile+instance Structured MonitorStateFileStatus -- | The state necessary to determine whether the files matched by a globbing -- match have changed.@@ -257,6 +271,9 @@ instance Binary MonitorStateGlob instance Binary MonitorStateGlobRel +instance Structured MonitorStateGlob+instance Structured MonitorStateGlobRel+ -- | We can build a 'MonitorStateFileSet' from a set of 'MonitorFilePath' by -- inspecting the state of the file system, and we can go in the reverse -- direction by just forgetting the extra info.@@ -399,7 +416,7 @@ -- See 'FileMonitor' for a full explanation. -- checkFileMonitorChanged- :: (Binary a, Binary b)+ :: (Binary a, Structured a, Binary b, Structured b) => FileMonitor a b -- ^ cache file path -> FilePath -- ^ root directory -> a -- ^ guard or key value@@ -477,23 +494,24 @@ -- -- This determines the type and format of the binary cache file. ---readCacheFile :: (Binary a, Binary b)+readCacheFile :: (Binary a, Structured a, Binary b, Structured b) => FileMonitor a b -> IO (Either String (MonitorStateFileSet, a, b)) readCacheFile FileMonitor {fileMonitorCacheFile} =- withBinaryFile fileMonitorCacheFile ReadMode $ \hnd ->- Binary.decodeOrFailIO =<< BS.hGetContents hnd+ withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> do+ contents <- BS.hGetContents hnd+ structuredDecodeOrFailIO contents -- | Helper for writing the cache file. -- -- This determines the type and format of the binary cache file. ---rewriteCacheFile :: (Binary a, Binary b)+rewriteCacheFile :: (Binary a, Structured a, Binary b, Structured b) => FileMonitor a b -> MonitorStateFileSet -> a -> b -> IO () rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result = writeFileAtomic fileMonitorCacheFile $- Binary.encode (fileset, key, result)+ structuredEncode (fileset, key, result) -- | Probe the file system to see if any of the monitored files have changed. --@@ -754,7 +772,7 @@ -- any files then you can use @Nothing@ for the timestamp parameter. -- updateFileMonitor- :: (Binary a, Binary b)+ :: (Binary a, Structured a, Binary b, Structured b) => FileMonitor a b -- ^ cache file path -> FilePath -- ^ root directory -> Maybe MonitorTimestamp -- ^ timestamp when the update action started@@ -961,7 +979,7 @@ -- that the set of files to monitor can change then it's simpler just to throw -- away the structure and use a finite map. ---readCacheFileHashes :: (Binary a, Binary b)+readCacheFileHashes :: (Binary a, Structured a, Binary b, Structured b) => FileMonitor a b -> IO FileHashCache readCacheFileHashes monitor = handleDoesNotExist Map.empty $@@ -1080,12 +1098,17 @@ then return Nothing else return (Just mtime') --- | Run an IO computation, returning @e@ if there is an 'error'+-- | Run an IO computation, returning the first argument @e@ if there is an 'error' -- call. ('ErrorCall') handleErrorCall :: a -> IO a -> IO a-handleErrorCall e =- handle (\(ErrorCall _) -> return e)+handleErrorCall e = handle handler where+#if MIN_VERSION_base(4,9,0)+ handler (ErrorCallWithLocation _ _) = return e+#else+ handler (ErrorCall _) = return e+#endif + -- | Run an IO computation, returning @e@ if there is any 'IOException'. -- -- This policy is OK in the file monitor code because it just causes the@@ -1105,15 +1128,3 @@ -- Instances -- -instance Binary MonitorStateFileSet where- put (MonitorStateFileSet singlePaths globPaths) = do- put (1 :: Int) -- version- put singlePaths- put globPaths- get = do- ver <- get- if ver == (1 :: Int)- then do singlePaths <- get- globPaths <- get- return $! MonitorStateFileSet singlePaths globPaths- else fail "MonitorStateFileSet: wrong version"
Distribution/Client/Freeze.hs view
@@ -175,6 +175,8 @@ . setCountConflicts countConflicts + . setFineGrainedConflicts fineGrainedConflicts+ . setMinimizeConflictSet minimizeConflictSet . setShadowPkgs shadowPkgs@@ -207,6 +209,7 @@ reorderGoals = fromFlag (freezeReorderGoals freezeFlags) countConflicts = fromFlag (freezeCountConflicts freezeFlags)+ fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags) minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags) independentGoals = fromFlag (freezeIndependentGoals freezeFlags) shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags)
Distribution/Client/GZipUtils.hs view
@@ -18,12 +18,14 @@ maybeDecompress, ) where +import Prelude ()+import Distribution.Client.Compat.Prelude+ import Codec.Compression.Zlib.Internal import Data.ByteString.Lazy.Internal as BS (ByteString(Empty, Chunk)) #if MIN_VERSION_zlib(0,6,0) import Control.Exception (throw)-import Control.Monad (liftM) import Control.Monad.ST.Lazy (ST, runST) import qualified Data.ByteString as Strict #endif
Distribution/Client/GenBounds.hs view
@@ -17,6 +17,7 @@ import Prelude () import Distribution.Client.Compat.Prelude+import Distribution.Utils.Generic (safeLast) import Distribution.Client.Init ( incVersion )@@ -59,9 +60,9 @@ -- | Does this version range have an upper bound? hasUpperBound :: VersionRange -> Bool hasUpperBound vr =- case asVersionIntervals vr of- [] -> False- is -> if snd (last is) == NoUpperBound then False else True+ case safeLast (asVersionIntervals vr) of+ Nothing -> False+ Just l -> if snd l == NoUpperBound then False else True -- | Given a version, return an API-compatible (according to PVP) version range. --
Distribution/Client/Get.hs view
@@ -24,6 +24,7 @@ import Prelude () import Distribution.Client.Compat.Prelude hiding (get)+import Data.Ord (comparing) import Distribution.Compat.Directory ( listDirectory ) import Distribution.Package@@ -34,10 +35,13 @@ ( notice, die', info, writeFileAtomic ) import Distribution.Verbosity ( Verbosity )+import Distribution.Pretty (prettyShow) import Distribution.Deprecated.Text (display) import qualified Distribution.PackageDescription as PD import Distribution.Simple.Program ( programName )+import Distribution.Types.SourceRepo (RepoKind (..))+import Distribution.Client.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy) import Distribution.Client.Setup ( GlobalFlags(..), GetFlags(..), RepoContext(..) )@@ -114,7 +118,7 @@ . map (\pkg -> (packageId pkg, packageSourceRepos pkg)) where kind = fromFlag . getSourceRepository $ getFlags- packageSourceRepos :: SourcePackage loc -> [SourceRepo]+ packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo] packageSourceRepos = PD.sourceRepos . PD.packageDescription . packageDescription@@ -197,11 +201,11 @@ data ClonePackageException = ClonePackageNoSourceRepos PackageId | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind)- | ClonePackageNoRepoType PackageId SourceRepo- | ClonePackageUnsupportedRepoType PackageId SourceRepo RepoType- | ClonePackageNoRepoLocation PackageId SourceRepo+ | ClonePackageNoRepoType PackageId PD.SourceRepo+ | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType+ | ClonePackageNoRepoLocation PackageId PD.SourceRepo | ClonePackageDestinationExists PackageId FilePath Bool- | ClonePackageFailedWithExitCode PackageId SourceRepo String ExitCode+ | ClonePackageFailedWithExitCode PackageId SourceRepoProxy String ExitCode deriving (Show, Eq) instance Exception ClonePackageException where@@ -237,7 +241,7 @@ displayException (ClonePackageFailedWithExitCode pkgid repo vcsprogname exitcode) = "Failed to fetch the source repository for package " ++ display pkgid- ++ maybe "" (", repository location " ++) (PD.repoLocation repo) ++ " ("+ ++ ", repository location " ++ srpLocation repo ++ " (" ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")." @@ -248,7 +252,7 @@ clonePackagesFromSourceRepo :: Verbosity -> FilePath -- ^ destination dir prefix -> Maybe RepoKind -- ^ preferred 'RepoKind'- -> [(PackageId, [SourceRepo])]+ -> [(PackageId, [PD.SourceRepo])] -- ^ the packages and their -- available 'SourceRepo's -> IO ()@@ -268,14 +272,14 @@ [ cloneSourceRepo verbosity vcs' repo destDir `catch` \exitcode -> throwIO (ClonePackageFailedWithExitCode- pkgid repo (programName (vcsProgram vcs)) exitcode)+ pkgid (srpToProxy repo) (programName (vcsProgram vcs)) exitcode) | (pkgid, repo, vcs, destDir) <- pkgrepos'- , let Just vcs' = Map.lookup (vcsRepoType vcs) vcss+ , let vcs' = Map.findWithDefault (error $ "Cannot configure " ++ prettyShow (vcsRepoType vcs)) (vcsRepoType vcs) vcss ] where- preCloneChecks :: (PackageId, [SourceRepo])- -> IO (PackageId, SourceRepo, VCS Program, FilePath)+ preCloneChecks :: (PackageId, [PD.SourceRepo])+ -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath) preCloneChecks (pkgid, repos) = do repo <- case selectPackageSourceRepo preferredRepoKind repos of Just repo -> return repo@@ -283,13 +287,13 @@ Nothing -> throwIO (ClonePackageNoSourceReposOfKind pkgid preferredRepoKind) - vcs <- case validateSourceRepo repo of- Right (_, _, _, vcs) -> return vcs+ (repo', vcs) <- case validatePDSourceRepo repo of+ Right (repo', _, _, vcs) -> return (repo', vcs) Left SourceRepoRepoTypeUnspecified -> throwIO (ClonePackageNoRepoType pkgid repo) - Left (SourceRepoRepoTypeUnsupported repoType) ->- throwIO (ClonePackageUnsupportedRepoType pkgid repo repoType)+ Left (SourceRepoRepoTypeUnsupported repo' repoType) ->+ throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType) Left SourceRepoLocationUnspecified -> throwIO (ClonePackageNoRepoLocation pkgid repo)@@ -300,5 +304,37 @@ when (destDirExists || destFileExists) $ throwIO (ClonePackageDestinationExists pkgid destDir destDirExists) - return (pkgid, repo, vcs, destDir)+ return (pkgid, repo', vcs, destDir) +-------------------------------------------------------------------------------+-- Selecting+-------------------------------------------------------------------------------++-- | 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+ -> [PD.SourceRepo]+ -> Maybe PD.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 (PD.repoKind repo ==) preferredRepoKind)+ where+ thisFirst :: PD.SourceRepo -> Int+ thisFirst r = case PD.repoKind r of+ RepoThis -> 0+ 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+ RepoKindUnknown _ -> 2
Distribution/Client/Glob.hs view
@@ -61,6 +61,10 @@ instance Binary FilePathGlobRel instance Binary GlobPiece +instance Structured FilePathGlob+instance Structured FilePathRoot+instance Structured FilePathGlobRel+instance Structured GlobPiece -- | Check if a 'FilePathGlob' doesn't actually make use of any globbing and -- is in fact equivalent to a non-glob 'FilePath'.
Distribution/Client/GlobalFlags.hs view
@@ -17,7 +17,7 @@ import Distribution.Client.Compat.Prelude import Distribution.Client.Types- ( Repo(..), RemoteRepo(..) )+ ( Repo(..), RemoteRepo(..), LocalRepo (..), localRepoCacheKey ) import Distribution.Simple.Setup ( Flag(..), fromFlag, flagToMaybe ) import Distribution.Utils.NubList@@ -27,7 +27,7 @@ import Distribution.Verbosity ( Verbosity ) import Distribution.Simple.Utils- ( info )+ ( info, warn ) import Control.Concurrent ( MVar, newMVar, modifyMVar )@@ -48,6 +48,8 @@ import qualified Distribution.Client.Security.HTTP as Sec.HTTP import qualified Distribution.Client.Security.DNS as Sec.DNS +import qualified System.FilePath.Posix as FilePath.Posix+ -- ------------------------------------------------------------ -- * Global flags -- ------------------------------------------------------------@@ -62,6 +64,7 @@ globalRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. globalCacheDir :: Flag FilePath, globalLocalRepos :: NubList FilePath,+ globalLocalNoIndexRepos :: NubList LocalRepo, globalLogsDir :: Flag FilePath, globalWorldFile :: Flag FilePath, globalRequireSandbox :: Flag Bool,@@ -83,6 +86,7 @@ globalRemoteRepos = mempty, globalCacheDir = mempty, globalLocalRepos = mempty,+ globalLocalNoIndexRepos = mempty, globalLogsDir = mempty, globalWorldFile = mempty, globalRequireSandbox = Flag False,@@ -141,20 +145,25 @@ withRepoContext verbosity globalFlags = withRepoContext' verbosity- (fromNubList (globalRemoteRepos globalFlags))- (fromNubList (globalLocalRepos globalFlags))- (fromFlag (globalCacheDir globalFlags))- (flagToMaybe (globalHttpTransport globalFlags))- (flagToMaybe (globalIgnoreExpiry globalFlags))- (fromNubList (globalProgPathExtra globalFlags))+ (fromNubList (globalRemoteRepos globalFlags))+ (fromNubList (globalLocalRepos globalFlags))+ (fromNubList (globalLocalNoIndexRepos globalFlags))+ (fromFlag (globalCacheDir globalFlags))+ (flagToMaybe (globalHttpTransport globalFlags))+ (flagToMaybe (globalIgnoreExpiry globalFlags))+ (fromNubList (globalProgPathExtra globalFlags)) -withRepoContext' :: Verbosity -> [RemoteRepo] -> [FilePath]+withRepoContext' :: Verbosity -> [RemoteRepo] -> [FilePath] -> [LocalRepo] -> FilePath -> Maybe String -> Maybe Bool -> [FilePath] -> (RepoContext -> IO a) -> IO a-withRepoContext' verbosity remoteRepos localRepos+withRepoContext' verbosity remoteRepos localRepos localNoIndexRepos sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do+ for_ localNoIndexRepos $ \local ->+ unless (FilePath.Posix.isAbsolute (localRepoPath local)) $+ warn verbosity $ "file+noindex " ++ localRepoName local ++ " repository path is not absolute; this is fragile, and not recommended"+ transportRef <- newMVar Nothing let httpLib = Sec.HTTP.transportAdapter verbosity@@ -162,6 +171,7 @@ initSecureRepos verbosity httpLib secureRemoteRepos $ \secureRepos' -> callback RepoContext { repoContextRepos = allRemoteRepos+ ++ allLocalNoIndexRepos ++ map RepoLocal localRepos , repoContextGetTransport = getTransport transportRef , repoContextWithSecureRepo = withSecureRepo secureRepos'@@ -170,11 +180,21 @@ where secureRemoteRepos = [ (remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos ]++ allRemoteRepos :: [Repo] allRemoteRepos = [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir | remote <- remoteRepos , let cacheDir = sharedCacheDir </> remoteRepoName remote isSecure = remoteRepoSecure remote == Just True+ ]++ allLocalNoIndexRepos :: [Repo]+ allLocalNoIndexRepos =+ [ RepoLocalNoIndex local cacheDir+ | local <- localNoIndexRepos+ , let cacheDir | localRepoSharedCache local = sharedCacheDir </> localRepoCacheKey local+ | otherwise = localRepoPath local ] getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport
+ Distribution/Client/HashValue.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+module Distribution.Client.HashValue (+ HashValue,+ hashValue,+ truncateHash,+ showHashValue,+ readFileHashValue,+ hashFromTUF,+ ) where++import Distribution.Client.Compat.Prelude+import Prelude ()++import qualified Hackage.Security.Client as Sec++import qualified Crypto.Hash.SHA256 as SHA256+import qualified Data.ByteString.Base16 as Base16+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS++import Control.Exception (evaluate)+import System.IO (IOMode (..), withBinaryFile)++-----------------------------------------------+-- The specific choice of hash implementation+--++-- Is a crypto hash necessary here? One thing to consider is who controls the+-- inputs and what's the result of a hash collision. Obviously we should not+-- install packages we don't trust because they can run all sorts of code, but+-- if I've checked there's no TH, no custom Setup etc, is there still a+-- problem? If someone provided us a tarball that hashed to the same value as+-- some other package and we installed it, we could end up re-using that+-- installed package in place of another one we wanted. So yes, in general+-- there is some value in preventing intentional hash collisions in installed+-- package ids.++newtype HashValue = HashValue BS.ByteString+ deriving (Eq, Generic, Show, Typeable)++-- Cannot do any sensible validation here. Although we use SHA256+-- for stuff we hash ourselves, we can also get hashes from TUF+-- and that can in principle use different hash functions in future.+--+-- Therefore, we simply derive this structurally.+instance Binary HashValue+instance Structured HashValue++-- | Hash some data. Currently uses SHA256.+--+hashValue :: LBS.ByteString -> HashValue+hashValue = HashValue . SHA256.hashlazy++showHashValue :: HashValue -> String+showHashValue (HashValue digest) = BS.unpack (Base16.encode digest)++-- | Hash the content of a file. Uses SHA256.+--+readFileHashValue :: FilePath -> IO HashValue+readFileHashValue tarball =+ withBinaryFile tarball ReadMode $ \hnd ->+ evaluate . hashValue =<< LBS.hGetContents hnd++-- | Convert a hash from TUF metadata into a 'PackageSourceHash'.+--+-- Note that TUF hashes don't neessarily have to be SHA256, since it can+-- support new algorithms in future.+--+hashFromTUF :: Sec.Hash -> HashValue+hashFromTUF (Sec.Hash hashstr) =+ --TODO: [code cleanup] either we should get TUF to use raw bytestrings or+ -- perhaps we should also just use a base16 string as the internal rep.+ case Base16.decode (BS.pack hashstr) of+ (hash, trailing) | not (BS.null hash) && BS.null trailing+ -> HashValue hash+ _ -> error "hashFromTUF: cannot decode base16 hash"+++-- | Truncate a 32 byte SHA256 hash to+--+-- For example 20 bytes render as 40 hex chars, which we use for unit-ids.+-- Or even 4 bytes for 'hashedInstalledPackageIdShort'+--+truncateHash :: Int -> HashValue -> HashValue+truncateHash n (HashValue h) = HashValue (BS.take n h)
Distribution/Client/HttpUtils.hs view
@@ -15,7 +15,8 @@ ) where import Prelude ()-import Distribution.Client.Compat.Prelude+import Distribution.Client.Compat.Prelude hiding (Proxy (..))+import Distribution.Utils.Generic import Network.HTTP ( Request (..), Response (..), RequestMethod (..)@@ -38,8 +39,8 @@ import Distribution.Verbosity (Verbosity) import Distribution.Pretty (prettyShow) import Distribution.Simple.Utils- ( die', info, warn, debug, notice, writeFileAtomic- , copyFileVerbose, withTempFile )+ ( die', info, warn, debug, notice+ , copyFileVerbose, withTempFile, IOData (..) ) import Distribution.Client.Utils ( withTempFileName ) import Distribution.Client.Types@@ -281,7 +282,7 @@ Just prog -> snd <$> requireProgram verbosity prog baseProgDb -- ^^ if it fails, it'll fail here - let Just transport = mkTrans progdb+ let transport = fromMaybe (error "configureTransport: failed to make transport") $ mkTrans progdb return transport { transportManuallySelected = True } Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name@@ -305,8 +306,8 @@ [ (name, transport) | (name, _, _, mkTrans) <- supportedTransports , transport <- maybeToList (mkTrans progdb) ]- -- there's always one because the plain one is last and never fails- let (name, transport) = head availableTransports+ let (name, transport) =+ fromMaybe ("plain-http", plainHttpTransport) (safeHead availableTransports) debug verbosity $ "Selected http transport implementation: " ++ name return transport { transportManuallySelected = False }@@ -350,7 +351,7 @@ addAuthConfig auth progInvocation = progInvocation { progInvokeInput = do (uname, passwd) <- auth- return $ unlines+ return $ IODataText $ unlines [ "--digest" , "--user " ++ uname ++ ":" ++ passwd ]@@ -507,7 +508,7 @@ -- and sensitive data should not be passed via command line arguments. let invocation = (programInvocation prog ("--input-file=-" : args))- { progInvokeInput = Just (uriToString id uri "")+ { progInvokeInput = Just $ IODataText $ uriToString id uri "" } -- wget returns its output on stderr rather than stdout@@ -618,7 +619,7 @@ ] debug verbosity script getProgramInvocationOutput verbosity (programInvocation prog args)- { progInvokeInput = Just (script ++ "\nExit(0);")+ { progInvokeInput = Just $ IODataText $ script ++ "\nExit(0);" } escape = show@@ -644,9 +645,11 @@ HdrIfModifiedSince -> "IfModifiedSince = " ++ escape value HdrReferer -> "Referer = " ++ escape value HdrTransferEncoding -> "TransferEncoding = " ++ escape value- HdrRange -> let (start, _:end) =+ HdrRange -> let (start, end) = if "bytes=" `isPrefixOf` value- then break (== '-') value'+ then case break (== '-') value' of+ (start', '-':end') -> (start', end')+ _ -> error $ "Could not decode range: " ++ value else error $ "Could not decode range: " ++ value value' = drop 6 value in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");"
Distribution/Client/IndexUtils.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} -----------------------------------------------------------------------------@@ -50,6 +51,8 @@ import Distribution.Client.IndexUtils.Timestamp import Distribution.Client.Types import Distribution.Verbosity+import Distribution.Pretty (prettyShow)+import Distribution.Parsec (simpleParsec) import Distribution.Package ( PackageId, PackageIdentifier(..), mkPackageName@@ -70,7 +73,7 @@ import Distribution.Deprecated.Text ( display, simpleParse ) import Distribution.Simple.Utils- ( die', warn, info )+ ( die', warn, info, createDirectoryIfMissingVerbose ) import Distribution.Client.Setup ( RepoContext(..) ) @@ -83,9 +86,11 @@ import Distribution.Solver.Types.SourcePackage import qualified Data.Map as Map+import qualified Data.Set as Set import Control.DeepSeq import Control.Monad import Control.Exception+import Data.List (stripPrefix) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Data.ByteString.Char8 as BSS@@ -93,18 +98,20 @@ import Distribution.Client.GZipUtils (maybeDecompress) import Distribution.Client.Utils ( byteStringToFilePath , tryFindAddSourcePackageDesc )-import Distribution.Compat.Binary+import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredEncodeFile, structuredDecodeFileOrFail) import Distribution.Compat.Exception (catchIO) import Distribution.Compat.Time (getFileAge, getModTime) import System.Directory (doesFileExist, doesDirectoryExist) import System.FilePath- ( (</>), (<.>), takeExtension, replaceExtension, splitDirectories, normalise )-import System.FilePath.Posix as FilePath.Posix- ( takeFileName )+ ( (</>), (<.>), takeFileName, takeExtension, replaceExtension, splitDirectories, normalise, takeDirectory )+import qualified System.FilePath.Posix as FilePath.Posix import System.IO import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error (isDoesNotExistError)+import Distribution.Compat.Directory (listDirectory) +import qualified Codec.Compression.GZip as GZip+ import qualified Hackage.Security.Client as Sec import qualified Hackage.Security.Util.Some as Sec @@ -130,9 +137,10 @@ indexBaseName repo = repoLocalDir repo </> fn where fn = case repo of- RepoSecure {} -> "01-index"- RepoRemote {} -> "00-index"- RepoLocal {} -> "00-index"+ RepoSecure {} -> "01-index"+ RepoRemote {} -> "00-index"+ RepoLocal {} -> "00-index"+ RepoLocalNoIndex {} -> "noindex" ------------------------------------------------------------------------ -- Reading the source package index@@ -218,7 +226,12 @@ describeState (IndexStateTime time) = "historical state as of " ++ display time pkgss <- forM (repoContextRepos repoCtxt) $ \r -> do- let rname = maybe "" remoteRepoName $ maybeRepoRemote r+ let rname = case r of+ RepoRemote remote _ -> remoteRepoName remote+ RepoSecure remote _ -> remoteRepoName remote+ RepoLocalNoIndex local _ -> localRepoName local+ RepoLocal _ -> ""+ info verbosity ("Reading available packages of " ++ rname ++ "...") idxState <- case mb_idxState of@@ -240,6 +253,7 @@ unless (idxState == IndexStateHead) $ case r of RepoLocal path -> warn verbosity ("index-state ignored for old-format repositories (local repository '" ++ path ++ "')")+ RepoLocalNoIndex {} -> warn verbosity "index-state ignored for file+noindex repositories" RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ rname ++ "')") RepoSecure {} -> pure () @@ -301,7 +315,7 @@ -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo) readRepoIndex verbosity repoCtxt repo idxState = handleNotFound $ do- warnIfIndexIsOld =<< getIndexFileAge repo+ when (isRepoRemote repo) $ warnIfIndexIsOld =<< getIndexFileAge repo updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) readPackageIndexCacheFile verbosity mkAvailablePackage (RepoIndex repoCtxt repo)@@ -330,6 +344,10 @@ RepoLocal{..} -> warn verbosity $ "The package list for the local repo '" ++ repoLocalDir ++ "' is missing. The repo is invalid."+ RepoLocalNoIndex local _ -> warn verbosity $+ "Error during construction of local+noindex "+ ++ localRepoName local ++ " repository index: "+ ++ show e return (mempty,mempty,emptyStateInfo) else ioError e @@ -338,11 +356,12 @@ when (dt >= isOldThreshold) $ case repo of RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt- RepoLocal{..} -> return ()+ RepoLocal{} -> return ()+ RepoLocalNoIndex {} -> return () errMissingPackageList repoRemote = "The package list for '" ++ remoteRepoName repoRemote- ++ "' does not exist. Run 'cabal update' to download it."+ ++ "' does not exist. Run 'cabal update' to download it." ++ show repoRemote errOutdatedPackageList repoRemote dt = "The package list for '" ++ remoteRepoName repoRemote ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "@@ -366,19 +385,24 @@ -- updateRepoIndexCache :: Verbosity -> Index -> IO () updateRepoIndexCache verbosity index =- whenCacheOutOfDate index $ do- updatePackageIndexCacheFile verbosity index+ whenCacheOutOfDate index $ updatePackageIndexCacheFile verbosity index whenCacheOutOfDate :: Index -> IO () -> IO () whenCacheOutOfDate index action = do exists <- doesFileExist $ cacheFile index if not exists- then action- else do- indexTime <- getModTime $ indexFile index- cacheTime <- getModTime $ cacheFile index- when (indexTime > cacheTime) action+ then action+ else if localNoIndex index+ then return () -- TODO: don't update cache for local+noindex repositories+ else do+ indexTime <- getModTime $ indexFile index+ cacheTime <- getModTime $ cacheFile index+ when (indexTime > cacheTime) action +localNoIndex :: Index -> Bool+localNoIndex (RepoIndex _ (RepoLocalNoIndex {})) = True+localNoIndex _ = False+ ------------------------------------------------------------------------ -- Reading the index file --@@ -391,9 +415,10 @@ -- | A build tree reference is either a link or a snapshot. data BuildTreeRefType = SnapshotRef | LinkRef- deriving (Eq,Generic)+ deriving (Eq,Show,Generic) instance Binary BuildTreeRefType+instance Structured BuildTreeRefType refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType refTypeFromTypeCode t@@ -492,7 +517,7 @@ extractPrefs :: Tar.Entry -> Maybe [Dependency] extractPrefs entry = case Tar.entryContent entry of Tar.NormalFile content _- | takeFileName entrypath == "preferred-versions"+ | FilePath.Posix.takeFileName entrypath == "preferred-versions" -> Just prefs where entrypath = Tar.entryPath entry@@ -562,21 +587,28 @@ RepoSecure {} -> True RepoRemote {} -> False RepoLocal {} -> False+ RepoLocalNoIndex {} -> True is01Index (SandboxIndex _) = False updatePackageIndexCacheFile :: Verbosity -> Index -> IO () updatePackageIndexCacheFile verbosity index = do info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...")- withIndexEntries verbosity index $ \entries -> do- let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries)- cache = Cache { cacheHeadTs = maxTs- , cacheEntries = entries- }- writeIndexCache index cache- info verbosity ("Index cache updated to index-state "- ++ display (cacheHeadTs cache))+ withIndexEntries verbosity index callback callbackNoIndex+ where+ callback entries = do+ let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries)+ cache = Cache { cacheHeadTs = maxTs+ , cacheEntries = entries+ }+ writeIndexCache index cache+ info verbosity ("Index cache updated to index-state "+ ++ display (cacheHeadTs cache)) + callbackNoIndex entries = do+ writeNoIndexCache verbosity index $ NoIndexCache entries+ info verbosity "Index cache updated"+ -- | Read the index (for the purpose of building a cache) -- -- The callback is provided with list of cache entries, which is guaranteed to@@ -597,8 +629,12 @@ -- TODO: It would be nicer if we actually incrementally updated @cabal@'s -- cache, rather than reconstruct it from zero on each update. However, this -- would require a change in the cache format.-withIndexEntries :: Verbosity -> Index -> ([IndexCacheEntry] -> IO a) -> IO a-withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{..}) callback =+withIndexEntries+ :: Verbosity -> Index+ -> ([IndexCacheEntry] -> IO a)+ -> ([NoIndexCacheEntry] -> IO a)+ -> IO a+withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{..}) callback _ = repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do -- Incrementally (lazily) read all the entries in the tar file in order,@@ -625,7 +661,60 @@ timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $ epochTimeToTimestamp $ Sec.indexEntryTime sie -withIndexEntries verbosity index callback = do -- non-secure repositories+withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo name localDir _) _cacheDir)) _ callback = do+ dirContents <- listDirectory localDir+ let contentSet = Set.fromList dirContents++ entries <- handle handler $ fmap catMaybes $ forM dirContents $ \file -> do+ case isTarGz file of+ Nothing -> do+ unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $+ info verbosity $ "Skipping " ++ file+ return Nothing+ Just pkgid | cabalPath `Set.member` contentSet -> do+ contents <- BSS.readFile (localDir </> cabalPath)+ forM (parseGenericPackageDescriptionMaybe contents) $ \gpd ->+ return (CacheGPD gpd contents)+ where+ cabalPath = prettyShow pkgid ++ ".cabal"+ Just pkgId -> do+ -- check for the right named .cabal file in the compressed tarball+ tarGz <- BS.readFile (localDir </> file)+ let tar = GZip.decompress tarGz+ entries = Tar.read tar++ case Tar.foldEntries (readCabalEntry pkgId) Nothing (const Nothing) entries of+ Just ce -> return (Just ce)+ Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file++ info verbosity $ "Entries in file+noindex repository " ++ name+ for_ entries $ \(CacheGPD gpd _) ->+ info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd)++ callback entries+ where+ handler :: IOException -> IO a+ handler e = die' verbosity $ "Error while updating index for " ++ name ++ " repository " ++ show e++ isTarGz :: FilePath -> Maybe PackageIdentifier+ isTarGz fp = do+ pfx <- stripSuffix ".tar.gz" fp+ simpleParsec pfx++ stripSuffix sfx str = fmap reverse (stripPrefix (reverse sfx) (reverse str))++ -- look for <pkgid>/<pkgname>.cabal inside the tarball+ readCabalEntry :: PackageIdentifier -> Tar.Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry+ readCabalEntry pkgId entry Nothing+ | filename == Tar.entryPath entry+ , Tar.NormalFile contents _ <- Tar.entryContent entry+ = let bs = BS.toStrict contents+ in fmap (\gpd -> CacheGPD gpd bs) $ parseGenericPackageDescriptionMaybe bs+ where+ filename = prettyShow pkgId FilePath.Posix.</> prettyShow (packageName pkgId) ++ ".cabal"+ readCabalEntry _ _ x = x++withIndexEntries verbosity index callback _ = do -- non-secure repositories withFile (indexFile index) ReadMode $ \h -> do bs <- maybeDecompress `fmap` BS.hGetContents h pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs@@ -642,13 +731,18 @@ -> Index -> IndexState -> IO (PackageIndex pkg, [Dependency], IndexStateInfo)-readPackageIndexCacheFile verbosity mkPkg index idxState = do- cache0 <- readIndexCache verbosity index- indexHnd <- openFile (indexFile index) ReadMode- let (cache,isi) = filterCache idxState cache0- (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache- pure (pkgs,deps,isi)+readPackageIndexCacheFile verbosity mkPkg index idxState+ | localNoIndex index = do+ cache0 <- readNoIndexCache verbosity index+ pkgs <- packageNoIndexFromCache verbosity mkPkg cache0+ pure (pkgs, [], emptyStateInfo) + | otherwise = do+ cache0 <- readIndexCache verbosity index+ indexHnd <- openFile (indexFile index) ReadMode+ let (cache,isi) = filterCache idxState cache0+ (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache+ pure (pkgs,deps,isi) packageIndexFromCache :: Package pkg => Verbosity@@ -661,6 +755,21 @@ pkgIndex <- evaluate $ PackageIndex.fromList pkgs return (pkgIndex, prefs) +packageNoIndexFromCache+ :: forall pkg. Package pkg+ => Verbosity+ -> (PackageEntry -> pkg)+ -> NoIndexCache+ -> IO (PackageIndex pkg)+packageNoIndexFromCache _verbosity mkPkg cache =+ evaluate $ PackageIndex.fromList pkgs+ where+ pkgs =+ [ mkPkg $ NormalPackage pkgId gpd (BS.fromStrict bs) 0+ | CacheGPD gpd bs <- noIndexCacheEntries cache+ , let pkgId = package $ Distribution.PackageDescription.packageDescription gpd+ ]+ -- | Read package list -- -- The result package releases and preference entries are guaranteed@@ -749,8 +858,7 @@ --------------------------------------------------------------------------- Index cache data structure---+-- Index cache data structure -- -- | Read the 'Index' cache from the filesystem --@@ -773,20 +881,46 @@ Right res -> return (hashConsCache res) +readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache+readNoIndexCache verbosity index = do+ cacheOrFail <- readNoIndexCache' index+ case cacheOrFail of+ Left msg -> do+ warn verbosity $ concat+ [ "Parsing the index cache failed (", msg, "). "+ , "Trying to regenerate the index cache..."+ ]++ updatePackageIndexCacheFile verbosity index++ either (die' verbosity) return =<< readNoIndexCache' index++ -- we don't hash cons local repository cache, they are hopefully small+ Right res -> return res+ -- | Read the 'Index' cache from the filesystem without attempting to -- regenerate on parsing failures. readIndexCache' :: Index -> IO (Either String Cache) readIndexCache' index- | is01Index index = decodeFileOrFail' (cacheFile index)+ | is01Index index = structuredDecodeFileOrFail (cacheFile index) | otherwise = liftM (Right .read00IndexCache) $ BSS.readFile (cacheFile index) +readNoIndexCache' :: Index -> IO (Either String NoIndexCache)+readNoIndexCache' index = structuredDecodeFileOrFail (cacheFile index)+ -- | Write the 'Index' cache to the filesystem writeIndexCache :: Index -> Cache -> IO () writeIndexCache index cache- | is01Index index = encodeFile (cacheFile index) cache+ | is01Index index = structuredEncodeFile (cacheFile index) cache | otherwise = writeFile (cacheFile index) (show00IndexCache cache) +writeNoIndexCache :: Verbosity -> Index -> NoIndexCache -> IO ()+writeNoIndexCache verbosity index cache = do+ let path = cacheFile index+ createDirectoryIfMissingVerbose verbosity True (takeDirectory path)+ structuredEncodeFile path cache+ -- | Write the 'IndexState' to the filesystem writeIndexTimestamp :: Index -> IndexState -> IO () writeIndexTimestamp index st@@ -852,28 +986,44 @@ -- 'cacheEntries' , cacheEntries :: [IndexCacheEntry] }+ deriving (Show, Generic) instance NFData Cache where rnf = rnf . cacheEntries +-- | Cache format for 'file+noindex' repositories+newtype NoIndexCache = NoIndexCache+ { noIndexCacheEntries :: [NoIndexCacheEntry]+ }+ deriving (Show, Generic)++instance NFData NoIndexCache where+ rnf = rnf . noIndexCacheEntries+ -- | Tar files are block structured with 512 byte blocks. Every header and file -- content starts on a block boundary. -- type BlockNo = Word32 -- Tar.TarEntryOffset - data IndexCacheEntry = CachePackageId PackageId !BlockNo !Timestamp | CachePreference Dependency !BlockNo !Timestamp | CacheBuildTreeRef !BuildTreeRefType !BlockNo -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build- deriving (Eq,Generic)+ deriving (Eq,Show,Generic) +data NoIndexCacheEntry+ = CacheGPD GenericPackageDescription !BSS.ByteString+ deriving (Eq,Show,Generic)+ instance NFData IndexCacheEntry where rnf (CachePackageId pkgid _ _) = rnf pkgid rnf (CachePreference dep _ _) = rnf dep rnf (CacheBuildTreeRef _ _) = () +instance NFData NoIndexCacheEntry where+ rnf (CacheGPD gpd bs) = rnf gpd `seq` rnf bs+ cacheEntryTimestamp :: IndexCacheEntry -> Timestamp cacheEntryTimestamp (CacheBuildTreeRef _ _) = nullTimestamp cacheEntryTimestamp (CachePreference _ _ ts) = ts@@ -882,24 +1032,26 @@ ---------------------------------------------------------------------------- -- new binary 01-index.cache format -instance Binary Cache where- put (Cache headTs ents) = do- -- magic / format version- --- -- NB: this currently encodes word-size implicitly; when we- -- switch to CBOR encoding, we will have a platform- -- independent binary encoding- put (0xcaba1002::Word)- put headTs- put ents+instance Binary Cache+instance Binary IndexCacheEntry+instance Binary NoIndexCache +instance Structured Cache+instance Structured IndexCacheEntry+instance Structured NoIndexCache++-- | We need to save only .cabal file contents+instance Binary NoIndexCacheEntry where+ put (CacheGPD _ bs) = put bs+ get = do- magic <- get- when (magic /= (0xcaba1002::Word)) $- fail ("01-index.cache: unexpected magic marker encountered: " ++ show magic)- Cache <$> get <*> get+ bs <- get+ case parseGenericPackageDescriptionMaybe bs of+ Just gpd -> return (CacheGPD gpd bs)+ Nothing -> fail "Failed to parse GPD" -instance Binary IndexCacheEntry+instance Structured NoIndexCacheEntry where+ structure = nominalStructure ---------------------------------------------------------------------------- -- legacy 00-index.cache format@@ -972,16 +1124,19 @@ show00IndexCacheEntry :: IndexCacheEntry -> String show00IndexCacheEntry entry = unwords $ case entry of- CachePackageId pkgid b _ -> [ packageKey- , display (packageName pkgid)- , display (packageVersion pkgid)- , blocknoKey- , show b- ]- CacheBuildTreeRef tr b -> [ buildTreeRefKey- , [typeCodeFromRefType tr]- , show b- ]- CachePreference dep _ _ -> [ preferredVersionKey- , display dep- ]+ CachePackageId pkgid b _ ->+ [ packageKey+ , display (packageName pkgid)+ , display (packageVersion pkgid)+ , blocknoKey+ , show b+ ]+ CacheBuildTreeRef tr b ->+ [ buildTreeRefKey+ , [typeCodeFromRefType tr]+ , show b+ ]+ CachePreference dep _ _ ->+ [ preferredVersionKey+ , display dep+ ]
Distribution/Client/IndexUtils/Timestamp.hs view
@@ -21,21 +21,20 @@ , IndexState(..) ) where +import Distribution.Client.Compat.Prelude++-- read is needed for Text instance+import Prelude (read)+ import qualified Codec.Archive.Tar.Entry as Tar-import Control.DeepSeq-import Control.Monad-import Data.Char (isDigit)-import Data.Int (Int64) import Data.Time (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay) import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)-import Distribution.Compat.Binary import qualified Distribution.Deprecated.ReadP as ReadP import Distribution.Deprecated.Text import qualified Text.PrettyPrint as Disp-import GHC.Generics (Generic) -- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970). newtype Timestamp = TS Int64 -- Tar.EpochTime@@ -98,9 +97,8 @@ where showTOD = show . timeToTimeOfDay -instance Binary Timestamp where- put (TS t) = put t- get = TS `fmap` get+instance Binary Timestamp+instance Structured Timestamp instance Text Timestamp where disp = Disp.text . showTimestamp@@ -177,6 +175,7 @@ deriving (Eq,Generic,Show) instance Binary IndexState+instance Structured IndexState instance NFData IndexState instance Text IndexState where
Distribution/Client/Init.hs view
@@ -37,7 +37,8 @@ ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) import Data.List- ( groupBy, (\\) )+ ( (\\) )+import qualified Data.List.NonEmpty as NE import Data.Function ( on ) import qualified Data.Map as M@@ -636,25 +637,25 @@ -- do it. grps -> do message flags ("\nWarning: multiple packages found providing " ++ display m- ++ ": " ++ intercalate ", " (map (display . P.pkgName . head) grps))+ ++ ": " ++ intercalate ", " (fmap (display . P.pkgName . NE.head) grps)) message flags "You will need to pick one and manually add it to the Build-depends: field." return Nothing where- pkgGroups = groupBy ((==) `on` P.pkgName) (map P.packageId ps)+ pkgGroups = NE.groupBy ((==) `on` P.pkgName) (map P.packageId ps) desugar = maybe True (< mkVersion [2]) $ flagToMaybe (cabalVersion flags) -- Given a list of available versions of the same package, pick a dependency.- toDep :: [P.PackageIdentifier] -> IO P.Dependency+ toDep :: NonEmpty P.PackageIdentifier -> IO P.Dependency -- If only one version, easy. We change e.g. 0.4.2 into 0.4.*- toDep [pid] = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) (Set.singleton LMainLibName) --TODO sublibraries+ toDep (pid:|[]) = return $ P.Dependency (P.pkgName pid) (pvpize desugar . P.pkgVersion $ pid) (Set.singleton LMainLibName) --TODO sublibraries -- Otherwise, choose the latest version and issue a warning. toDep pids = do- message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.")- return $ P.Dependency (P.pkgName . head $ pids)- (pvpize desugar . maximum . map P.pkgVersion $ pids)+ message flags ("\nWarning: multiple versions of " ++ display (P.pkgName . NE.head $ pids) ++ " provide " ++ display m ++ ", choosing the latest.")+ return $ P.Dependency (P.pkgName . NE.head $ pids)+ (pvpize desugar . maximum . fmap P.pkgVersion $ pids) (Set.singleton LMainLibName) --TODO take into account sublibraries -- | Given a version, return an API-compatible (according to PVP) version range.@@ -950,7 +951,9 @@ _ -> writeMainHs flags mainFile else return () where- Flag mainFile = mainIs flags+ mainFile = case mainIs flags of+ Flag x -> x+ NoFlag -> error "createMainHs: no mainIs" --- | Write a main file if it doesn't already exist. writeMainHs :: InitFlags -> FilePath -> IO ()
Distribution/Client/Init/Heuristics.hs view
@@ -22,6 +22,7 @@ import Prelude () import Distribution.Client.Compat.Prelude+import Distribution.Utils.Generic (safeHead, safeTail, safeLast) import Distribution.Parsec (simpleParsec) import Distribution.Simple.Setup (Flag(..), flagToMaybe)@@ -56,6 +57,8 @@ import Distribution.Client.Compat.Process ( readProcessWithExitCode ) import System.Exit ( ExitCode(..) ) +import qualified Distribution.Utils.ShortText as ShortText+ -- | Return a list of candidate main files for this executable: top-level -- modules including the word 'Main' in the file name. The list is sorted in -- order of preference, shorter file names are preferred. 'Right's are existing@@ -86,7 +89,7 @@ -- | Guess the package name based on the given root directory. guessPackageName :: FilePath -> IO P.PackageName-guessPackageName = liftM (P.mkPackageName . repair . last . splitDirectories)+guessPackageName = liftM (P.mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories) . tryCanonicalizePath where -- Treat each span of non-alphanumeric characters as a hyphen. Each@@ -132,7 +135,7 @@ (files, dirs) <- liftM partitionEithers (mapM (tagIsDir dir) entries) let modules = catMaybes [ guessModuleName hierarchy file | file <- files- , isUpper (head file) ]+ , maybe False isUpper (safeHead file) ] modules' <- mapM (findImportsAndExts projectRoot) modules recMods <- mapM (scanRecursive dir hierarchy) dirs return $ concat (modules' : recMods)@@ -151,8 +154,8 @@ $ intercalate "." . reverse $ (unqualModName : hierarchy) ext = case takeExtension entry of '.':e -> e; e -> e scanRecursive parent hierarchy entry- | isUpper (head entry) = scan (parent </> entry) (entry : hierarchy)- | isLower (head entry) && not (ignoreDir entry) =+ | maybe False isUpper (safeHead entry) = scan (parent </> entry) (entry : hierarchy)+ | maybe False isLower (safeHead entry) && not (ignoreDir entry) = scanForModulesIn projectRoot $ foldl (</>) srcRoot (reverse (entry : hierarchy)) | otherwise = return [] ignoreDir ('.':_) = True@@ -345,9 +348,9 @@ -- |Get list of categories used in Hackage. NOTE: Very slow, needs to be cached knownCategories :: SourcePackageDb -> [String] knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet- [ cat | pkg <- map head (allPackagesByName sourcePkgIndex)+ [ cat | pkg <- maybeToList . safeHead =<< (allPackagesByName sourcePkgIndex) , let catList = (PD.category . PD.packageDescription . packageDescription) pkg- , cat <- splitString ',' catList+ , cat <- splitString ',' $ ShortText.fromShortText catList ] -- Parse name and email, from darcs pref files or environment variable@@ -358,7 +361,7 @@ | otherwise = (Flag $ trim nameOrEmail, Flag mail) where (nameOrEmail,erest) = break (== '<') str- (mail,_) = break (== '>') (tail erest)+ (mail,_) = break (== '>') (safeTail erest) trim :: String -> String trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse
Distribution/Client/Install.hs view
@@ -31,7 +31,9 @@ import Prelude () import Distribution.Client.Compat.Prelude+import Distribution.Utils.Generic(safeLast) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as S import Control.Exception as Exception@@ -124,7 +126,7 @@ import Distribution.Simple.Setup ( haddockCommand, HaddockFlags(..) , buildCommand, BuildFlags(..), emptyBuildFlags- , TestFlags+ , TestFlags, BenchmarkFlags , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) import qualified Distribution.Simple.Setup as Cabal ( Flag(..)@@ -133,7 +135,7 @@ , testCommand, TestFlags(..) ) import Distribution.Simple.Utils ( createDirectoryIfMissingVerbose, comparing- , writeFileAtomic, withUTF8FileContents )+ , writeFileAtomic ) import Distribution.Simple.InstallDirs as InstallDirs ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate , initialPathTemplateEnv, installDirsTemplateEnv )@@ -147,7 +149,7 @@ ( thisPackageVersion ) import Distribution.Types.GivenComponent ( GivenComponent(..) )-import Distribution.Pretty ( prettyShow ) +import Distribution.Pretty ( prettyShow ) import Distribution.Types.PackageVersionConstraint ( PackageVersionConstraint(..) ) import Distribution.Types.MungedPackageId@@ -172,6 +174,8 @@ ( Verbosity, modifyVerbosity, normal, verbose ) import Distribution.Simple.BuildPaths ( exeExtension ) +import qualified Data.ByteString as BS+ --TODO: -- * assign flags to packages individually -- * complain about flags that do not apply to any package given as target@@ -205,11 +209,12 @@ -> InstallFlags -> HaddockFlags -> TestFlags+ -> BenchmarkFlags -> [UserTarget] -> IO () install verbosity packageDBs repos comp platform progdb useSandbox mSandboxPkgInfo- globalFlags configFlags configExFlags installFlags haddockFlags testFlags- userTargets0 = do+ globalFlags configFlags configExFlags installFlags+ haddockFlags testFlags benchmarkFlags userTargets0 = do unless (installRootCmd installFlags == Cabal.NoFlag) $ warn verbosity $ "--root-cmd is no longer supported, "@@ -237,7 +242,7 @@ args :: InstallArgs args = (packageDBs, repos, comp, platform, progdb, useSandbox, mSandboxPkgInfo, globalFlags, configFlags, configExFlags,- installFlags, haddockFlags, testFlags)+ installFlags, haddockFlags, testFlags, benchmarkFlags) die'' message = die' verbosity (message ++ if isUseSandbox useSandbox then installFailedInSandbox else [])@@ -271,14 +276,15 @@ , ConfigExFlags , InstallFlags , HaddockFlags- , TestFlags )+ , TestFlags+ , BenchmarkFlags ) -- | Make an install context given install arguments. makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget] -> IO InstallContext makeInstallContext verbosity (packageDBs, repoCtxt, comp, _, progdb,_,_,- globalFlags, _, configExFlags, installFlags, _, _) mUserTargets = do+ globalFlags, _, configExFlags, installFlags, _, _, _) mUserTargets = do let idxState = flagToMaybe (installIndexState installFlags) @@ -317,7 +323,7 @@ makeInstallPlan verbosity (_, _, comp, platform, _, _, mSandboxPkgInfo, _, configFlags, configExFlags, installFlags,- _, _)+ _, _, _) (installedPkgIndex, sourcePkgDb, pkgConfigDb, _, pkgSpecifiers, _) = do @@ -333,7 +339,7 @@ -> SolverInstallPlan -> IO () processInstallPlan verbosity- args@(_,_, _, _, _, _, _, _, configFlags, _, installFlags, _, _)+ args@(_,_, _, _, _, _, _, _, configFlags, _, installFlags, _, _, _) (installedPkgIndex, sourcePkgDb, _, userTargets, pkgSpecifiers, _) installPlan0 = do @@ -389,6 +395,8 @@ . setCountConflicts countConflicts + . setFineGrainedConflicts fineGrainedConflicts+ . setMinimizeConflictSet minimizeConflictSet . setAvoidReinstalls avoidReinstalls@@ -457,6 +465,7 @@ fromFlag (installReinstall installFlags) reorderGoals = fromFlag (installReorderGoals installFlags) countConflicts = fromFlag (installCountConflicts installFlags)+ fineGrainedConflicts = fromFlag (installFineGrainedConflicts installFlags) minimizeConflictSet = fromFlag (installMinimizeConflictSet installFlags) independentGoals = fromFlag (installIndependentGoals installFlags) avoidReinstalls = fromFlag (installAvoidReinstalls installFlags)@@ -698,11 +707,11 @@ Nothing -> "" where mLatestVersion :: Maybe Version- mLatestVersion = case SourcePackageIndex.lookupPackageName- (packageIndex sourcePkgDb)- (packageName pkg) of- [] -> Nothing- x -> Just $ packageVersion $ last x+ mLatestVersion = fmap packageVersion $+ safeLast $+ SourcePackageIndex.lookupPackageName+ (packageIndex sourcePkgDb)+ (packageName pkg) toFlagAssignment :: [Flag] -> FlagAssignment toFlagAssignment = mkFlagAssignment . map (\ f -> (flagName f, flagDefault f))@@ -754,7 +763,7 @@ -> IO () reportPlanningFailure verbosity (_, _, comp, platform, _, _, _- ,_, configFlags, _, installFlags, _, _)+ ,_, configFlags, _, installFlags, _, _, _) (_, sourcePkgDb, _, _, pkgSpecifiers, _) message = do @@ -834,7 +843,7 @@ -> IO () postInstallActions verbosity (packageDBs, _, comp, platform, progdb, useSandbox, mSandboxPkgInfo- ,globalFlags, configFlags, _, installFlags, _, _)+ ,globalFlags, configFlags, _, installFlags, _, _, _) targets installPlan buildOutcomes = do updateSandboxTimestampsFile verbosity useSandbox mSandboxPkgInfo@@ -1088,7 +1097,8 @@ -> IO BuildOutcomes performInstallations verbosity (packageDBs, repoCtxt, comp, platform, progdb, useSandbox, _,- globalFlags, configFlags, configExFlags, installFlags, haddockFlags, testFlags)+ globalFlags, configFlags, configExFlags, installFlags,+ haddockFlags, testFlags, _) installedPkgIndex installPlan = do -- With 'install -j' it can be a bit hard to tell whether a sandbox is used.@@ -1546,14 +1556,14 @@ readPkgConf :: FilePath -> FilePath -> IO Installed.InstalledPackageInfo- readPkgConf pkgConfDir pkgConfFile =- (withUTF8FileContents (pkgConfDir </> pkgConfFile) $ \pkgConfText ->- case Installed.parseInstalledPackageInfo pkgConfText of- Left perrors -> pkgConfParseFailed $ unlines perrors- Right (warns, pkgConf) -> do- unless (null warns) $- warn verbosity $ unlines warns- return pkgConf)+ readPkgConf pkgConfDir pkgConfFile = do+ pkgConfText <- BS.readFile (pkgConfDir </> pkgConfFile)+ case Installed.parseInstalledPackageInfo pkgConfText of+ Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors+ Right (warns, pkgConf) -> do+ unless (null warns) $+ warn verbosity $ unlines warns+ return pkgConf pkgConfParseFailed :: String -> IO a pkgConfParseFailed perror =
Distribution/Client/InstallPlan.hs view
@@ -67,6 +67,10 @@ reverseDependencyClosure, ) where +import Distribution.Client.Compat.Prelude hiding (toList, lookup, tail)+import Prelude (tail)+import Distribution.Compat.Stack (WithCallStack)+ import Distribution.Client.Types hiding (BuildOutcomes) import qualified Distribution.PackageDescription as PD import qualified Distribution.Simple.Configure as Configure@@ -80,6 +84,7 @@ import Distribution.Solver.Types.SolverPackage import Distribution.Client.JobControl import Distribution.Deprecated.Text+import Distribution.Pretty (prettyShow) import Text.PrettyPrint import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan import Distribution.Client.SolverInstallPlan (SolverInstallPlan)@@ -90,31 +95,19 @@ import Distribution.Solver.Types.InstSolverPackage import Distribution.Utils.LogProgress+import Distribution.Utils.Structured (Structured (..), Structure(Nominal)) -- TODO: Need this when we compute final UnitIds -- import qualified Distribution.Simple.Configure as Configure -import Data.List- ( foldl', intercalate )-import qualified Data.Foldable as Foldable (all)-import Data.Maybe- ( fromMaybe, mapMaybe )+import qualified Data.Foldable as Foldable (all, toList) import qualified Distribution.Compat.Graph as Graph import Distribution.Compat.Graph (Graph, IsNode(..))-import Distribution.Compat.Binary (Binary(..))-import GHC.Generics-import Data.Typeable-import Control.Monad import Control.Exception ( assert ) import qualified Data.Map as Map-import Data.Map (Map) import qualified Data.Set as Set-import Data.Set (Set) -import Prelude hiding (lookup)-- -- When cabal tries to install a number of packages, including all their -- dependencies it has a non-trivial problem to solve. --@@ -174,6 +167,11 @@ | Installed srcpkg deriving (Eq, Show, Generic) +displayGenericPlanPackage :: (IsUnit ipkg, IsUnit srcpkg) => GenericPlanPackage ipkg srcpkg -> String+displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg)+displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg)+displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg)+ -- | Convenience combinator for destructing 'GenericPlanPackage'. -- This is handy because if you case manually, you have to handle -- 'Configured' and 'Installed' separately (where often you want@@ -203,8 +201,8 @@ nodeNeighbors (Configured spkg) = nodeNeighbors spkg nodeNeighbors (Installed spkg) = nodeNeighbors spkg -instance (Binary ipkg, Binary srcpkg)- => Binary (GenericPlanPackage ipkg srcpkg)+instance (Binary ipkg, Binary srcpkg) => Binary (GenericPlanPackage ipkg srcpkg)+instance (Structured ipkg, Structured srcpkg) => Structured (GenericPlanPackage ipkg srcpkg) type PlanPackage = GenericPlanPackage InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)@@ -258,27 +256,34 @@ planIndepGoals = indepGoals } -internalError :: String -> String -> a+internalError :: WithCallStack (String -> String -> a) internalError loc msg = error $ "internal error in InstallPlan." ++ loc ++ if null msg then "" else ": " ++ msg +instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where+ structure p = Nominal (typeRep p) 0 "GenericInstallPlan"+ [ structure (Proxy :: Proxy ipkg)+ , structure (Proxy :: Proxy srcpkg)+ ]+ instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId, Binary ipkg, Binary srcpkg) => Binary (GenericInstallPlan ipkg srcpkg) where put GenericInstallPlan { planGraph = graph, planIndepGoals = indepGoals- } = put (graph, indepGoals)+ } = put graph >> put indepGoals get = do- (graph, indepGoals) <- get+ graph <- get+ indepGoals <- get return $! mkInstallPlan "(instance Binary)" graph indepGoals showPlanGraph :: (Package ipkg, Package srcpkg, IsUnit ipkg, IsUnit srcpkg) => Graph (GenericPlanPackage ipkg srcpkg) -> String showPlanGraph graph = renderStyle defaultStyle $- vcat (map dispPlanPackage (Graph.toList graph))+ vcat (map dispPlanPackage (Foldable.toList graph)) where dispPlanPackage p = hang (hsep [ text (showPlanPackageTag p) , disp (packageId p)@@ -309,7 +314,7 @@ toList :: GenericInstallPlan ipkg srcpkg -> [GenericPlanPackage ipkg srcpkg]-toList = Graph.toList . planGraph+toList = Foldable.toList . planGraph toMap :: GenericInstallPlan ipkg srcpkg -> Map UnitId (GenericPlanPackage ipkg srcpkg)@@ -621,7 +626,7 @@ -- and return any packages that are newly in the processing state (ie ready to -- process), along with the updated 'Processing' state. ---completed :: (IsUnit ipkg, IsUnit srcpkg)+completed :: forall ipkg srcpkg. (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg -> Processing -> UnitId -> ([GenericReadyPackage srcpkg], Processing)@@ -646,8 +651,9 @@ (map nodeKey newlyReady) processing' = Processing processingSet' completedSet' failedSet - asReadyPackage (Configured pkg) = ReadyPackage pkg- asReadyPackage _ = internalError "completed" ""+ asReadyPackage :: GenericPlanPackage ipkg srcpkg -> GenericReadyPackage srcpkg+ asReadyPackage (Configured pkg) = ReadyPackage pkg+ asReadyPackage pkg = internalError "completed" $ "not in configured state: " ++ displayGenericPlanPackage pkg failed :: (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg@@ -673,7 +679,7 @@ processing' = Processing processingSet' completedSet failedSet' asConfiguredPackage (Configured pkg) = pkg- asConfiguredPackage _ = internalError "failed" "not in configured state"+ asConfiguredPackage pkg = internalError "failed" $ "not in configured state: " ++ displayGenericPlanPackage pkg processingInvariant :: (IsUnit ipkg, IsUnit srcpkg) => GenericInstallPlan ipkg srcpkg@@ -929,7 +935,7 @@ --TODO: consider re-enabling this one, see SolverInstallPlan -} ++ [ PackageStateInvalid pkg pkg'- | pkg <- Graph.toList graph+ | pkg <- Foldable.toList graph , Just pkg' <- map (flip Graph.lookup graph) (nodeNeighbors pkg) , not (stateDependencyRelation pkg pkg') ]
Distribution/Client/InstallSymlink.hs view
@@ -22,6 +22,8 @@ import Distribution.Compat.Binary ( Binary )+import Distribution.Utils.Structured+ ( Structured ) import Distribution.Package (PackageIdentifier) import Distribution.Types.UnqualComponentName@@ -37,6 +39,7 @@ deriving (Show, Eq, Generic, Bounded, Enum) instance Binary OverwritePolicy+instance Structured OverwritePolicy symlinkBinaries :: Platform -> Compiler -> OverwritePolicy@@ -48,7 +51,7 @@ symlinkBinaries _ _ _ _ _ _ _ = return [] symlinkBinary :: OverwritePolicy- -> FilePath -> FilePath -> UnqualComponentName -> String+ -> FilePath -> FilePath -> FilePath -> String -> IO Bool symlinkBinary _ _ _ _ _ = fail "Symlinking feature not available on Windows" @@ -56,6 +59,8 @@ import Distribution.Compat.Binary ( Binary )+import Distribution.Utils.Structured+ ( Structured ) import Distribution.Client.Types ( ConfiguredPackage(..), BuildOutcomes )@@ -110,6 +115,7 @@ deriving (Show, Eq, Generic, Bounded, Enum) instance Binary OverwritePolicy+instance Structured OverwritePolicy -- | We would like by default to install binaries into some location that is on -- the user's PATH. For per-user installations on Unix systems that basically@@ -154,7 +160,7 @@ ok <- symlinkBinary overwritePolicy publicBinDir privateBinDir- publicExeName privateExeName+ (display publicExeName) privateExeName if ok then return Nothing else return (Just (pkgid, publicExeName,@@ -220,7 +226,7 @@ -- @/home/user/bin@ -> FilePath -- ^ The canonical path of the private bin dir eg -- @/home/user/.cabal/bin@- -> UnqualComponentName -- ^ The name of the executable to go in the public bin+ -> FilePath -- ^ The name of the executable to go in the public bin -- dir, eg @foo@ -> String -- ^ The name of the executable to in the private bin -- dir, eg @foo-1.0@@@ -229,7 +235,7 @@ -- not own. Other errors like permission errors just -- propagate as exceptions. symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do- ok <- targetOkToOverwrite (publicBindir </> publicName')+ ok <- targetOkToOverwrite (publicBindir </> publicName) (privateBindir </> privateName) case ok of NotExists -> mkLink >> return True@@ -239,11 +245,10 @@ NeverOverwrite -> return False AlwaysOverwrite -> rmLink >> mkLink >> return True where- publicName' = display publicName relativeBindir = makeRelative publicBindir privateBindir mkLink = createSymbolicLink (relativeBindir </> privateName)- (publicBindir </> publicName')- rmLink = removeLink (publicBindir </> publicName')+ (publicBindir </> publicName)+ rmLink = removeLink (publicBindir </> publicName) -- | Check a file path of a symlink that we would like to create to see if it -- is OK. For it to be OK to overwrite it must either not already exist yet or
Distribution/Client/List.hs view
@@ -77,7 +77,10 @@ import System.Directory ( doesDirectoryExist ) +import Distribution.Utils.ShortText (ShortText)+import qualified Distribution.Utils.ShortText as ShortText + -- | Return a list of packages matching given search strings. getPkgList :: Verbosity -> PackageDBStack@@ -277,15 +280,15 @@ installedVersions :: [Version], sourceVersions :: [Version], preferredVersions :: VersionRange,- homepage :: String,- bugReports :: String,- sourceRepo :: String,- synopsis :: String,- description :: String,- category :: String,+ homepage :: ShortText,+ bugReports :: ShortText,+ sourceRepo :: String, -- TODO+ synopsis :: ShortText,+ description :: ShortText,+ category :: ShortText, license :: Either SPDX.License License,- author :: String,- maintainer :: String,+ author :: ShortText,+ maintainer :: ShortText, dependencies :: [ExtDependency], flags :: [Flag], hasLib :: Bool,@@ -307,7 +310,7 @@ char '*' <+> disp (pkgName pkginfo) $+$ (nest 4 $ vcat [- maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs+ maybeShowST (synopsis pkginfo) "Synopsis:" reflowParagraphs , text "Default available version:" <+> case selectedSourcePkg pkginfo of Nothing -> text "[ Not available from any configured repository ]"@@ -318,13 +321,14 @@ | otherwise -> text "[ Unknown ]" versions -> dispTopVersions 4 (preferredVersions pkginfo) versions- , maybeShow (homepage pkginfo) "Homepage:" text+ , maybeShowST (homepage pkginfo) "Homepage:" text , text "License: " <+> either pretty pretty (license pkginfo) ]) $+$ text "" where- maybeShow [] _ _ = empty- maybeShow l s f = text s <+> (f l)+ maybeShowST l s f+ | ShortText.null l = empty+ | otherwise = text s <+> f (ShortText.fromShortText l) showPackageDetailedInfo :: PackageDisplayInfo -> String showPackageDetailedInfo pkginfo =@@ -335,7 +339,7 @@ Disp.<> parens pkgkind $+$ (nest 4 $ vcat [- entry "Synopsis" synopsis hideIfNull reflowParagraphs+ entryST "Synopsis" synopsis hideIfNull reflowParagraphs , entry "Versions available" sourceVersions (altText null "[ Not available from server ]") (dispTopVersions 9 (preferredVersions pkginfo))@@ -343,13 +347,13 @@ (altText null (if hasLib pkginfo then "[ Not installed ]" else "[ Unknown ]")) (dispTopVersions 4 (preferredVersions pkginfo))- , entry "Homepage" homepage orNotSpecified text- , entry "Bug reports" bugReports orNotSpecified text- , entry "Description" description hideIfNull reflowParagraphs- , entry "Category" category hideIfNull text+ , entryST "Homepage" homepage orNotSpecified text+ , entryST "Bug reports" bugReports orNotSpecified text+ , entryST "Description" description hideIfNull reflowParagraphs+ , entryST "Category" category hideIfNull text , entry "License" license alwaysShow (either pretty pretty)- , entry "Author" author hideIfNull reflowLines- , entry "Maintainer" maintainer hideIfNull reflowLines+ , entryST "Author" author hideIfNull reflowLines+ , entryST "Maintainer" maintainer hideIfNull reflowLines , entry "Source repo" sourceRepo orNotSpecified text , entry "Executables" executables hideIfNull (commaSep disp) , entry "Flags" flags hideIfNull (commaSep dispFlag)@@ -369,6 +373,8 @@ label = text fname Disp.<> char ':' Disp.<> padding padding = text (replicate (13 - length fname ) ' ') + entryST fname field = entry fname (ShortText.fromShortText . field)+ normal = Nothing hide = Just Nothing replace msg = Just (Just msg)@@ -446,14 +452,14 @@ Installed.author installed, homepage = combine Source.homepage source Installed.homepage installed,- bugReports = maybe "" Source.bugReports source,- sourceRepo = fromMaybe "" . join+ bugReports = maybe mempty Source.bugReports source,+ sourceRepo = fromMaybe mempty . join . fmap (uncons Nothing Source.repoLocation . sortBy (comparing Source.repoKind) . Source.sourceRepos) $ source, --TODO: installed package info is missing synopsis- synopsis = maybe "" Source.synopsis source,+ synopsis = maybe mempty Source.synopsis source, description = combine Source.description source Installed.description installed, category = combine Source.category source
Distribution/Client/Outdated.hs view
@@ -26,6 +26,7 @@ import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.PackageIndex import Distribution.Client.Sandbox.PackageEnvironment+import Distribution.Utils.Generic import Distribution.Package (PackageName, packageVersion) import Distribution.PackageDescription (allBuildDepends)@@ -204,7 +205,8 @@ relaxMinor :: VersionRange -> VersionRange relaxMinor vr = let vis = asVersionIntervals vr- (LowerBound v0 _,upper) = last vis- in case upper of- NoUpperBound -> vr- UpperBound _v1 _ -> majorBoundVersion v0+ in maybe vr relax (safeLast vis)+ where relax (LowerBound v0 _, upper) =+ case upper of+ NoUpperBound -> vr+ UpperBound _v1 _ -> majorBoundVersion v0
Distribution/Client/PackageHash.hs view
@@ -20,13 +20,6 @@ -- ** Platform-specific variations hashedInstalledPackageIdLong, hashedInstalledPackageIdShort,-- -- * Low level hash choice- HashValue,- hashValue,- showHashValue,- readFileHashValue,- hashFromTUF, ) where import Prelude ()@@ -48,25 +41,17 @@ import Distribution.Deprecated.Text ( display ) import Distribution.Types.PkgconfigVersion (PkgconfigVersion)+import Distribution.Client.HashValue import Distribution.Client.Types ( InstalledPackageId ) import qualified Distribution.Solver.Types.ComponentDeps as CD -import qualified Hackage.Security.Client as Sec--import qualified Crypto.Hash.SHA256 as SHA256-import qualified Data.ByteString.Base16 as Base16-import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Map as Map import qualified Data.Set as Set-import Data.Set (Set) import Data.Function (on)-import Control.Exception (evaluate)-import System.IO (withBinaryFile, IOMode(..)) - ------------------------------- -- Calculating package hashes --@@ -122,15 +107,11 @@ -- max length now 64 [ truncateStr 14 (display name) , truncateStr 8 (display version)- , showHashValue (truncateHash (hashPackageHashInputs pkghashinputs))+ , showHashValue (truncateHash 20 (hashPackageHashInputs pkghashinputs)) ] where PackageIdentifier name version = pkgHashPkgId - -- Truncate a 32 byte SHA256 hash to 160bits, 20 bytes :-(- -- It'll render as 40 hex chars.- truncateHash (HashValue h) = HashValue (BS.take 20 h)- -- Truncate a string, with a visual indication that it is truncated. truncateStr n s | length s <= n = s | otherwise = take (n-1) s ++ "_"@@ -164,11 +145,10 @@ intercalate "-" [ filter (not . flip elem "aeiou") (display name) , display version- , showHashValue (truncateHash (hashPackageHashInputs pkghashinputs))+ , showHashValue (truncateHash 4 (hashPackageHashInputs pkghashinputs)) ] where PackageIdentifier name version = pkgHashPkgId- truncateHash (HashValue h) = HashValue (BS.take 4 h) -- | All the information that contribues to a package's hash, and thus its -- 'InstalledPackageId'.@@ -331,58 +311,3 @@ | otherwise = entry key format value showFlagAssignment = unwords . map showFlagValue . sortBy (compare `on` fst) . unFlagAssignment---------------------------------------------------- The specific choice of hash implementation------- Is a crypto hash necessary here? One thing to consider is who controls the--- inputs and what's the result of a hash collision. Obviously we should not--- install packages we don't trust because they can run all sorts of code, but--- if I've checked there's no TH, no custom Setup etc, is there still a--- problem? If someone provided us a tarball that hashed to the same value as--- some other package and we installed it, we could end up re-using that--- installed package in place of another one we wanted. So yes, in general--- there is some value in preventing intentional hash collisions in installed--- package ids.--newtype HashValue = HashValue BS.ByteString- deriving (Eq, Generic, Show, Typeable)--instance Binary HashValue where- put (HashValue digest) = put digest- get = do- digest <- get- -- Cannot do any sensible validation here. Although we use SHA256- -- for stuff we hash ourselves, we can also get hashes from TUF- -- and that can in principle use different hash functions in future.- return (HashValue digest)---- | Hash some data. Currently uses SHA256.----hashValue :: LBS.ByteString -> HashValue-hashValue = HashValue . SHA256.hashlazy--showHashValue :: HashValue -> String-showHashValue (HashValue digest) = BS.unpack (Base16.encode digest)---- | Hash the content of a file. Uses SHA256.----readFileHashValue :: FilePath -> IO HashValue-readFileHashValue tarball =- withBinaryFile tarball ReadMode $ \hnd ->- evaluate . hashValue =<< LBS.hGetContents hnd---- | Convert a hash from TUF metadata into a 'PackageSourceHash'.------ Note that TUF hashes don't neessarily have to be SHA256, since it can--- support new algorithms in future.----hashFromTUF :: Sec.Hash -> HashValue-hashFromTUF (Sec.Hash hashstr) =- --TODO: [code cleanup] either we should get TUF to use raw bytestrings or- -- perhaps we should also just use a base16 string as the internal rep.- case Base16.decode (BS.pack hashstr) of- (hash, trailing) | not (BS.null hash) && BS.null trailing- -> HashValue hash- _ -> error "hashFromTUF: cannot decode base16 hash"
Distribution/Client/ParseUtils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ExistentialQuantification, NamedFieldPuns #-}+{-# LANGUAGE ExistentialQuantification, NamedFieldPuns, RankNTypes #-} ----------------------------------------------------------------------------- -- |@@ -24,6 +24,9 @@ SectionDescr(..), liftSection, + -- * FieldGrammar sections+ FGSectionDescr(..),+ -- * Parsing and printing flat config parseFields, ppFields,@@ -39,6 +42,9 @@ ) where +import Distribution.Client.Compat.Prelude hiding (empty, get)+import Prelude ()+ import Distribution.Deprecated.ParseUtils ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo , Field(..), liftField, readFieldsFlat )@@ -48,13 +54,23 @@ import Distribution.Simple.Command ( OptionField ) -import Control.Monad ( foldM ) import Text.PrettyPrint ( (<+>), ($+$) ) import qualified Data.Map as Map import qualified Text.PrettyPrint as Disp ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest ) +-- For new parser stuff+import Distribution.CabalSpecVersion (cabalSpecLatest)+import Distribution.FieldGrammar (FieldGrammar, partitionFields, parseFieldGrammar)+import Distribution.Fields.ParseResult (runParseResult)+import Distribution.Parsec.Error (showPError)+import Distribution.Parsec.Position (Position (..))+import Distribution.Parsec.Warning (showPWarning)+import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS)+import qualified Distribution.Fields as F+import qualified Distribution.FieldGrammar as FG + ------------------------- -- FieldDescr utilities --@@ -107,6 +123,15 @@ sectionEmpty :: b } +-- | 'FieldGrammar' section description+data FGSectionDescr a = forall s. FGSectionDescr+ { fgSectionName :: String+ , fgSectionGrammar :: forall g. (FieldGrammar g, Applicative (g s)) => g s s+ -- todo: add subsections?+ , fgSectionGet :: a -> [(String, s)]+ , fgSectionSet :: LineNo -> String -> s -> a -> ParseResult a+ }+ -- | To help construction of config file descriptions in a modular way it is -- useful to define fields and sections on local types and then hoist them -- into the parent types when combining them in bigger descriptions.@@ -191,13 +216,18 @@ -- | Much like 'parseFields' but it also allows subsections. The permitted -- subsections are given by a list of 'SectionDescr's. ---parseFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> a- -> [Field] -> ParseResult a-parseFieldsAndSections fieldDescrs sectionDescrs =+parseFieldsAndSections+ :: [FieldDescr a] -- ^ field+ -> [SectionDescr a] -- ^ legacy sections+ -> [FGSectionDescr a] -- ^ FieldGrammar sections+ -> a+ -> [Field] -> ParseResult a+parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs = foldM setField where- fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]- sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ]+ fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]+ sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ]+ fgSectionMap = Map.fromList [ (fgSectionName s, s) | s <- fgSectionDescrs ] setField a (F line name value) = case Map.lookup name fieldMap of@@ -208,10 +238,25 @@ return a setField a (Section line name param fields) =- case Map.lookup name sectionMap of- Just (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty) -> do- b <- parseFieldsAndSections fieldDescrs' sectionDescrs' sectionEmpty fields+ case Left <$> Map.lookup name sectionMap <|> Right <$> Map.lookup name fgSectionMap of+ Just (Left (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty)) -> do+ b <- parseFieldsAndSections fieldDescrs' sectionDescrs' [] sectionEmpty fields set line param b a+ Just (Right (FGSectionDescr _ grammar _getter setter)) -> do+ let fields1 = mapMaybe convertField fields+ (fields2, sections) = partitionFields fields1+ -- TODO: recurse into sections+ for_ (concat sections) $ \(FG.MkSection (F.Name (Position line' _) name') _ _) ->+ warning $ "Unrecognized section '" ++ fromUTF8BS name'+ ++ "' on line " ++ show line'+ case runParseResult $ parseFieldGrammar cabalSpecLatest fields2 grammar of+ (warnings, Right b) -> do+ for_ warnings $ \w -> warning $ showPWarning "???" w+ setter line param b a+ (warnings, Left (_, errs)) -> do+ for_ warnings $ \w -> warning $ showPWarning "???" w+ case errs of+ err :| _errs -> fail $ showPError "???" err Nothing -> do warning $ "Unrecognized section '" ++ name ++ "' on line " ++ show line@@ -221,17 +266,31 @@ warning $ "Unrecognized stanza on line " ++ show (lineNo block) return accum +convertField :: Field -> Maybe (F.Field Position)+convertField (F line name str) = Just $+ F.Field (F.Name pos (toUTF8BS name)) [ F.FieldLine pos $ toUTF8BS str ]+ where+ pos = Position line 0+-- arguments omitted+convertField (Section line name _arg fields) = Just $+ F.Section (F.Name pos (toUTF8BS name)) [] (mapMaybe convertField fields)+ where+ pos = Position line 0+-- silently omitted.+convertField IfBlock {} = Nothing++ -- | Much like 'ppFields' but also pretty prints any subsections. Subsection -- are only shown if they are non-empty. -- -- Note that unlike 'ppFields', at present it does not support printing -- default values. If needed, adding such support would be quite reasonable. ---ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc-ppFieldsAndSections fieldDescrs sectionDescrs val =+ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> Disp.Doc+ppFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs val = ppFields fieldDescrs Nothing val $+$- Disp.vcat+ Disp.vcat ( [ Disp.text "" $+$ sectionDoc | SectionDescr { sectionName, sectionGet,@@ -240,25 +299,58 @@ , (param, x) <- sectionGet val , let sectionDoc = ppSectionAndSubsections sectionName param- sectionFields sectionSubsections x+ sectionFields sectionSubsections [] x , not (Disp.isEmpty sectionDoc)- ]+ ] +++ [ Disp.text "" $+$ sectionDoc+ | FGSectionDescr { fgSectionName, fgSectionGrammar, fgSectionGet } <- fgSectionDescrs+ , (param, x) <- fgSectionGet val+ , let sectionDoc = ppFgSection fgSectionName param fgSectionGrammar x+ , not (Disp.isEmpty sectionDoc)+ ]) -- | Unlike 'ppSection' which has to be called directly, this gets used via -- 'ppFieldsAndSections' and so does not need to be exported. -- ppSectionAndSubsections :: String -> String- -> [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc-ppSectionAndSubsections name arg fields sections cur+ -> [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> Disp.Doc+ppSectionAndSubsections name arg fields sections fgSections cur | Disp.isEmpty fieldsDoc = Disp.empty | otherwise = Disp.text name <+> argDoc $+$ (Disp.nest 2 fieldsDoc) where- fieldsDoc = showConfig fields sections cur+ fieldsDoc = showConfig fields sections fgSections cur argDoc | arg == "" = Disp.empty | otherwise = Disp.text arg +-- |+--+-- TODO: subsections+-- TODO: this should simply build 'PrettyField'+ppFgSection+ :: String -- ^ section name+ -> String -- ^ parameter+ -> FG.PrettyFieldGrammar a a+ -> a+ -> Disp.Doc+ppFgSection secName arg grammar x+ | null prettyFields = Disp.empty+ | otherwise =+ Disp.text secName <+> argDoc+ $+$ (Disp.nest 2 fieldsDoc)+ where+ prettyFields = FG.prettyFieldGrammar cabalSpecLatest grammar x + argDoc | arg == "" = Disp.empty+ | otherwise = Disp.text arg++ fieldsDoc = Disp.vcat+ [ Disp.text fname' <<>> Disp.colon <<>> doc+ | F.PrettyField _ fname doc <- prettyFields -- TODO: this skips sections+ , let fname' = fromUTF8BS fname+ ]++ ----------------------------------------------- -- Top level config file parsing and printing --@@ -268,15 +360,15 @@ -- -- It accumulates the result on top of a given initial (typically empty) value. ---parseConfig :: [FieldDescr a] -> [SectionDescr a] -> a+parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> String -> ParseResult a-parseConfig fieldDescrs sectionDescrs empty str =- parseFieldsAndSections fieldDescrs sectionDescrs empty+parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str =+ parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty =<< readFieldsFlat str -- | Render a value in the config file syntax, based on a description of the -- configuration file in terms of its fields and sections. ---showConfig :: [FieldDescr a] -> [SectionDescr a] -> a -> Disp.Doc+showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr a] -> a -> Disp.Doc showConfig = ppFieldsAndSections
Distribution/Client/ProjectBuilding.hs view
@@ -38,9 +38,8 @@ BuildFailureReason(..), ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif+import Distribution.Client.Compat.Prelude+import Prelude () import Distribution.Client.PackageHash (renderPackageHashInputs) import Distribution.Client.RebuildMonad@@ -95,28 +94,20 @@ import Distribution.Pretty import Distribution.Compat.Graph (IsNode(..)) -import Data.Map (Map)+import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map-import Data.Set (Set) import qualified Data.Set as Set+import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS-import Data.List (isPrefixOf) -import Control.Monad-import Control.Exception-import Data.Function (on)-import Data.Maybe+import Control.Exception (Exception (..), Handler (..), SomeAsyncException, SomeException, assert, catches, handle, throwIO)+import Data.Function (on)+import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory)+import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>))+import System.IO (IOMode (AppendMode), withFile) -import System.FilePath-import System.IO-import System.Directory+import Distribution.Compat.Directory (listDirectory) -#if !MIN_VERSION_directory(1,2,5)-listDirectory :: FilePath -> IO [FilePath]-listDirectory path =- (filter f) <$> (getDirectoryContents path)- where f filename = filename /= "." && filename /= ".."-#endif ------------------------------------------------------------------------------ -- * Overall building strategy.@@ -272,7 +263,7 @@ -- -- The packages are visited in dependency order, starting with packages with no -- dependencies. The result for each package is accumulated into a 'Map' and--- returned as the final result. In addition, when visting a package, the+-- returned as the final result. In addition, when visiting a package, the -- visiting function is passed the results for all the immediate package -- dependencies. This can be used to propagate information from dependencies. --@@ -295,7 +286,7 @@ -- we go in the right order so the results map has entries for all deps let depresults :: [b] depresults =- map (\ipkgid -> let Just result = Map.lookup ipkgid results+ map (\ipkgid -> let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results in result) (InstallPlan.depends pkg) result <- visit pkg depresults@@ -590,7 +581,7 @@ createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory createDirectoryIfMissingVerbose verbosity True distTempDirectory- mapM_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse+ traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse -- Before traversing the install plan, pre-emptively find all packages that -- will need to be downloaded and start downloading them.@@ -605,7 +596,7 @@ handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ let uid = installedUnitId pkg- Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus in+ pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in rebuildTarget verbosity@@ -765,7 +756,7 @@ | InstallPlan.Configured elab <- InstallPlan.reverseTopologicalOrder installPlan , let uid = installedUnitId elab- Just pkgBuildStatus = Map.lookup uid pkgsBuildStatus+ pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus , BuildStatusDownload <- [pkgBuildStatus] ] @@ -983,6 +974,12 @@ let prefix = normalise $ dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) entryDir = tmpDirNormalised </> prefix++ -- if there weren't anything to build, it might be that directory is not created+ -- the @setup Cabal.copyCommand@ above might do nothing.+ -- https://github.com/haskell/cabal/issues/4130+ createDirectoryIfMissingVerbose verbosity True entryDir+ LBS.writeFile (entryDir </> "cabal-hash.txt") (renderPackageHashInputs (packageHashInputs pkgshared pkg))@@ -1007,7 +1004,7 @@ listFilesRecursive :: FilePath -> IO [FilePath] listFilesRecursive path = do files <- fmap (path </>) <$> (listDirectory path)- allFiles <- forM files $ \file -> do+ allFiles <- for files $ \file -> do isDir <- doesDirectoryExist file if isDir then listFilesRecursive file@@ -1441,11 +1438,10 @@ ++ show perror readPkgConf pkgConfDir pkgConfFile = do- (warns, ipkg) <-- withUTF8FileContents (pkgConfDir </> pkgConfFile) $ \pkgConfStr ->- case Installed.parseInstalledPackageInfo pkgConfStr of- Left perrors -> pkgConfParseFailed $ unlines perrors- Right (warns, ipkg) -> return (warns, ipkg)+ pkgConfStr <- BS.readFile (pkgConfDir </> pkgConfFile)+ (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of+ Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors+ Right (warns, ipkg) -> return (warns, ipkg) unless (null warns) $ warn verbosity $ unlines warns
Distribution/Client/ProjectConfig.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-}@@ -28,6 +29,7 @@ readGlobalConfig, readProjectLocalFreezeConfig, withProjectOrGlobalConfig,+ withProjectOrGlobalConfigIgn, writeProjectLocalExtraConfig, writeProjectLocalFreezeConfig, writeProjectConfigFile,@@ -98,9 +100,11 @@ ( parseGenericPackageDescription ) import Distribution.Fields ( runParseResult, PError, PWarning, showPWarning)-import Distribution.Pretty ()+import Distribution.Pretty (prettyShow) import Distribution.Types.SourceRepo- ( SourceRepo(..), RepoType(..), )+ ( RepoType(..) )+import Distribution.Client.SourceRepo+ ( SourceRepoList, SourceRepositoryPackage (..), srpFanOut ) import Distribution.Simple.Compiler ( Compiler, compilerInfo ) import Distribution.Simple.Program@@ -139,7 +143,7 @@ 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.List.NonEmpty as NE import qualified Data.Set as Set import qualified Data.Hashable as Hashable import Numeric (showHex)@@ -183,6 +187,7 @@ verbosity buildSettingRemoteRepos buildSettingLocalRepos+ buildSettingLocalNoIndexRepos buildSettingCacheDir buildSettingHttpTransport (Just buildSettingIgnoreExpiry)@@ -205,6 +210,7 @@ verbosity (fromNubList projectConfigRemoteRepos) (fromNubList projectConfigLocalRepos)+ (fromNubList projectConfigLocalNoIndexRepos) (fromFlagOrDefault (error "projectConfigWithSolverRepoContext: projectConfigCacheDir")@@ -229,6 +235,7 @@ -- the flag assignments need checking. solverSettingRemoteRepos = fromNubList projectConfigRemoteRepos solverSettingLocalRepos = fromNubList projectConfigLocalRepos+ solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos solverSettingConstraints = projectConfigConstraints solverSettingPreferences = projectConfigPreferences solverSettingFlagAssignment = packageConfigFlagAssignment projectConfigLocalPackages@@ -243,6 +250,7 @@ | otherwise -> Just n solverSettingReorderGoals = fromFlag projectConfigReorderGoals solverSettingCountConflicts = fromFlag projectConfigCountConflicts+ solverSettingFineGrainedConflicts = fromFlag projectConfigFineGrainedConflicts solverSettingMinimizeConflictSet = fromFlag projectConfigMinimizeConflictSet solverSettingStrongFlags = fromFlag projectConfigStrongFlags solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls@@ -264,6 +272,7 @@ projectConfigMaxBackjumps = Flag defaultMaxBackjumps, projectConfigReorderGoals = Flag (ReorderGoals False), projectConfigCountConflicts = Flag (CountConflicts True),+ projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts True), projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False), projectConfigStrongFlags = Flag (StrongFlags False), projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False),@@ -292,6 +301,7 @@ projectConfigShared = ProjectConfigShared { projectConfigRemoteRepos, projectConfigLocalRepos,+ projectConfigLocalNoIndexRepos, projectConfigProgPathExtra }, projectConfigBuildOnly@@ -312,6 +322,7 @@ buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles buildSettingRemoteRepos = fromNubList projectConfigRemoteRepos buildSettingLocalRepos = fromNubList projectConfigLocalRepos+ buildSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos buildSettingCacheDir = fromFlag projectConfigCacheDir buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry@@ -451,6 +462,24 @@ renderBadProjectRoot (BadProjectRootExplicitFile projectFile) = "The given project file '" ++ projectFile ++ "' does not exist." +-- | Like 'withProjectOrGlobalConfig', with an additional boolean+-- which tells to ignore local project.+--+-- Used to implement -z / --ignore-project behaviour+--+withProjectOrGlobalConfigIgn+ :: Bool -- ^ whether to ignore local project+ -> Verbosity+ -> Flag FilePath+ -> IO a+ -> (ProjectConfig -> IO a)+ -> IO a+withProjectOrGlobalConfigIgn True verbosity gcf _with without = do+ globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf+ without globalConfig+withProjectOrGlobalConfigIgn False verbosity gcf with without =+ withProjectOrGlobalConfig verbosity gcf with without+ withProjectOrGlobalConfig :: Verbosity -> Flag FilePath -> IO a@@ -647,7 +676,7 @@ | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file | ProjectPackageLocalTarball FilePath | ProjectPackageRemoteTarball URI- | ProjectPackageRemoteRepo SourceRepo+ | ProjectPackageRemoteRepo SourceRepoList | ProjectPackageNamed PackageVersionConstraint deriving Show @@ -1055,7 +1084,6 @@ . 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.@@ -1108,7 +1136,7 @@ :: Verbosity -> DistDirLayout -> ProjectConfigShared- -> [SourceRepo]+ -> [SourceRepoList] -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] syncAndReadSourcePackagesRemoteRepos verbosity DistDirLayout{distDownloadSrcDirectory}@@ -1123,7 +1151,7 @@ -- 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)]+ [(SourceRepoList, RepoType)] reposByLocation = Map.fromListWith (++) [ ((rtype, rloc), [(repo, vcsRepoType vcs)]) | (repo, rloc, rtype, vcs) <- repos' ]@@ -1131,7 +1159,7 @@ --TODO: pass progPathExtra on to 'configureVCS' let _progPathExtra = fromNubList projectConfigProgPathExtra getConfiguredVCS <- delayInitSharedResources $ \repoType ->- let Just vcs = Map.lookup repoType knownVCSs in+ let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs in configureVCS verbosity {-progPathExtra-} vcs concat <$> sequence@@ -1143,7 +1171,7 @@ pathStem = distDownloadSrcDirectory </> localFileNameForRemoteRepo primaryRepo monitor :: FileMonitor- [SourceRepo]+ [SourceRepoList] [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] monitor = newFileMonitor (pathStem <.> "cache") ]@@ -1151,7 +1179,7 @@ syncRepoGroupAndReadSourcePackages :: VCS ConfiguredProgram -> FilePath- -> [SourceRepo]+ -> [SourceRepoList] -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)] syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do liftIO $ createDirectoryIfMissingVerbose verbosity False@@ -1168,29 +1196,38 @@ sequence [ readPackageFromSourceRepo repoWithSubdir repoPath | (_, reposWithSubdir, repoPath) <- repoGroupWithPaths- , repoWithSubdir <- reposWithSubdir ]+ , repoWithSubdir <- NE.toList reposWithSubdir ] where -- So to do both things above, we pair them up here.+ repoGroupWithPaths+ :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)] repoGroupWithPaths = zipWith (\(x, y) z -> (x,y,z))- (Map.toList- (Map.fromListWith (++)- [ (repo { repoSubdir = Nothing }, [repo])- | repo <- repoGroup ]))+ (mapGroup+ [ (repo { srpSubdir = Proxy }, repo)+ | repo <- foldMap (NE.toList . srpFanOut) repoGroup+ ]) repoPaths + mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)]+ mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v))+ -- The repos in a group are given distinct names by simple enumeration -- foo, foo-2, foo-3 etc+ repoPaths :: [FilePath] repoPaths = pathStem : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ] + readPackageFromSourceRepo+ :: SourceRepositoryPackage Maybe -> FilePath+ -> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc)) readPackageFromSourceRepo repo repoPath = do- let packageDir = maybe repoPath (repoPath </>) (repoSubdir repo)+ let packageDir = maybe repoPath (repoPath </>) (srpSubdir repo) entries <- liftIO $ getDirectoryContents packageDir --TODO: wrap exceptions case filter (\e -> takeExtension e == ".cabal") entries of- [] -> liftIO $ throwIO NoCabalFileFound- (_:_:_) -> liftIO $ throwIO MultipleCabalFilesFound+ [] -> liftIO $ throwIO $ NoCabalFileFound packageDir+ (_:_:_) -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir [cabalFileName] -> do monitorFiles [monitorFileHashed cabalFilePath] liftIO $ fmap (mkSpecificSourcePackage location)@@ -1201,10 +1238,10 @@ location = RemoteSourceRepoPackage repo packageDir - reportSourceRepoProblems :: [(SourceRepo, SourceRepoProblem)] -> Rebuild a+ reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems - renderSourceRepoProblems :: [(SourceRepo, SourceRepoProblem)] -> String+ renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems" @@ -1229,11 +1266,11 @@ -- | Errors reported upon failing to parse a @.cabal@ file. -- data CabalFileParseError = CabalFileParseError- FilePath -- ^ @.cabal@ file path- BS.ByteString -- ^ @.cabal@ file contents- [PError] -- ^ errors- (Maybe Version) -- ^ We might discover the spec version the package needs- [PWarning] -- ^ warnings+ FilePath -- ^ @.cabal@ file path+ BS.ByteString -- ^ @.cabal@ file contents+ (NonEmpty PError) -- ^ errors+ (Maybe Version) -- ^ We might discover the spec version the package needs+ [PWarning] -- ^ warnings deriving (Typeable) -- | Manual instance which skips file contentes@@ -1282,9 +1319,9 @@ -- | When looking for a package's @.cabal@ file we can find none, or several, -- both of which are failures. ---data CabalFileSearchFailure =- NoCabalFileFound- | MultipleCabalFilesFound+data CabalFileSearchFailure+ = NoCabalFileFound FilePath+ | MultipleCabalFilesFound FilePath deriving (Show, Typeable) instance Exception CabalFileSearchFailure@@ -1298,7 +1335,7 @@ extractTarballPackageCabalFile tarballFile = withBinaryFile tarballFile ReadMode $ \hnd -> do content <- LBS.hGetContents hnd- case extractTarballPackageCabalFilePure content of+ case extractTarballPackageCabalFilePure tarballFile content of Left (Left e) -> throwIO e Left (Right e) -> throwIO e Right (fileName, fileContent) ->@@ -1307,11 +1344,12 @@ -- | Scan through a tar file stream and collect the @.cabal@ file, or fail. ---extractTarballPackageCabalFilePure :: LBS.ByteString+extractTarballPackageCabalFilePure :: FilePath+ -> LBS.ByteString -> Either (Either Tar.FormatError CabalFileSearchFailure) (FilePath, LBS.ByteString)-extractTarballPackageCabalFilePure =+extractTarballPackageCabalFilePure tarballFile = check . accumEntryMap . Tar.filterEntries isCabalFile@@ -1324,11 +1362,11 @@ check (Left (e, _m)) = Left (Left e) check (Right m) = case Map.elems m of- [] -> Left (Right NoCabalFileFound)+ [] -> Left (Right $ NoCabalFileFound tarballFile) [file] -> case Tar.entryContent file of Tar.NormalFile content _ -> Right (Tar.entryPath file, content)- _ -> Left (Right NoCabalFileFound)- _files -> Left (Right MultipleCabalFilesFound)+ _ -> Left (Right $ NoCabalFileFound tarballFile)+ _files -> Left (Right $ MultipleCabalFilesFound tarballFile) isCabalFile e = case splitPath (Tar.entryPath e) of [ _dir, file] -> takeExtension file == ".cabal"@@ -1356,10 +1394,9 @@ -- 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 ""+localFileNameForRemoteRepo :: SourceRepoList -> FilePath+localFileNameForRemoteRepo SourceRepositoryPackage {srpType, srpLocation} =+ mangleName srpLocation ++ "-" ++ showHex locationHash "" where mangleName = truncateString 10 . dropExtension . takeFileName . dropTrailingPathSeparator@@ -1367,7 +1404,7 @@ -- just the parts that make up the "identity" of the repo locationHash :: Word locationHash =- fromIntegral (Hashable.hash (show repoType, repoLocation, repoModule))+ fromIntegral (Hashable.hash (show srpType, srpLocation)) -- | Truncate a string, with a visual indication that it is truncated.
Distribution/Client/ProjectConfig/Legacy.hs view
@@ -27,11 +27,12 @@ import Distribution.Client.ProjectConfig.Types import Distribution.Client.Types- ( RemoteRepo(..), emptyRemoteRepo+ ( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo , AllowNewer(..), AllowOlder(..) )+import Distribution.Client.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList) import Distribution.Client.Config- ( SavedConfig(..), remoteRepoFields )+ ( SavedConfig(..), remoteRepoFields, postProcessRepo ) import Distribution.Client.CmdInstall.ClientInstallFlags ( ClientInstallFlags(..), defaultClientInstallFlags@@ -41,10 +42,7 @@ import Distribution.Package import Distribution.PackageDescription- ( SourceRepo(..), RepoKind(..)- , dispFlagAssignment )-import Distribution.Client.SourceRepoParse- ( sourceRepoFieldDescrs )+ ( dispFlagAssignment ) import Distribution.Simple.Compiler ( OptimisationLevel(..), DebugInfoLevel(..) ) import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) )@@ -53,6 +51,7 @@ , ConfigFlags(..), configureOptions , HaddockFlags(..), haddockOptions, defaultHaddockFlags , TestFlags(..), testOptions', defaultTestFlags+ , BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags , programDbPaths', splitArgs ) import Distribution.Client.Setup@@ -79,7 +78,7 @@ ( Doc, ($+$) ) import qualified Distribution.Deprecated.ParseUtils as ParseUtils (field) import Distribution.Deprecated.ParseUtils- ( ParseResult(..), PError(..), syntaxError, PWarning(..), warning+ ( ParseResult(..), PError(..), syntaxError, PWarning(..) , simpleField, commaNewLineListField, newLineListField, parseTokenQ , parseHaskellString, showToken ) import Distribution.Client.ParseUtils@@ -90,6 +89,9 @@ ( PackageVersionConstraint ) import qualified Data.Map as Map++import Network.URI (URI (..))+ ------------------------------------------------------------------ -- Representing the project config file in terms of legacy types --@@ -106,7 +108,7 @@ data LegacyProjectConfig = LegacyProjectConfig { legacyPackages :: [String], legacyPackagesOptional :: [String],- legacyPackagesRepo :: [SourceRepo],+ legacyPackagesRepo :: [SourceRepoList], legacyPackagesNamed :: [PackageVersionConstraint], legacySharedConfig :: LegacySharedConfig,@@ -126,7 +128,8 @@ legacyConfigureFlags :: ConfigFlags, legacyInstallPkgFlags :: InstallFlags, legacyHaddockFlags :: HaddockFlags,- legacyTestFlags :: TestFlags+ legacyTestFlags :: TestFlags,+ legacyBenchmarkFlags :: BenchmarkFlags } deriving Generic instance Monoid LegacyPackageConfig where@@ -168,15 +171,16 @@ -> InstallFlags -> ClientInstallFlags -> HaddockFlags -> TestFlags+ -> BenchmarkFlags -> ProjectConfig commandLineFlagsToProjectConfig globalFlags configFlags configExFlags installFlags clientInstallFlags- haddockFlags testFlags =+ haddockFlags testFlags benchmarkFlags = mempty { projectConfigBuildOnly = convertLegacyBuildOnlyFlags globalFlags configFlags installFlags clientInstallFlags- haddockFlags testFlags,+ haddockFlags testFlags benchmarkFlags, projectConfigShared = convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags,@@ -185,7 +189,8 @@ } where (localConfig, allConfig) = splitConfig (convertLegacyPerPackageFlags- configFlags installFlags haddockFlags testFlags)+ configFlags installFlags+ haddockFlags testFlags benchmarkFlags) -- split the package config (from command line arguments) into -- those applied to all packages and those to local only. --@@ -231,7 +236,8 @@ savedUploadFlags = _, savedReportFlags = _, savedHaddockFlags = haddockFlags,- savedTestFlags = testFlags+ savedTestFlags = testFlags,+ savedBenchmarkFlags = benchmarkFlags } = mempty { projectConfigBuildOnly = configBuildOnly,@@ -241,21 +247,23 @@ where --TODO: [code cleanup] eliminate use of default*Flags here and specify the -- defaults in the various resolve functions in terms of the new types.- configExFlags' = defaultConfigExFlags <> configExFlags- installFlags' = defaultInstallFlags <> installFlags- clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags- haddockFlags' = defaultHaddockFlags <> haddockFlags- testFlags' = defaultTestFlags <> testFlags+ configExFlags' = defaultConfigExFlags <> configExFlags+ installFlags' = defaultInstallFlags <> installFlags+ clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags+ haddockFlags' = defaultHaddockFlags <> haddockFlags+ testFlags' = defaultTestFlags <> testFlags+ benchmarkFlags' = defaultBenchmarkFlags <> benchmarkFlags configAllPackages = convertLegacyPerPackageFlags- configFlags installFlags' haddockFlags' testFlags'+ configFlags installFlags'+ haddockFlags' testFlags' benchmarkFlags' configShared = convertLegacyAllPackageFlags globalFlags configFlags configExFlags' installFlags' configBuildOnly = convertLegacyBuildOnlyFlags globalFlags configFlags installFlags' clientInstallFlags'- haddockFlags' testFlags'+ haddockFlags' testFlags' benchmarkFlags' -- | Convert the project config from the legacy types to the 'ProjectConfig'@@ -274,7 +282,7 @@ clientInstallFlags, legacyAllConfig, legacyLocalConfig = LegacyPackageConfig configFlags installPerPkgFlags- haddockFlags testFlags,+ haddockFlags testFlags benchmarkFlags, legacySpecificConfig } = @@ -292,23 +300,25 @@ projectConfigSpecificPackage = fmap perPackage legacySpecificConfig } where- configAllPackages = convertLegacyPerPackageFlags g i h t- where LegacyPackageConfig g i h t = legacyAllConfig+ configAllPackages = convertLegacyPerPackageFlags g i h t b+ where LegacyPackageConfig g i h t b = legacyAllConfig configLocalPackages = convertLegacyPerPackageFlags configFlags installPerPkgFlags haddockFlags- testFlags+ testFlags benchmarkFlags configPackagesShared= convertLegacyAllPackageFlags globalFlags (configFlags <> configShFlags) configExFlags installSharedFlags configBuildOnly = convertLegacyBuildOnlyFlags globalFlags configShFlags installSharedFlags clientInstallFlags- haddockFlags testFlags+ haddockFlags testFlags benchmarkFlags perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags- perPkgHaddockFlags perPkgTestFlags) =+ perPkgHaddockFlags perPkgTestFlags+ perPkgBenchmarkFlags) = convertLegacyPerPackageFlags- perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags perPkgTestFlags+ perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags+ perPkgTestFlags perPkgBenchmarkFlags -- | Helper used by other conversion functions that returns the@@ -326,6 +336,7 @@ globalSandboxConfigFile = _, -- ?? globalRemoteRepos = projectConfigRemoteRepos, globalLocalRepos = projectConfigLocalRepos,+ globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, globalProgPathExtra = projectConfigProgPathExtra, globalStoreDir = projectConfigStoreDir } = globalFlags@@ -363,6 +374,7 @@ --installUpgradeDeps = projectConfigUpgradeDeps, installReorderGoals = projectConfigReorderGoals, installCountConflicts = projectConfigCountConflicts,+ installFineGrainedConflicts = projectConfigFineGrainedConflicts, installMinimizeConflictSet = projectConfigMinimizeConflictSet, installPerComponent = projectConfigPerComponent, installIndependentGoals = projectConfigIndependentGoals,@@ -378,8 +390,9 @@ -- 'PackageConfig' subset of the 'ProjectConfig'. -- convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags- -> TestFlags -> PackageConfig-convertLegacyPerPackageFlags configFlags installFlags haddockFlags testFlags =+ -> TestFlags -> BenchmarkFlags -> PackageConfig+convertLegacyPerPackageFlags configFlags installFlags+ haddockFlags testFlags benchmarkFlags = PackageConfig{..} where ConfigFlags {@@ -454,6 +467,9 @@ testOptions = packageConfigTestTestOptions } = testFlags + BenchmarkFlags {+ benchmarkOptions = packageConfigBenchmarkOptions+ } = benchmarkFlags -- | Helper used by other conversion functions that returns the@@ -462,10 +478,11 @@ convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags -> InstallFlags -> ClientInstallFlags -> HaddockFlags -> TestFlags+ -> BenchmarkFlags -> ProjectConfigBuildOnly convertLegacyBuildOnlyFlags globalFlags configFlags installFlags clientInstallFlags- haddockFlags _ =+ haddockFlags _ _ = ProjectConfigBuildOnly{..} where projectConfigClientInstallFlags = clientInstallFlags@@ -555,6 +572,7 @@ globalRemoteRepos = projectConfigRemoteRepos, globalCacheDir = projectConfigCacheDir, globalLocalRepos = projectConfigLocalRepos,+ globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos, globalLogsDir = projectConfigLogsDir, globalWorldFile = mempty, globalRequireSandbox = mempty,@@ -594,6 +612,7 @@ installUpgradeDeps = mempty, --projectConfigUpgradeDeps, installReorderGoals = projectConfigReorderGoals, installCountConflicts = projectConfigCountConflicts,+ installFineGrainedConflicts = projectConfigFineGrainedConflicts, installMinimizeConflictSet = projectConfigMinimizeConflictSet, installIndependentGoals = projectConfigIndependentGoals, installShadowPkgs = mempty, --projectConfigShadowPkgs,@@ -630,7 +649,8 @@ legacyConfigureFlags = configFlags, legacyInstallPkgFlags= mempty, legacyHaddockFlags = haddockFlags,- legacyTestFlags = mempty+ legacyTestFlags = mempty,+ legacyBenchmarkFlags = mempty } where configFlags = ConfigFlags {@@ -701,7 +721,8 @@ legacyConfigureFlags = configFlags, legacyInstallPkgFlags = installFlags, legacyHaddockFlags = haddockFlags,- legacyTestFlags = testFlags+ legacyTestFlags = testFlags,+ legacyBenchmarkFlags = benchmarkFlags } where configFlags = ConfigFlags {@@ -802,6 +823,11 @@ testOptions = packageConfigTestTestOptions } + benchmarkFlags = BenchmarkFlags {+ benchmarkDistPref = mempty,+ benchmarkVerbosity = mempty,+ benchmarkOptions = packageConfigBenchmarkOptions+ } ------------------------------------------------ -- Parsing and showing the project config file@@ -811,6 +837,7 @@ parseLegacyProjectConfig = parseConfig legacyProjectConfigFieldDescrs legacyPackageConfigSectionDescrs+ legacyPackageConfigFGSectionDescrs mempty showLegacyProjectConfig :: LegacyProjectConfig -> String@@ -818,6 +845,7 @@ Disp.render $ showConfig legacyProjectConfigFieldDescrs legacyPackageConfigSectionDescrs+ legacyPackageConfigFGSectionDescrs config $+$ Disp.text ""@@ -978,8 +1006,9 @@ , "one-shot", "jobs", "keep-going", "offline", "per-component" -- solver flags: , "max-backjumps", "reorder-goals", "count-conflicts"- , "minimize-conflict-set", "independent-goals"- , "strong-flags" , "allow-boot-library-installs", "reject-unconstrained-dependencies", "index-state"+ , "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals"+ , "strong-flags" , "allow-boot-library-installs"+ , "reject-unconstrained-dependencies", "index-state" ] . commandOptionsToFields ) (installOptions ParseArgs)@@ -1097,6 +1126,20 @@ , "fail-when-no-test-suites", "test-wrapper" ] . commandOptionsToFields ) (testOptions' ParseArgs)+ +++ ( liftFields+ legacyBenchmarkFlags+ (\flags conf -> conf { legacyBenchmarkFlags = flags })+ . addFields+ [ newLineListField "benchmark-options"+ (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)+ benchmarkOptions+ (\v conf -> conf { benchmarkOptions = v })+ ]+ . filterFields+ []+ . commandOptionsToFields+ ) (benchmarkOptions' ParseArgs) where@@ -1165,10 +1208,14 @@ | otherwise = "test-" ++ name +legacyPackageConfigFGSectionDescrs :: [FGSectionDescr LegacyProjectConfig]+legacyPackageConfigFGSectionDescrs =+ [ packageRepoSectionDescr+ ]+ legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig] legacyPackageConfigSectionDescrs =- [ packageRepoSectionDescr- , packageSpecificOptionsSectionDescr+ [ packageSpecificOptionsSectionDescr , liftSection legacyLocalConfig (\flags conf -> conf { legacyLocalConfig = flags })@@ -1186,31 +1233,19 @@ remoteRepoSectionDescr ] -packageRepoSectionDescr :: SectionDescr LegacyProjectConfig-packageRepoSectionDescr =- SectionDescr {- sectionName = "source-repository-package",- sectionFields = sourceRepoFieldDescrs,- sectionSubsections = [],- sectionGet = map (\x->("", x))- . legacyPackagesRepo,- sectionSet =+packageRepoSectionDescr :: FGSectionDescr LegacyProjectConfig+packageRepoSectionDescr = FGSectionDescr+ { fgSectionName = "source-repository-package"+ , fgSectionGrammar = sourceRepositoryPackageGrammar+ , fgSectionGet = map (\x->("", x)) . legacyPackagesRepo+ , fgSectionSet = \lineno unused pkgrepo projconf -> do unless (null unused) $ syntaxError lineno "the section 'source-repository-package' takes no arguments" return projconf { legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo]- },- sectionEmpty = SourceRepo {- repoKind = RepoThis, -- hopefully unused- repoType = Nothing,- repoLocation = Nothing,- repoModule = Nothing,- repoBranch = Nothing,- repoTag = Nothing,- repoSubdir = Nothing- }- }+ }+ } -- | The definitions of all the fields that can appear in the @package pkgfoo@ -- and @package *@ sections of the @cabal.project@-format files.@@ -1357,43 +1392,46 @@ | otherwise = arg +-- The implementation is slight hack: we parse all as remote repository+-- but if the url schema is file+noindex, we switch to local. remoteRepoSectionDescr :: SectionDescr GlobalFlags-remoteRepoSectionDescr =- SectionDescr {- sectionName = "repository",- sectionFields = remoteRepoFields,- sectionSubsections = [],- sectionGet = map (\x->(remoteRepoName x, x)) . fromNubList- . globalRemoteRepos,- sectionSet =- \lineno reponame repo0 conf -> do- when (null reponame) $- syntaxError lineno $ "a 'repository' section requires the "- ++ "repository name as an argument"- let repo = repo0 { remoteRepoName = reponame }- when (remoteRepoKeyThreshold repo- > length (remoteRepoRootKeys repo)) $- warning $ "'key-threshold' for repository "- ++ show (remoteRepoName repo)- ++ " higher than number of keys"- when (not (null (remoteRepoRootKeys repo))- && remoteRepoSecure repo /= Just True) $- warning $ "'root-keys' for repository "- ++ show (remoteRepoName repo)- ++ " non-empty, but 'secure' not set to True."- return conf {- globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf)- },- sectionEmpty = emptyRemoteRepo ""+remoteRepoSectionDescr = SectionDescr+ { sectionName = "repository"+ , sectionEmpty = emptyRemoteRepo ""+ , sectionFields = remoteRepoFields+ , sectionSubsections = []+ , sectionGet = getS+ , sectionSet = setS }+ where+ getS :: GlobalFlags -> [(String, RemoteRepo)]+ getS gf =+ map (\x->(remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf))+ +++ map (\x->(localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf)) + setS :: Int -> String -> RemoteRepo -> GlobalFlags -> ParseResult GlobalFlags+ setS lineno reponame repo0 conf = do+ repo1 <- postProcessRepo lineno reponame repo0+ case repo1 of+ Left repo -> return conf+ { globalLocalNoIndexRepos = overNubList (++[repo]) (globalLocalNoIndexRepos conf)+ }+ Right repo -> return conf+ { globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf)+ } + localToRemote :: LocalRepo -> RemoteRepo+ localToRemote (LocalRepo name path sharedCache) = (emptyRemoteRepo name)+ { remoteRepoURI = URI "file+noindex:" Nothing path "" (if sharedCache then "#shared-cache" else "")+ }+ ------------------------------- -- Local field utils -- -- | Parser combinator for simple fields which uses the field type's--- 'Monoid' instance for combining multiple occurences of the field.+-- 'Monoid' instance for combining multiple occurrences of the field. monoidField :: Monoid a => String -> (a -> Doc) -> ReadP a a -> (b -> a) -> (a -> b -> b) -> FieldDescr b monoidField name showF readF get' set =
Distribution/Client/ProjectConfig/Types.hs view
@@ -20,8 +20,11 @@ MapMappend(..), ) where +import Distribution.Client.Compat.Prelude+import Prelude ()+ import Distribution.Client.Types- ( RemoteRepo, AllowNewer(..), AllowOlder(..)+ ( RemoteRepo, LocalRepo, AllowNewer(..), AllowOlder(..) , WriteGhcEnvironmentFilesPolicy ) import Distribution.Client.Dependency.Types ( PreSolver )@@ -29,6 +32,7 @@ ( UserConstraint ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) )+import Distribution.Client.SourceRepo (SourceRepoList) import Distribution.Client.IndexUtils.Timestamp ( IndexState )@@ -48,7 +52,7 @@ import Distribution.System ( Platform ) import Distribution.PackageDescription- ( FlagAssignment, SourceRepo(..) )+ ( FlagAssignment ) import Distribution.Simple.Compiler ( Compiler, CompilerFlavor , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) )@@ -61,15 +65,8 @@ import Distribution.Verbosity ( Verbosity ) -import Data.Map (Map) import qualified Data.Map as Map-import Data.Set (Set)-import Distribution.Compat.Binary (Binary)-import Distribution.Compat.Semigroup-import GHC.Generics (Generic)-import Data.Typeable - ------------------------------- -- Project config types --@@ -107,7 +104,7 @@ projectPackagesOptional :: [String], -- | Packages in this project from remote source repositories.- projectPackagesRepo :: [SourceRepo],+ projectPackagesRepo :: [SourceRepoList], -- | Packages in this project from hackage repositories. projectPackagesNamed :: [PackageVersionConstraint],@@ -182,6 +179,7 @@ -- configuration used both by the solver and other phases projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers. projectConfigLocalRepos :: NubList FilePath,+ projectConfigLocalNoIndexRepos :: NubList LocalRepo, projectConfigIndexState :: Flag IndexState, projectConfigStoreDir :: Flag FilePath, @@ -197,6 +195,7 @@ projectConfigMaxBackjumps :: Flag Int, projectConfigReorderGoals :: Flag ReorderGoals, projectConfigCountConflicts :: Flag CountConflicts,+ projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts, projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet, projectConfigStrongFlags :: Flag StrongFlags, projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls,@@ -293,7 +292,9 @@ packageConfigTestKeepTix :: Flag Bool, packageConfigTestWrapper :: Flag FilePath, packageConfigTestFailWhenNoTestSuites :: Flag Bool,- packageConfigTestTestOptions :: [PathTemplate]+ packageConfigTestTestOptions :: [PathTemplate],+ -- Benchmark options+ packageConfigBenchmarkOptions :: [PathTemplate] } deriving (Eq, Show, Generic) @@ -303,12 +304,19 @@ instance Binary ProjectConfigProvenance instance Binary PackageConfig +instance Structured ProjectConfig+instance Structured ProjectConfigBuildOnly+instance Structured ProjectConfigShared+instance Structured ProjectConfigProvenance+instance Structured PackageConfig -- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that takes -- the last value rather than the first value for overlapping keys. newtype MapLast k v = MapLast { getMapLast :: Map k v } deriving (Eq, Show, Functor, Generic, Binary, Typeable) +instance (Structured k, Structured v) => Structured (MapLast k v)+ instance Ord k => Monoid (MapLast k v) where mempty = MapLast Map.empty mappend = (<>)@@ -323,6 +331,8 @@ newtype MapMappend k v = MapMappend { getMapMappend :: Map k v } deriving (Eq, Show, Functor, Generic, Binary, Typeable) +instance (Structured k, Structured v) => Structured (MapMappend k v)+ instance (Semigroup v, Ord k) => Monoid (MapMappend k v) where mempty = MapMappend Map.empty mappend = (<>)@@ -379,6 +389,7 @@ = SolverSettings { solverSettingRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers. solverSettingLocalRepos :: [FilePath],+ solverSettingLocalNoIndexRepos :: [LocalRepo], solverSettingConstraints :: [(UserConstraint, ConstraintSource)], solverSettingPreferences :: [PackageVersionConstraint], solverSettingFlagAssignment :: FlagAssignment, -- ^ For all local packages@@ -390,6 +401,7 @@ solverSettingMaxBackjumps :: Maybe Int, solverSettingReorderGoals :: ReorderGoals, solverSettingCountConflicts :: CountConflicts,+ solverSettingFineGrainedConflicts :: FineGrainedConflicts, solverSettingMinimizeConflictSet :: MinimizeConflictSet, solverSettingStrongFlags :: StrongFlags, solverSettingAllowBootLibInstalls :: AllowBootLibInstalls,@@ -407,6 +419,7 @@ deriving (Eq, Show, Generic, Typeable) instance Binary SolverSettings+instance Structured SolverSettings -- | Resolved configuration for things that affect how we build and not the@@ -437,6 +450,7 @@ buildSettingKeepTempFiles :: Bool, buildSettingRemoteRepos :: [RemoteRepo], buildSettingLocalRepos :: [FilePath],+ buildSettingLocalNoIndexRepos :: [LocalRepo], buildSettingCacheDir :: FilePath, buildSettingHttpTransport :: Maybe String, buildSettingIgnoreExpiry :: Bool,
Distribution/Client/ProjectOrchestration.hs view
@@ -159,6 +159,7 @@ , OptimisationLevel(..)) import qualified Data.Monoid as Mon+import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import qualified Data.Map as Map import Data.Either@@ -221,6 +222,10 @@ verbosity cabalDirLayout projectConfig + -- https://github.com/haskell/cabal/issues/6013+ when (null (projectPackages projectConfig) && null (projectPackagesOptional projectConfig)) $+ warn verbosity "There are no packages or optional-packages in the project"+ return ProjectBaseContext { distDirLayout, cabalDirLayout,@@ -512,6 +517,7 @@ resolveTargets selectPackageTargets selectComponentTarget liftProblem installPlan mPkgDb = fmap mkTargetsMap+ . either (Left . toList) Right . checkErrors . map (\ts -> (,) ts <$> checkTarget ts) where@@ -609,12 +615,12 @@ -> [AvailableTarget k] -> Either err [k] selectComponentTargets subtarget =- either (Left . head) Right+ either (Left . NE.head) Right . checkErrors . map (selectComponentTarget subtarget) - checkErrors :: [Either e a] -> Either [e] [a]- checkErrors = (\(es, xs) -> if null es then Right xs else Left es)+ checkErrors :: [Either e a] -> Either (NonEmpty e) [a]+ checkErrors = (\(es, xs) -> case es of { [] -> Right xs; (e:es') -> Left (e:|es') }) . partitionEithers
Distribution/Client/ProjectPlanOutput.hs view
@@ -19,7 +19,8 @@ import Distribution.Client.ProjectBuilding.Types import Distribution.Client.DistDirLayout import Distribution.Client.Types (Repo(..), RemoteRepo(..), PackageLocation(..), confInstId)-import Distribution.Client.PackageHash (showHashValue, hashValue)+import Distribution.Client.HashValue (showHashValue, hashValue)+import Distribution.Client.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..)) import qualified Distribution.Client.InstallPlan as InstallPlan import qualified Distribution.Client.Utils.Json as J@@ -52,7 +53,6 @@ import Distribution.Client.Compat.Prelude import qualified Data.Map as Map-import Data.Set (Set) import qualified Data.Set as Set import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Builder as BB@@ -203,6 +203,10 @@ J.object [ "type" J..= J.String "local-repo" , "path" J..= J.String repoLocalDir ]+ RepoLocalNoIndex{..} ->+ J.object [ "type" J..= J.String "local-repo-no-index"+ , "path" J..= J.String repoLocalDir+ ] RepoRemote{..} -> J.object [ "type" J..= J.String "remote-repo" , "uri" J..= J.String (show (remoteRepoURI repoRemote))@@ -212,15 +216,14 @@ , "uri" J..= J.String (show (remoteRepoURI repoRemote)) ] - sourceRepoToJ :: PD.SourceRepo -> J.Value- sourceRepoToJ PD.SourceRepo{..} =+ sourceRepoToJ :: SourceRepoMaybe -> J.Value+ sourceRepoToJ SourceRepositoryPackage{..} = 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+ [ "type" J..= jdisplay srpType+ , "location" J..= J.String srpLocation+ , "branch" J..= fmap J.String srpBranch+ , "tag" J..= fmap J.String srpTag+ , "subdir" J..= fmap J.String srpSubdir ] dist_dir = distBuildDirectory distDirLayout
Distribution/Client/ProjectPlanning.hs view
@@ -70,6 +70,7 @@ import Prelude () import Distribution.Client.Compat.Prelude +import Distribution.Client.HashValue import Distribution.Client.ProjectPlanning.Types as Ty import Distribution.Client.PackageHash import Distribution.Client.RebuildMonad@@ -160,13 +161,13 @@ import Text.PrettyPrint hiding ((<>)) import qualified Text.PrettyPrint as Disp import qualified Data.Map as Map-import Data.Set (Set) import qualified Data.Set as Set import Control.Monad import qualified Data.Traversable as T import Control.Monad.State as State import Control.Exception import Data.List (groupBy)+import qualified Data.List.NonEmpty as NE import Data.Either import Data.Function import System.FilePath@@ -650,7 +651,12 @@ projectConfigAllPackages projectConfigLocalPackages (getMapMappend projectConfigSpecificPackage)- let instantiatedPlan = instantiateInstallPlan elaboratedPlan+ let instantiatedPlan+ = instantiateInstallPlan+ cabalStoreDirLayout+ defaultInstallDirs+ elaboratedShared+ elaboratedPlan liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan) return (instantiatedPlan, elaboratedShared) where@@ -873,8 +879,8 @@ return (pkgid, hashFromTUF hash) | pkgid <- pkgids ] | (repo, pkgids) <-- map (\grp@((_,repo):_) -> (repo, map fst grp))- . groupBy ((==) `on` (remoteRepoName . repoRemote . snd))+ map (\grp@((_,repo):|_) -> (repo, map fst (NE.toList grp)))+ . NE.groupBy ((==) `on` (remoteRepoName . repoRemote . snd)) . sortBy (compare `on` (remoteRepoName . repoRemote . snd)) $ repoTarballPkgsWithMetadata ]@@ -952,6 +958,8 @@ . setCountConflicts solverSettingCountConflicts + . setFineGrainedConflicts solverSettingFineGrainedConflicts+ . setMinimizeConflictSet solverSettingMinimizeConflictSet --TODO: [required eventually] should only be configurable for@@ -1077,6 +1085,7 @@ -- respective major Cabal version bundled with the respective GHC -- release). --+ -- GHC 8.8 needs Cabal >= 3.0 -- GHC 8.6 needs Cabal >= 2.4 -- GHC 8.4 needs Cabal >= 2.2 -- GHC 8.2 needs Cabal >= 2.0@@ -1089,11 +1098,9 @@ -- TODO: long-term, this compatibility matrix should be -- stored as a field inside 'Distribution.Compiler.Compiler' setupMinCabalVersionConstraint- | 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,6] = mkVersion [2,3]+ | isGHC, compVer >= mkVersion [8,10] = mkVersion [3,2]+ | isGHC, compVer >= mkVersion [8,8] = mkVersion [3,0]+ | isGHC, compVer >= mkVersion [8,6] = mkVersion [2,4] | isGHC, compVer >= mkVersion [8,4] = mkVersion [2,2] | isGHC, compVer >= mkVersion [8,2] = mkVersion [2,0] | isGHC, compVer >= mkVersion [8,0] = mkVersion [1,24]@@ -1481,7 +1488,7 @@ -- 5. Construct the final ElaboratedConfiguredPackage let- elab = elab1 {+ elab2 = elab1 { elabModuleShape = lc_shape lc, elabUnitId = abstractUnitId (lc_uid lc), elabComponentId = lc_cid lc,@@ -1491,9 +1498,15 @@ compOrderLibDependencies = ordNub (map (abstractUnitId . ci_id) (lc_includes lc ++ lc_sig_includes lc))- },- elabInstallDirs = install_dirs cid+ } }+ elab = elab2 {+ elabInstallDirs = computeInstallDirs+ storeDirLayout+ defaultInstallDirs+ elaboratedSharedConfig+ elab2+ } -- 6. Construct the updated local maps let cc_map' = extendConfiguredComponentMap cc cc_map@@ -1548,31 +1561,6 @@ | PkgconfigDependency pn _ <- PD.pkgconfigDepends (Cabal.componentBuildInfo comp) ] - install_dirs cid- | shouldBuildInplaceOnly spkg- -- use the ordinary default install dirs- = (InstallDirs.absoluteInstallDirs- pkgid- (newSimpleUnitId cid)- (compilerInfo compiler)- InstallDirs.NoCopyDest- platform- defaultInstallDirs) {-- -- absoluteInstallDirs sets these as 'undefined' but we have- -- to use them as "Setup.hs configure" args- InstallDirs.libsubdir = "",- InstallDirs.libexecsubdir = "",- InstallDirs.datasubdir = ""- }-- | otherwise- -- use special simplified install dirs- = storePackageInstallDirs- storeDirLayout- (compilerId compiler)- cid- inplace_bin_dir elab = binDirectoryFor distDirLayout@@ -1634,14 +1622,20 @@ elab where elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg- elab = elab0 {+ elab1 = elab0 { elabUnitId = newSimpleUnitId pkgInstalledId, elabComponentId = pkgInstalledId, elabLinkedInstantiatedWith = Map.empty,- elabInstallDirs = install_dirs, elabPkgOrComp = ElabPackage $ ElaboratedPackage {..}, elabModuleShape = modShape }+ elab = elab1 {+ elabInstallDirs =+ computeInstallDirs storeDirLayout+ defaultInstallDirs+ elaboratedSharedConfig+ elab1+ } modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of Nothing -> emptyModuleShape@@ -1704,31 +1698,6 @@ -- pkgStanzasEnabled is a superset of elabStanzasRequested pkgStanzasEnabled = Map.keysSet (Map.filter (id :: Bool -> Bool) elabStanzasRequested) - install_dirs- | shouldBuildInplaceOnly pkg- -- use the ordinary default install dirs- = (InstallDirs.absoluteInstallDirs- pkgid- (newSimpleUnitId pkgInstalledId)- (compilerInfo compiler)- InstallDirs.NoCopyDest- platform- defaultInstallDirs) {-- -- absoluteInstallDirs sets these as 'undefined' but we have to- -- use them as "Setup.hs configure" args- InstallDirs.libsubdir = "",- InstallDirs.libexecsubdir = "",- InstallDirs.datasubdir = ""- }-- | otherwise- -- use special simplified install dirs- = storePackageInstallDirs- storeDirLayout- (compilerId compiler)- pkgInstalledId- elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc -> ElaboratedConfiguredPackage elaborateSolverToCommon@@ -1749,12 +1718,12 @@ elabIsCanonical = True elabPkgSourceId = pkgid- elabPkgDescription = let Right (desc, _) =- PD.finalizePD+ elabPkgDescription = case PD.finalizePD flags elabEnabledSpec (const True) platform (compilerInfo compiler)- [] gdesc- in desc+ [] gdesc of+ Right (desc, _) -> desc+ Left _ -> error "Failed to finalizePD in elaborateSolverToCommon" elabFlagAssignment = flags elabFlagDefaults = PD.mkFlagAssignment [ (Cabal.flagName flag, Cabal.flagDefault flag)@@ -1887,6 +1856,8 @@ elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites elabTestTestOptions = perPkgOptionList pkgid packageConfigTestTestOptions + elabBenchmarkOptions = perPkgOptionList pkgid packageConfigBenchmarkOptions+ perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a]@@ -2153,8 +2124,8 @@ getComponentId (InstallPlan.Configured elab) = elabComponentId elab getComponentId (InstallPlan.Installed elab) = elabComponentId elab -instantiateInstallPlan :: ElaboratedInstallPlan -> ElaboratedInstallPlan-instantiateInstallPlan plan =+instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan+instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan = InstallPlan.new (IndependentGoals False) (Graph.fromDistinctList (Map.elems ready_map)) where@@ -2182,12 +2153,12 @@ instantiateComponent uid cid insts | Just planpkg <- Map.lookup cid cmap = case planpkg of- InstallPlan.Configured (elab@ElaboratedConfiguredPackage+ InstallPlan.Configured (elab0@ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) -> do deps <- mapM (substUnitId insts) (compLinkedLibDependencies comp) let getDep (Module dep_uid _) = [dep_uid]- return $ InstallPlan.Configured elab {+ elab1 = elab0 { elabUnitId = uid, elabComponentId = cid, elabInstantiatedWith = insts,@@ -2198,7 +2169,14 @@ ordNub (map unDefUnitId (deps ++ concatMap getDep (Map.elems insts))) }- }+ }+ elab = elab1 {+ elabInstallDirs = computeInstallDirs storeDirLayout+ defaultInstallDirs+ elaboratedShared+ elab1+ }+ return $ InstallPlan.Configured elab _ -> return planpkg | otherwise = error ("instantiateComponent: " ++ display cid) @@ -3256,6 +3234,38 @@ sysconfdir = prefix </> "etc" ++computeInstallDirs :: StoreDirLayout+ -> InstallDirs.InstallDirTemplates+ -> ElaboratedSharedConfig+ -> ElaboratedConfiguredPackage+ -> InstallDirs.InstallDirs FilePath+computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab+ | elabBuildStyle elab == BuildInplaceOnly+ -- use the ordinary default install dirs+ = (InstallDirs.absoluteInstallDirs+ (elabPkgSourceId elab)+ (elabUnitId elab)+ (compilerInfo (pkgConfigCompiler elaboratedShared))+ InstallDirs.NoCopyDest+ (pkgConfigPlatform elaboratedShared)+ defaultInstallDirs) {++ -- absoluteInstallDirs sets these as 'undefined' but we have+ -- to use them as "Setup.hs configure" args+ InstallDirs.libsubdir = "",+ InstallDirs.libexecsubdir = "",+ InstallDirs.datasubdir = ""+ }++ | otherwise+ -- use special simplified install dirs+ = storePackageInstallDirs'+ storeDirLayout+ (compilerId (pkgConfigCompiler elaboratedShared))+ (elabUnitId elab)++ --TODO: [code cleanup] perhaps reorder this code -- based on the ElaboratedInstallPlan + ElaboratedSharedConfig, -- make the various Setup.hs {configure,build,copy} flags@@ -3459,10 +3469,10 @@ -> Verbosity -> FilePath -> Cabal.BenchmarkFlags-setupHsBenchFlags _ _ verbosity builddir = Cabal.BenchmarkFlags+setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.BenchmarkFlags { benchmarkDistPref = toFlag builddir , benchmarkVerbosity = toFlag verbosity- , benchmarkOptions = mempty+ , benchmarkOptions = elabBenchmarkOptions } setupHsBenchArgs :: ElaboratedConfiguredPackage -> [String]
Distribution/Client/ProjectPlanning/Types.hs view
@@ -60,6 +60,9 @@ SetupScriptStyle(..), ) where +import Distribution.Client.Compat.Prelude+import Prelude ()+ import Distribution.Client.TargetSelector ( SubComponentTarget(..) ) import Distribution.Client.PackageHash@@ -102,16 +105,10 @@ import Distribution.Compat.Graph (IsNode(..)) 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-import Distribution.Compat.Binary-import GHC.Generics (Generic) import qualified Data.Monoid as Mon-import Data.Typeable-import Control.Monad+import Control.Monad (guard) import System.FilePath ((</>)) @@ -158,6 +155,7 @@ --TODO: [code cleanup] no Eq instance instance Binary ElaboratedSharedConfig+instance Structured ElaboratedSharedConfig data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage {@@ -297,6 +295,8 @@ elabTestFailWhenNoTestSuites :: Bool, elabTestTestOptions :: [PathTemplate], + elabBenchmarkOptions :: [PathTemplate],+ -- Setup.hs related things: -- | One of four modes for how we build and interact with the Setup.hs@@ -461,6 +461,7 @@ nodeNeighbors = elabOrderDependencies instance Binary ElaboratedConfiguredPackage+instance Structured ElaboratedConfiguredPackage data ElaboratedPackageOrComponent = ElabPackage ElaboratedPackage@@ -468,6 +469,7 @@ deriving (Eq, Show, Generic) instance Binary ElaboratedPackageOrComponent+instance Structured ElaboratedPackageOrComponent elabComponentName :: ElaboratedConfiguredPackage -> Maybe ComponentName elabComponentName elab =@@ -659,6 +661,7 @@ deriving (Eq, Show, Generic) instance Binary ElaboratedComponent+instance Structured ElaboratedComponent -- | See 'elabOrderDependencies'. compOrderDependencies :: ElaboratedComponent -> [UnitId]@@ -707,6 +710,7 @@ deriving (Eq, Show, Generic) instance Binary ElaboratedPackage+instance Structured ElaboratedPackage -- | See 'elabOrderDependencies'. This gives the unflattened version, -- which can be useful in some circumstances.@@ -738,6 +742,7 @@ deriving (Eq, Show, Generic) instance Binary BuildStyle+instance Structured BuildStyle type CabalFileText = LBS.ByteString @@ -755,6 +760,7 @@ deriving (Eq, Ord, Show, Generic) instance Binary ComponentTarget+instance Structured ComponentTarget -- | Unambiguously render a 'ComponentTarget', e.g., to pass -- to a Cabal Setup script.@@ -830,3 +836,4 @@ deriving (Eq, Show, Generic, Typeable) instance Binary SetupScriptStyle+instance Structured SetupScriptStyle
Distribution/Client/RebuildMonad.hs view
@@ -116,7 +116,7 @@ -- -- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'. ---rerunIfChanged :: (Binary a, Binary b)+rerunIfChanged :: (Binary a, Structured a, Binary b, Structured b) => Verbosity -> FileMonitor a b -> a
Distribution/Client/Sandbox.hs view
@@ -44,6 +44,7 @@ import Prelude () import Distribution.Client.Compat.Prelude+import Distribution.Utils.Generic(safeLast) import Distribution.Client.Setup ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..)@@ -91,7 +92,7 @@ import Distribution.Simple.PreProcess ( knownSuffixHandlers ) import Distribution.Simple.Program ( ProgramDb ) import Distribution.Simple.Setup ( Flag(..), HaddockFlags(..)- , emptyTestFlags+ , emptyTestFlags, emptyBenchmarkFlags , fromFlagOrDefault, flagToMaybe ) import Distribution.Simple.SrcDist ( prepareTree ) import Distribution.Simple.Utils ( die', debug, notice, info, warn@@ -216,10 +217,10 @@ tryGetIndexFilePath' :: Verbosity -> GlobalFlags -> IO FilePath tryGetIndexFilePath' verbosity globalFlags = do let paths = fromNubList $ globalLocalRepos globalFlags- case paths of- [] -> die' verbosity $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " +++ case safeLast paths of+ Nothing -> die' verbosity $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++ "no local repos found. " ++ checkConfiguration- _ -> return $ (last paths) </> Index.defaultIndexFileName+ Just lp -> return $ lp </> Index.defaultIndexFileName where checkConfiguration = "Please check your configuration ('" ++ userPackageEnvironmentFile ++ "')."@@ -685,7 +686,7 @@ ,comp, platform, progdb ,UseSandbox sandboxDir, Just sandboxPkgInfo ,globalFlags, configFlags, configExFlags, installFlags- ,haddockFlags, emptyTestFlags)+ ,haddockFlags, emptyTestFlags, emptyBenchmarkFlags) -- This can actually be replaced by a call to 'install', but we use a -- lower-level API because of layer separation reasons. Additionally, we
Distribution/Client/Security/HTTP.hs view
@@ -35,7 +35,6 @@ import Hackage.Security.Client.Repository.HttpLib import Hackage.Security.Util.Checked import Hackage.Security.Util.Pretty-import qualified Hackage.Security.Util.Lens as Lens {------------------------------------------------------------------------------- 'HttpLib' implementation@@ -142,7 +141,14 @@ finalize (name, strs) = [HTTP.Header name (intercalate ", " (reverse strs))] insert :: Eq a => a -> [b] -> [(a, [b])] -> [(a, [b])]- insert x y = Lens.modify (Lens.lookupM x) (++ y)+ insert x y = modifyAssocList x (++ y)++ -- modify the first matching element+ modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)]+ modifyAssocList a f = go where+ go [] = []+ go (p@(a', b) : xs) | a == a' = (a', f b) : xs+ | otherwise = p : go xs {------------------------------------------------------------------------------- Custom exceptions
Distribution/Client/Setup.hs view
@@ -23,7 +23,7 @@ , configureExCommand, ConfigExFlags(..), defaultConfigExFlags , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..) , filterTestFlags- , replCommand, testCommand, benchmarkCommand, testOptions+ , replCommand, testCommand, benchmarkCommand, testOptions, benchmarkOptions , configureExOptions, reconfigureCommand , installCommand, InstallFlags(..), installOptions, defaultInstallFlags , filterHaddockArgs, filterHaddockFlags, haddockOptions@@ -61,9 +61,9 @@ , liftOptions , yesNoOpt --TODO: stop exporting these:- , showRepo- , parseRepo- , readRepo+ , showRemoteRepo+ , parseRemoteRepo+ , readRemoteRepo ) where import Prelude ()@@ -73,6 +73,7 @@ import Distribution.Client.Types ( Username(..), Password(..), RemoteRepo(..)+ , LocalRepo (..), emptyLocalRepo , AllowNewer(..), AllowOlder(..), RelaxDeps(..) , WriteGhcEnvironmentFilesPolicy(..) )@@ -101,7 +102,7 @@ import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Setup ( ConfigFlags(..), BuildFlags(..), ReplFlags- , TestFlags, BenchmarkFlags(..)+ , TestFlags, BenchmarkFlags , SDistFlags(..), HaddockFlags(..) , CleanFlags(..), DoctestFlags(..) , CopyFlags(..), RegisterFlags(..)@@ -420,8 +421,13 @@ option [] ["remote-repo"] "The name and url for a remote repository" globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })- (reqArg' "NAME:URL" (toNubList . maybeToList . readRepo) (map showRepo . fromNubList))+ (reqArg' "NAME:URL" (toNubList . maybeToList . readRemoteRepo) (map showRemoteRepo . fromNubList)) + ,option [] ["local-no-index-repo"]+ "The name and a path for a local no-index repository"+ globalLocalNoIndexRepos (\v flags -> flags { globalLocalNoIndexRepos = v })+ (reqArg' "NAME:PATH" (toNubList . maybeToList . readLocalRepo) (map showLocalRepo . fromNubList))+ ,option [] ["remote-repo-cache"] "The location where downloads from all remote repos are cached" globalCacheDir (\v flags -> flags { globalCacheDir = v })@@ -997,6 +1003,7 @@ fetchMaxBackjumps :: Flag Int, fetchReorderGoals :: Flag ReorderGoals, fetchCountConflicts :: Flag CountConflicts,+ fetchFineGrainedConflicts :: Flag FineGrainedConflicts, fetchMinimizeConflictSet :: Flag MinimizeConflictSet, fetchIndependentGoals :: Flag IndependentGoals, fetchShadowPkgs :: Flag ShadowPkgs,@@ -1017,6 +1024,7 @@ fetchMaxBackjumps = Flag defaultMaxBackjumps, fetchReorderGoals = Flag (ReorderGoals False), fetchCountConflicts = Flag (CountConflicts True),+ fetchFineGrainedConflicts = Flag (FineGrainedConflicts True), fetchMinimizeConflictSet = Flag (MinimizeConflictSet False), fetchIndependentGoals = Flag (IndependentGoals False), fetchShadowPkgs = Flag (ShadowPkgs False),@@ -1079,6 +1087,7 @@ fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v }) fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v }) fetchCountConflicts (\v flags -> flags { fetchCountConflicts = v })+ fetchFineGrainedConflicts (\v flags -> flags { fetchFineGrainedConflicts = v }) fetchMinimizeConflictSet (\v flags -> flags { fetchMinimizeConflictSet = v }) fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v }) fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v })@@ -1100,6 +1109,7 @@ freezeMaxBackjumps :: Flag Int, freezeReorderGoals :: Flag ReorderGoals, freezeCountConflicts :: Flag CountConflicts,+ freezeFineGrainedConflicts :: Flag FineGrainedConflicts, freezeMinimizeConflictSet :: Flag MinimizeConflictSet, freezeIndependentGoals :: Flag IndependentGoals, freezeShadowPkgs :: Flag ShadowPkgs,@@ -1118,6 +1128,7 @@ freezeMaxBackjumps = Flag defaultMaxBackjumps, freezeReorderGoals = Flag (ReorderGoals False), freezeCountConflicts = Flag (CountConflicts True),+ freezeFineGrainedConflicts = Flag (FineGrainedConflicts True), freezeMinimizeConflictSet = Flag (MinimizeConflictSet False), freezeIndependentGoals = Flag (IndependentGoals False), freezeShadowPkgs = Flag (ShadowPkgs False),@@ -1171,6 +1182,7 @@ freezeMaxBackjumps (\v flags -> flags { freezeMaxBackjumps = v }) freezeReorderGoals (\v flags -> flags { freezeReorderGoals = v }) freezeCountConflicts (\v flags -> flags { freezeCountConflicts = v })+ freezeFineGrainedConflicts (\v flags -> flags { freezeFineGrainedConflicts = v }) freezeMinimizeConflictSet (\v flags -> flags { freezeMinimizeConflictSet = v }) freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v }) freezeShadowPkgs (\v flags -> flags { freezeShadowPkgs = v })@@ -1367,13 +1379,15 @@ -- * Other commands -- ------------------------------------------------------------ -upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)+upgradeCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags+ ) upgradeCommand = configureCommand { commandName = "upgrade", commandSynopsis = "(command disabled, use install instead)", commandDescription = Nothing, commandUsage = usageFlagsOrPackages "upgrade",- commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty),+ commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty), commandOptions = commandOptions installCommand } @@ -1741,6 +1755,7 @@ installMaxBackjumps :: Flag Int, installReorderGoals :: Flag ReorderGoals, installCountConflicts :: Flag CountConflicts,+ installFineGrainedConflicts :: Flag FineGrainedConflicts, installMinimizeConflictSet :: Flag MinimizeConflictSet, installIndependentGoals :: Flag IndependentGoals, installShadowPkgs :: Flag ShadowPkgs,@@ -1790,6 +1805,7 @@ installMaxBackjumps = Flag defaultMaxBackjumps, installReorderGoals = Flag (ReorderGoals False), installCountConflicts = Flag (CountConflicts True),+ installFineGrainedConflicts = Flag (FineGrainedConflicts True), installMinimizeConflictSet = Flag (MinimizeConflictSet False), installIndependentGoals= Flag (IndependentGoals False), installShadowPkgs = Flag (ShadowPkgs False),@@ -1830,7 +1846,9 @@ allSolvers :: String allSolvers = intercalate ", " (map display ([minBound .. maxBound] :: [PreSolver])) -installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)+installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags+ ) installCommand = CommandUI { commandName = "install", commandSynopsis = "Install packages.",@@ -1883,7 +1901,7 @@ ++ " " ++ (map (const ' ') pname) ++ " " ++ " Change installation destination\n",- commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty),+ commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty), commandOptions = \showOrParseArgs -> liftOptions get1 set1 -- Note: [Hidden Flags]@@ -1902,13 +1920,15 @@ installOptions showOrParseArgs) ++ liftOptions get4 set4 (haddockOptions showOrParseArgs) ++ liftOptions get5 set5 (testOptions showOrParseArgs)+ ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs) } 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)+ get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f)+ get2 (_,b,_,_,_,_) = b; set2 b (a,_,c,d,e,f) = (a,b,c,d,e,f)+ get3 (_,_,c,_,_,_) = c; set3 c (a,b,_,d,e,f) = (a,b,c,d,e,f)+ get4 (_,_,_,d,_,_) = d; set4 d (a,b,c,_,e,f) = (a,b,c,d,e,f)+ get5 (_,_,_,_,e,_) = e; set5 e (a,b,c,d,_,f) = (a,b,c,d,e,f)+ get6 (_,_,_,_,_,f) = f; set6 f (a,b,c,d,e,_) = (a,b,c,d,e,f) haddockCommand :: CommandUI HaddockFlags haddockCommand = Cabal.haddockCommand@@ -1968,6 +1988,19 @@ prefixTest name | "test-" `isPrefixOf` name = name | otherwise = "test-" ++ name +benchmarkOptions :: ShowOrParseArgs -> [OptionField BenchmarkFlags]+benchmarkOptions showOrParseArgs+ = [ opt { optionName = prefixBenchmark name,+ optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixBenchmark lflags)) descr+ | descr <- optionDescr opt] }+ | opt <- commandOptions Cabal.benchmarkCommand showOrParseArgs+ , let name = optionName opt+ , name `elem` ["benchmark-options", "benchmark-option"]+ ]+ where+ prefixBenchmark name | "benchmark-" `isPrefixOf` name = name+ | otherwise = "benchmark-" ++ name+ fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w@@ -2003,6 +2036,7 @@ installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v }) installReorderGoals (\v flags -> flags { installReorderGoals = v }) installCountConflicts (\v flags -> flags { installCountConflicts = v })+ installFineGrainedConflicts (\v flags -> flags { installFineGrainedConflicts = v }) installMinimizeConflictSet (\v flags -> flags { installMinimizeConflictSet = v }) installIndependentGoals (\v flags -> flags { installIndependentGoals = v }) installShadowPkgs (\v flags -> flags { installShadowPkgs = v })@@ -2835,6 +2869,7 @@ -> (flags -> Flag Int ) -> (Flag Int -> flags -> flags) -> (flags -> Flag ReorderGoals) -> (Flag ReorderGoals -> flags -> flags) -> (flags -> Flag CountConflicts) -> (Flag CountConflicts -> flags -> flags)+ -> (flags -> Flag FineGrainedConflicts) -> (Flag FineGrainedConflicts -> flags -> flags) -> (flags -> Flag MinimizeConflictSet) -> (Flag MinimizeConflictSet -> flags -> flags) -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags) -> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags)@@ -2843,8 +2878,8 @@ -> (flags -> Flag OnlyConstrained) -> (Flag OnlyConstrained -> flags -> flags) -> [OptionField flags] optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc- getmc setmc getig setig getsip setsip getstrfl setstrfl- getib setib getoc setoc =+ getfgc setfgc getmc setmc getig setig getsip setsip+ getstrfl setstrfl getib setib getoc setoc = [ option [] ["max-backjumps"] ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.") getmbj setmbj@@ -2860,6 +2895,11 @@ (fmap asBool . getcc) (setcc . fmap CountConflicts) (yesNoOpt showOrParseArgs)+ , option [] ["fine-grained-conflicts"]+ "Skip a version of a package if it does not resolve the conflicts encountered in the last version, as a solver optimization (default)."+ (fmap asBool . getfgc)+ (setfgc . fmap FineGrainedConflicts)+ (yesNoOpt showOrParseArgs) , option [] ["minimize-conflict-set"] ("When there is no solution, try to improve the error message by finding " ++ "a minimal conflict set (default: false). May increase run time "@@ -2932,15 +2972,15 @@ v | v == nullVersion -> Dependency (packageName p) anyVersion (Set.singleton LMainLibName) | otherwise -> Dependency (packageName p) (thisVersion v) (Set.singleton LMainLibName) -showRepo :: RemoteRepo -> String-showRepo repo = remoteRepoName repo ++ ":"+showRemoteRepo :: RemoteRepo -> String+showRemoteRepo repo = remoteRepoName repo ++ ":" ++ uriToString id (remoteRepoURI repo) [] -readRepo :: String -> Maybe RemoteRepo-readRepo = readPToMaybe parseRepo+readRemoteRepo :: String -> Maybe RemoteRepo+readRemoteRepo = readPToMaybe parseRemoteRepo -parseRepo :: Parse.ReadP r RemoteRepo-parseRepo = do+parseRemoteRepo :: Parse.ReadP r RemoteRepo+parseRemoteRepo = do name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.") _ <- Parse.char ':' uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~")@@ -2953,6 +2993,21 @@ remoteRepoKeyThreshold = 0, remoteRepoShouldTryHttps = False }++showLocalRepo :: LocalRepo -> String+showLocalRepo repo = localRepoName repo ++ ":" ++ localRepoPath repo++readLocalRepo :: String -> Maybe LocalRepo+readLocalRepo = readPToMaybe parseLocalRepo++parseLocalRepo :: Parse.ReadP r LocalRepo+parseLocalRepo = do+ name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.")+ _ <- Parse.char ':'+ path <- Parse.munch1 (const True)+ return $ (emptyLocalRepo name)+ { localRepoPath = path+ } -- ------------------------------------------------------------ -- * Helpers for Documentation
Distribution/Client/SetupWrapper.hs view
@@ -81,6 +81,8 @@ ( Lock, criticalSection ) import Distribution.Simple.Setup ( Flag(..) )+import Distribution.Utils.Generic+ ( safeHead ) import Distribution.Simple.Utils ( die', debug, info, infoNoWrap , cabalVersion, tryFindPackageDesc, comparing@@ -726,7 +728,8 @@ ++ "' requires Cabal library version " ++ display (useCabalVersion options) ++ " but no suitable version is installed."- pkgs -> let ipkginfo = head . snd . bestVersion fst $ pkgs+ pkgs -> let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs+ err = error "Distribution.Client.installedCabalVersion: empty version list" in return (packageVersion ipkginfo ,Just . IPI.installedComponentId $ ipkginfo, options'')
Distribution/Client/SolverInstallPlan.hs view
@@ -51,6 +51,9 @@ reverseTopologicalOrder, ) where +import Distribution.Client.Compat.Prelude hiding (toList)+import Prelude ()+ import Distribution.Package ( PackageIdentifier(..), Package(..), PackageName , HasUnitId(..), PackageId, packageVersion, packageName )@@ -67,18 +70,12 @@ import Distribution.Solver.Types.ResolverPackage import Distribution.Solver.Types.SolverId -import Data.List- ( intercalate )-import Data.Maybe- ( fromMaybe, mapMaybe )-import Distribution.Compat.Binary (Binary(..)) import Distribution.Compat.Graph (Graph, IsNode(..))+import qualified Data.Foldable as Foldable import qualified Data.Graph as OldGraph import qualified Distribution.Compat.Graph as Graph import qualified Data.Map as Map-import Data.Map (Map) import Data.Array ((!))-import Data.Typeable type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc @@ -88,7 +85,7 @@ planIndex :: !SolverPlanIndex, planIndepGoals :: !IndependentGoals }- deriving (Typeable)+ deriving (Typeable, Generic) {- -- | Much like 'planPkgIdOf', but mapping back to full packages.@@ -102,24 +99,10 @@ Nothing -> error "InstallPlan: internal error: planPkgOf lookup failed" -} -mkInstallPlan :: SolverPlanIndex- -> IndependentGoals- -> SolverInstallPlan-mkInstallPlan index indepGoals =- SolverInstallPlan {- planIndex = index,- planIndepGoals = indepGoals- } -instance Binary SolverInstallPlan where- put SolverInstallPlan {- planIndex = index,- planIndepGoals = indepGoals- } = put (index, indepGoals) - get = do- (index, indepGoals) <- get- return $! mkInstallPlan index indepGoals+instance Binary SolverInstallPlan+instance Structured SolverInstallPlan showPlanIndex :: [SolverPlanPackage] -> String showPlanIndex = intercalate "\n" . map showPlanPackage@@ -140,11 +123,11 @@ -> Either [SolverPlanProblem] SolverInstallPlan new indepGoals index = case problems indepGoals index of- [] -> Right (mkInstallPlan index indepGoals)+ [] -> Right (SolverInstallPlan index indepGoals) probs -> Left probs toList :: SolverInstallPlan -> [SolverPlanPackage]-toList = Graph.toList . planIndex+toList = Foldable.toList . planIndex toMap :: SolverInstallPlan -> Map SolverId SolverPlanPackage toMap = Graph.toMap . planIndex@@ -239,7 +222,7 @@ dependencyInconsistencies indepGoals index ] ++ [ PackageStateInvalid pkg pkg'- | pkg <- Graph.toList index+ | pkg <- Foldable.toList index , Just pkg' <- map (flip Graph.lookup index) (nodeNeighbors pkg) , not (stateDependencyRelation pkg pkg') ]@@ -316,7 +299,7 @@ setupRoots :: SolverPlanIndex -> [[SolverId]] setupRoots = filter (not . null) . map (CD.setupDeps . resolverPackageLibDeps)- . Graph.toList+ . Foldable.toList -- | Given a package index where we assume we want to use all the packages -- (use 'dependencyClosure' if you need to get such a index subset) find out@@ -345,7 +328,7 @@ inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) [ (packageName dep, Map.fromList [(sid,(dep,[packageId pkg]))]) | -- For each package @pkg@- pkg <- Graph.toList index+ pkg <- Foldable.toList index -- Find out which @sid@ @pkg@ depends on , sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg) -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@)
+ Distribution/Client/SourceRepo.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+module Distribution.Client.SourceRepo where++import Distribution.Client.Compat.Prelude+import Prelude ()+import Distribution.Compat.Lens (Lens, Lens')++import Distribution.Types.SourceRepo+ ( RepoType(..))+import Distribution.FieldGrammar (FieldGrammar, ParsecFieldGrammar', PrettyFieldGrammar', uniqueField, uniqueFieldAla, optionalFieldAla, monoidalFieldAla)+import Distribution.Parsec.Newtypes (Token (..), FilePathNT (..), alaList', NoCommaFSep (..))++-- | @source-repository-package@ definition+--+data SourceRepositoryPackage f = SourceRepositoryPackage+ { srpType :: !RepoType+ , srpLocation :: !String+ , srpTag :: !(Maybe String)+ , srpBranch :: !(Maybe String)+ , srpSubdir :: !(f FilePath)+ }+ deriving (Generic)++deriving instance (Eq (f FilePath)) => Eq (SourceRepositoryPackage f)+deriving instance (Ord (f FilePath)) => Ord (SourceRepositoryPackage f)+deriving instance (Show (f FilePath)) => Show (SourceRepositoryPackage f)+deriving instance (Binary (f FilePath)) => Binary (SourceRepositoryPackage f)+deriving instance (Typeable f, Structured (f FilePath)) => Structured (SourceRepositoryPackage f)++-- | Read from @cabal.project@+type SourceRepoList = SourceRepositoryPackage []++-- | Distilled from 'Distribution.Types.SourceRepo.SourceRepo'+type SourceRepoMaybe = SourceRepositoryPackage Maybe++-- | 'SourceRepositoryPackage' without subdir. Used in clone errors. Cloning doesn't care about subdirectory.+type SourceRepoProxy = SourceRepositoryPackage Proxy++srpHoist :: (forall x. f x -> g x) -> SourceRepositoryPackage f -> SourceRepositoryPackage g+srpHoist nt s = s { srpSubdir = nt (srpSubdir s) }++srpToProxy :: SourceRepositoryPackage f -> SourceRepositoryPackage Proxy+srpToProxy s = s { srpSubdir = Proxy }++-- | Split single @source-repository-package@ declaration with multiple subdirs,+-- into multiple ones with at most single subdir.+srpFanOut :: SourceRepositoryPackage [] -> NonEmpty (SourceRepositoryPackage Maybe)+srpFanOut s@SourceRepositoryPackage { srpSubdir = [] } =+ s { srpSubdir = Nothing } :| []+srpFanOut s@SourceRepositoryPackage { srpSubdir = d:ds } = f d :| map f ds where+ f subdir = s { srpSubdir = Just subdir }++-------------------------------------------------------------------------------+-- Lens+-------------------------------------------------------------------------------++srpTypeLens :: Lens' (SourceRepositoryPackage f) RepoType+srpTypeLens f s = fmap (\x -> s { srpType = x }) (f (srpType s))+{-# INLINE srpTypeLens #-}++srpLocationLens :: Lens' (SourceRepositoryPackage f) String+srpLocationLens f s = fmap (\x -> s { srpLocation = x }) (f (srpLocation s))+{-# INLINE srpLocationLens #-}++srpTagLens :: Lens' (SourceRepositoryPackage f) (Maybe String)+srpTagLens f s = fmap (\x -> s { srpTag = x }) (f (srpTag s))+{-# INLINE srpTagLens #-}++srpBranchLens :: Lens' (SourceRepositoryPackage f) (Maybe String)+srpBranchLens f s = fmap (\x -> s { srpBranch = x }) (f (srpBranch s))+{-# INLINE srpBranchLens #-}++srpSubdirLens :: Lens (SourceRepositoryPackage f) (SourceRepositoryPackage g) (f FilePath) (g FilePath)+srpSubdirLens f s = fmap (\x -> s { srpSubdir = x }) (f (srpSubdir s))+{-# INLINE srpSubdirLens #-}++-------------------------------------------------------------------------------+-- Parser & PPrinter+-------------------------------------------------------------------------------++sourceRepositoryPackageGrammar+ :: (FieldGrammar g, Applicative (g SourceRepoList))+ => g SourceRepoList SourceRepoList+sourceRepositoryPackageGrammar = SourceRepositoryPackage+ <$> uniqueField "type" srpTypeLens+ <*> uniqueFieldAla "location" Token srpLocationLens+ <*> optionalFieldAla "tag" Token srpTagLens+ <*> optionalFieldAla "branch" Token srpBranchLens+ <*> monoidalFieldAla "subdir" (alaList' NoCommaFSep FilePathNT) srpSubdirLens -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there...+{-# SPECIALIZE sourceRepositoryPackageGrammar :: ParsecFieldGrammar' SourceRepoList #-}+{-# SPECIALIZE sourceRepositoryPackageGrammar :: PrettyFieldGrammar' SourceRepoList #-}
− Distribution/Client/SourceRepoParse.hs
@@ -1,23 +0,0 @@-module Distribution.Client.SourceRepoParse where--import Distribution.Client.Compat.Prelude-import Prelude ()--import Distribution.Deprecated.ParseUtils (FieldDescr (..), syntaxError)-import Distribution.FieldGrammar.FieldDescrs (fieldDescrsToList)-import Distribution.PackageDescription.FieldGrammar (sourceRepoFieldGrammar)-import Distribution.Parsec (explicitEitherParsec)-import Distribution.Simple.Utils (fromUTF8BS)-import Distribution.Types.SourceRepo (RepoKind (..), SourceRepo)--sourceRepoFieldDescrs :: [FieldDescr SourceRepo]-sourceRepoFieldDescrs =- map toDescr . fieldDescrsToList $ sourceRepoFieldGrammar (RepoKindUnknown "unused")- where- toDescr (name, pretty, parse) = FieldDescr- { fieldName = fromUTF8BS name- , fieldGet = pretty- , fieldSet = \lineNo str x ->- either (syntaxError lineNo) return- $ explicitEitherParsec (parse x) str- }
Distribution/Client/Store.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}+{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-} -- | Management for the installed package store.@@ -23,7 +23,6 @@ import Prelude () import Distribution.Client.Compat.Prelude-import Distribution.Client.Compat.FileLock import Distribution.Client.DistDirLayout import Distribution.Client.RebuildMonad@@ -36,14 +35,21 @@ import Distribution.Verbosity import Distribution.Deprecated.Text -import Data.Set (Set) import qualified Data.Set as Set import Control.Exception import Control.Monad (forM_) import System.FilePath import System.Directory-import System.IO +#ifdef MIN_VERSION_lukko+import Lukko+#else+import System.IO (openFile, IOMode(ReadWriteMode), hClose)+import GHC.IO.Handle.Lock (hLock, hTryLock, LockMode(ExclusiveLock))+#if MIN_VERSION_base(4,11,0)+import GHC.IO.Handle.Lock (hUnlock)+#endif+#endif -- $concurrency --@@ -236,6 +242,26 @@ compid unitid action = bracket takeLock releaseLock (\_hnd -> action) where+#ifdef MIN_VERSION_lukko+ takeLock+ | fileLockingSupported = do+ fd <- fdOpen (storeIncomingLock compid unitid)+ gotLock <- fdTryLock fd ExclusiveLock+ unless gotLock $ do+ info verbosity $ "Waiting for file lock on store entry "+ ++ display compid </> display unitid+ fdLock fd ExclusiveLock+ return fd++ -- if there's no locking, do nothing. Be careful on AIX.+ | otherwise = return undefined -- :(++ releaseLock fd+ | fileLockingSupported = do+ fdUnlock fd+ fdClose fd+ | otherwise = return ()+#else takeLock = do h <- openFile (storeIncomingLock compid unitid) ReadWriteMode -- First try non-blocking, but if we would have to wait then@@ -247,5 +273,5 @@ hLock h ExclusiveLock return h - releaseLock = hClose-+ releaseLock h = hUnlock h >> hClose h+#endif
Distribution/Client/TargetSelector.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor, RecordWildCards, NamedFieldPuns #-}+-- TODO+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.TargetSelector@@ -78,6 +80,7 @@ ( on ) import Data.List ( stripPrefix, partition, groupBy )+import qualified Data.List.NonEmpty as NE import Data.Ord ( comparing ) import qualified Data.Map.Lazy as Map.Lazy@@ -191,6 +194,7 @@ deriving (Eq, Ord, Show, Generic) instance Binary SubComponentTarget+instance Structured SubComponentTarget -- ------------------------------------------------------------@@ -502,9 +506,9 @@ projectIsEmpty = null knownPackagesAll classifyMatchErrors errs- | not (null expected)- = let (things, got:_) = unzip expected in- TargetSelectorExpected targetStr things got+ | Just expectedNE <- NE.nonEmpty expected+ = let (things, got:|_) = NE.unzip expectedNE in+ TargetSelectorExpected targetStr (NE.toList things) got | not (null nosuch) = TargetSelectorNoSuch targetStr nosuch
Distribution/Client/Targets.hs view
@@ -669,6 +669,7 @@ deriving (Eq, Show, Generic) instance Binary UserQualifier+instance Structured UserQualifier -- | Version of 'ConstraintScope' that a user may specify on the -- command line.@@ -684,6 +685,7 @@ deriving (Eq, Show, Generic) instance Binary UserConstraintScope+instance Structured UserConstraintScope fromUserQualifier :: UserQualifier -> Qualifier fromUserQualifier UserQualToplevel = QualToplevel@@ -703,6 +705,7 @@ deriving (Eq, Show, Generic) instance Binary UserConstraint+instance Structured UserConstraint userConstraintPackageName :: UserConstraint -> PackageName userConstraintPackageName (UserConstraint scope _) = scopePN scope
Distribution/Client/Types.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Client.Types@@ -48,8 +47,9 @@ ( ComponentName(..) ) import Distribution.Types.LibraryName ( LibraryName(..) )-import Distribution.Types.SourceRepo- ( SourceRepo )+import Distribution.Client.SourceRepo+ ( SourceRepoMaybe )+import Distribution.Client.HashValue (showHashValue, hashValue, truncateHash) import Distribution.Solver.Types.PackageIndex ( PackageIndex )@@ -65,13 +65,14 @@ import Distribution.Compat.Graph (IsNode(..)) import qualified Distribution.Deprecated.ReadP as Parse import Distribution.Deprecated.ParseUtils (parseOptCommaList)-import Distribution.Simple.Utils (ordNub)+import Distribution.Simple.Utils (ordNub, toUTF8BS) import Distribution.Deprecated.Text (Text(..)) -import Network.URI (URI(..), URIAuth(..), nullURI)-import Control.Exception- ( Exception, SomeException )+import Network.URI (URI(..), nullURI)+import Control.Exception (Exception, SomeException)+ import qualified Text.PrettyPrint as Disp+import qualified Data.ByteString.Lazy.Char8 as LBS newtype Username = Username { unUsername :: String }@@ -172,6 +173,7 @@ } instance Binary ConfiguredId+instance Structured ConfiguredId instance Show ConfiguredId where show cid = show (confInstId cid)@@ -241,6 +243,7 @@ deriving (Eq, Show, Functor, Generic) instance Binary pkg => Binary (PackageSpecifier pkg)+instance Structured pkg => Structured (PackageSpecifier pkg) pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName pkgSpecifierTarget (NamedPackage name _) = name@@ -287,21 +290,11 @@ | RepoTarballPackage Repo PackageId local -- | A package available from a version control system source repository- | RemoteSourceRepoPackage SourceRepo local+ | RemoteSourceRepoPackage SourceRepoMaybe local deriving (Show, Functor, Eq, Ord, Generic, Typeable) instance Binary local => Binary (PackageLocation local)---- note, network-uri-2.6.0.3+ provide a Generic instance but earlier--- versions do not, so we use manual Binary instances here-instance Binary URI where- put (URI a b c d e) = do put a; put b; put c; put d; put e- get = do !a <- get; !b <- get; !c <- get; !d <- get; !e <- get- return (URI a b c d e)--instance Binary URIAuth where- put (URIAuth a b c) = do put a; put b; put c- get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c)+instance Structured local => Structured (PackageLocation local) data RemoteRepo = RemoteRepo {@@ -334,11 +327,40 @@ deriving (Show, Eq, Ord, Generic) instance Binary RemoteRepo+instance Structured RemoteRepo -- | Construct a partial 'RemoteRepo' value to fold the field parser list over. emptyRemoteRepo :: String -> RemoteRepo emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False +-- | /no-index/ style local repositories.+--+-- https://github.com/haskell/cabal/issues/6359+data LocalRepo = LocalRepo+ { localRepoName :: String+ , localRepoPath :: FilePath+ , localRepoSharedCache :: Bool+ }+ deriving (Show, Eq, Ord, Generic)++instance Binary LocalRepo+instance Structured LocalRepo++-- | Construct a partial 'LocalRepo' value to fold the field parser list over.+emptyLocalRepo :: String -> LocalRepo+emptyLocalRepo name = LocalRepo name "" False++-- | Calculate a cache key for local-repo.+--+-- For remote repositories we just use name, but local repositories may+-- all be named "local", so we add a bit of `localRepoPath` into the+-- mix.+localRepoCacheKey :: LocalRepo -> String+localRepoCacheKey local = localRepoName local ++ "-" ++ hashPart where+ hashPart+ = showHashValue $ truncateHash 8 $ hashValue+ $ LBS.fromStrict $ toUTF8BS $ localRepoPath local+ -- | Different kinds of repositories -- -- NOTE: It is important that this type remains serializable.@@ -347,6 +369,14 @@ RepoLocal { repoLocalDir :: FilePath }+ + -- | Local repository, without index.+ --+ -- https://github.com/haskell/cabal/issues/6359+ | RepoLocalNoIndex+ { repoLocal :: LocalRepo+ , repoLocalDir :: FilePath+ } -- | Standard (unsecured) remote repositores | RepoRemote {@@ -369,17 +399,20 @@ deriving (Show, Eq, Ord, Generic) instance Binary Repo+instance Structured Repo -- | Check if this is a remote repo isRepoRemote :: Repo -> Bool-isRepoRemote RepoLocal{} = False-isRepoRemote _ = True+isRepoRemote RepoLocal{} = False+isRepoRemote RepoLocalNoIndex{} = False+isRepoRemote _ = True -- | Extract @RemoteRepo@ from @Repo@ if remote. maybeRepoRemote :: Repo -> Maybe RemoteRepo-maybeRepoRemote (RepoLocal _localDir) = Nothing-maybeRepoRemote (RepoRemote r _localDir) = Just r-maybeRepoRemote (RepoSecure r _localDir) = Just r+maybeRepoRemote (RepoLocal _localDir) = Nothing+maybeRepoRemote (RepoLocalNoIndex _ _localDir) = Nothing+maybeRepoRemote (RepoRemote r _localDir) = Just r+maybeRepoRemote (RepoSecure r _localDir) = Just r -- ------------------------------------------------------------ -- * Build results@@ -423,11 +456,10 @@ instance Binary DocsResult instance Binary TestsResult ---FIXME: this is a total cheat-instance Binary SomeException where- put _ = return ()- get = fail "cannot serialise exceptions"-+instance Structured BuildFailure+instance Structured BuildResult+instance Structured DocsResult+instance Structured TestsResult -- ------------------------------------------------------------ -- * --allow-newer/--allow-older@@ -554,6 +586,14 @@ instance Binary AllowNewer instance Binary AllowOlder +instance Structured RelaxDeps+instance Structured RelaxDepMod+instance Structured RelaxDepScope+instance Structured RelaxDepSubject+instance Structured RelaxedDep+instance Structured AllowNewer+instance Structured AllowOlder+ -- | Return 'True' if 'RelaxDeps' specifies a non-empty set of relaxations -- -- Equivalent to @isRelaxDeps = (/= 'mempty')@@@ -607,3 +647,4 @@ deriving (Eq, Enum, Bounded, Generic, Show) instance Binary WriteGhcEnvironmentFilesPolicy+instance Structured WriteGhcEnvironmentFilesPolicy
Distribution/Client/Update.hs view
@@ -74,6 +74,7 @@ transport <- repoContextGetTransport repoCtxt case repo of RepoLocal{..} -> return ()+ RepoLocalNoIndex{..} -> return () RepoRemote{..} -> do downloadResult <- downloadIndex transport verbosity repoRemote repoLocalDir case downloadResult of
Distribution/Client/Utils/Parsec.hs view
@@ -16,7 +16,7 @@ renderParseError :: FilePath -> BS.ByteString- -> [PError]+ -> NonEmpty PError -> [PWarning] -> String renderParseError filepath contents errors warnings = unlines $
Distribution/Client/VCS.hs view
@@ -1,20 +1,16 @@-{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-} 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+ validatePDSourceRepo, validateSourceRepo, validateSourceRepos, SourceRepoProblem(..),@@ -38,7 +34,8 @@ import Distribution.Client.Compat.Prelude import Distribution.Types.SourceRepo- ( SourceRepo(..), RepoType(..), RepoKind(..) )+ ( RepoType(..) )+import Distribution.Client.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy) import Distribution.Client.RebuildMonad ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence ) import Distribution.Verbosity as Verbosity@@ -51,6 +48,7 @@ , emptyProgramDb, requireProgram ) import Distribution.Version ( mkVersion )+import qualified Distribution.PackageDescription as PD import Control.Monad ( mapM_ )@@ -58,8 +56,6 @@ ( liftIO ) import qualified Data.Char as Char import qualified Data.Map as Map-import Data.Ord- ( comparing ) import Data.Either ( partitionEithers ) import System.FilePath@@ -80,9 +76,9 @@ -- | The program invocation(s) to get\/clone a repository into a fresh -- local directory.- vcsCloneRepo :: Verbosity+ vcsCloneRepo :: forall f. Verbosity -> ConfiguredProgram- -> SourceRepo+ -> SourceRepositoryPackage f -> FilePath -- Source URI -> FilePath -- Destination directory -> [ProgramInvocation],@@ -90,9 +86,9 @@ -- | 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+ vcsSyncRepos :: forall f. Verbosity -> ConfiguredProgram- -> [(SourceRepo, FilePath)]+ -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] } @@ -101,37 +97,8 @@ -- * 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+ | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType | SourceRepoLocationUnspecified deriving Show @@ -140,25 +107,42 @@ -- -- | It also returns the 'VCS' driver we should use to work with it. ---validateSourceRepo :: SourceRepo- -> Either SourceRepoProblem- (SourceRepo, String, RepoType, VCS Program)+validateSourceRepo+ :: SourceRepositoryPackage f+ -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program) validateSourceRepo = \repo -> do- rtype <- repoType repo ?! SourceRepoRepoTypeUnspecified- vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported rtype- uri <- repoLocation repo ?! SourceRepoLocationUnspecified+ let rtype = srpType repo+ vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype+ let uri = srpLocation repo return (repo, uri, rtype, vcs) where a ?! e = maybe (Left e) Right a +validatePDSourceRepo+ :: PD.SourceRepo+ -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program)+validatePDSourceRepo repo = do+ rtype <- PD.repoType repo ?! SourceRepoRepoTypeUnspecified+ uri <- PD.repoLocation repo ?! SourceRepoLocationUnspecified+ validateSourceRepo SourceRepositoryPackage+ { srpType = rtype+ , srpLocation = uri+ , srpTag = PD.repoTag repo+ , srpBranch = PD.repoBranch repo+ , srpSubdir = PD.repoSubdir repo+ }+ 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 :: [SourceRepositoryPackage f]+ -> Either [(SourceRepositoryPackage f, SourceRepoProblem)]+ [(SourceRepositoryPackage f, String, RepoType, VCS Program)] validateSourceRepos rs = case partitionEithers (map validateSourceRepo' rs) of (problems@(_:_), _) -> Left problems@@ -193,17 +177,15 @@ -- -- 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 ConfiguredProgram+ -> SourceRepositoryPackage f+ -> [Char]+ -> IO () cloneSourceRepo verbosity vcs- repo@SourceRepo{ repoLocation = Just srcuri } destdir =+ repo@SourceRepositoryPackage{ srpLocation = srcuri } destdir = mapM_ (runProgramInvocation verbosity) invocations where invocations = vcsCloneRepo vcs verbosity@@ -228,7 +210,7 @@ -- syncSourceRepos :: Verbosity -> VCS ConfiguredProgram- -> [(SourceRepo, FilePath)]+ -> [(SourceRepositoryPackage f, FilePath)] -> Rebuild () syncSourceRepos verbosity vcs repos = do files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos@@ -260,7 +242,7 @@ where vcsCloneRepo :: Verbosity -> ConfiguredProgram- -> SourceRepo+ -> SourceRepositoryPackage f -> FilePath -> FilePath -> [ProgramInvocation]@@ -274,13 +256,13 @@ = "branch" | otherwise = "get" - tagArgs = case repoTag repo of+ tagArgs = case srpTag repo of Nothing -> [] Just tag -> ["-r", "tag:" ++ tag] verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] vcsSyncRepos :: Verbosity -> ConfiguredProgram- -> [(SourceRepo, FilePath)] -> IO [MonitorFilePath]+ -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr" bzrProgram :: Program@@ -306,7 +288,7 @@ where vcsCloneRepo :: Verbosity -> ConfiguredProgram- -> SourceRepo+ -> SourceRepositoryPackage f -> FilePath -> FilePath -> [ProgramInvocation]@@ -319,13 +301,13 @@ cloneCmd | programVersion prog >= Just (mkVersion [2,8]) = "clone" | otherwise = "get"- tagArgs = case repoTag repo of+ tagArgs = case srpTag repo of Nothing -> [] Just tag -> ["-t", tag] verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] vcsSyncRepos :: Verbosity -> ConfiguredProgram- -> [(SourceRepo, FilePath)] -> IO [MonitorFilePath]+ -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for darcs" darcsProgram :: Program@@ -351,7 +333,7 @@ where vcsCloneRepo :: Verbosity -> ConfiguredProgram- -> SourceRepo+ -> SourceRepositoryPackage f -> FilePath -> FilePath -> [ProgramInvocation]@@ -361,11 +343,11 @@ ++ [ (programInvocation prog (checkoutArgs tag)) { progInvokeCwd = Just destdir }- | tag <- maybeToList (repoTag repo) ]+ | tag <- maybeToList (srpTag repo) ] where cloneArgs = ["clone", srcuri, destdir] ++ branchArgs ++ verboseArg- branchArgs = case repoBranch repo of+ branchArgs = case srpBranch repo of Just b -> ["--branch", b] Nothing -> [] checkoutArgs tag = "checkout" : verboseArg ++ [tag, "--"]@@ -373,7 +355,7 @@ vcsSyncRepos :: Verbosity -> ConfiguredProgram- -> [(SourceRepo, FilePath)]+ -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] vcsSyncRepos _ _ [] = return [] vcsSyncRepos verbosity gitProg@@ -383,10 +365,10 @@ sequence_ [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir) | (repo, localDir) <- secondaryRepos ]- return [ monitorDirectoryExistence dir + return [ monitorDirectoryExistence dir | dir <- (primaryLocalDir : map snd secondaryRepos) ] - vcsSyncRepo verbosity gitProg SourceRepo{..} localDir peer = do+ vcsSyncRepo verbosity gitProg SourceRepositoryPackage{..} localDir peer = do exists <- doesDirectoryExist localDir if exists then git localDir ["fetch"]@@ -404,10 +386,10 @@ Nothing -> [] Just peerLocalDir -> ["--reference", peerLocalDir] ++ verboseArg- where Just loc = repoLocation+ where loc = srpLocation checkoutArgs = "checkout" : verboseArg ++ ["--detach", "--force" , checkoutTarget, "--" ]- checkoutTarget = fromMaybe "HEAD" (repoBranch `mplus` repoTag)+ checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] gitProgram :: Program@@ -444,7 +426,7 @@ where vcsCloneRepo :: Verbosity -> ConfiguredProgram- -> SourceRepo+ -> SourceRepositoryPackage f -> FilePath -> FilePath -> [ProgramInvocation]@@ -453,17 +435,17 @@ where cloneArgs = ["clone", srcuri, destdir] ++ branchArgs ++ tagArgs ++ verboseArg- branchArgs = case repoBranch repo of+ branchArgs = case srpBranch repo of Just b -> ["--branch", b] Nothing -> []- tagArgs = case repoTag repo of+ tagArgs = case srpTag repo of Just t -> ["--rev", t] Nothing -> [] verboseArg = [ "--quiet" | verbosity < Verbosity.normal ] vcsSyncRepos :: Verbosity -> ConfiguredProgram- -> [(SourceRepo, FilePath)]+ -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg" @@ -490,7 +472,7 @@ where vcsCloneRepo :: Verbosity -> ConfiguredProgram- -> SourceRepo+ -> SourceRepositoryPackage f -> FilePath -> FilePath -> [ProgramInvocation]@@ -503,7 +485,7 @@ vcsSyncRepos :: Verbosity -> ConfiguredProgram- -> [(SourceRepo, FilePath)]+ -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath] vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn"
Distribution/Deprecated/Text.hs view
@@ -28,7 +28,6 @@ import Distribution.Deprecated.ReadP ((<++)) import qualified Distribution.Deprecated.ReadP as Parse -import Data.Functor.Identity (Identity (..)) import Distribution.Parsec import Distribution.Pretty import qualified Text.PrettyPrint as Disp
Distribution/Deprecated/ViewAsFieldDescr.hs view
@@ -5,6 +5,7 @@ import Distribution.Client.Compat.Prelude hiding (get) import Prelude () +import qualified Data.List.NonEmpty as NE import Distribution.Parsec (parsec) import Distribution.Pretty import Distribution.ReadE (parsecToReadE)@@ -19,10 +20,10 @@ viewAsFieldDescr :: OptionField a -> FieldDescr a viewAsFieldDescr (OptionField _n []) = error "Distribution.command.viewAsFieldDescr: unexpected"-viewAsFieldDescr (OptionField n dd) = FieldDescr n get set+viewAsFieldDescr (OptionField n (d:dd)) = FieldDescr n get set where- optDescr = head $ sortBy cmp dd+ optDescr = head $ NE.sortBy cmp (d:|dd) cmp :: OptDescr a -> OptDescr a -> Ordering ReqArg{} `cmp` ReqArg{} = EQ
Distribution/Solver/Modular.hs view
@@ -16,7 +16,7 @@ import Distribution.Solver.Compat.Prelude import qualified Data.Map as M-import Data.Set (Set, isSubsetOf)+import Data.Set (isSubsetOf) import Data.Ord import Distribution.Compat.Graph ( IsNode(..) )
Distribution/Solver/Modular/Builder.hs view
@@ -145,7 +145,9 @@ -- and then handle each instance in turn. addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) = case M.lookup pn idx of- Nothing -> FailF (varToConflictSet (P qpn) `CS.union` goalReasonToCS gr) UnknownPackage+ Nothing -> FailF+ (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr)+ UnknownPackage Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) -> ([], POption i Nothing, bs { next = Instance qpn info })) (M.toList pis)))
Distribution/Solver/Modular/ConfiguredConversion.hs view
@@ -45,7 +45,7 @@ solverPkgExeDeps = fmap snd ds' } where- Just srcpkg = CI.lookupPackageId sidx pi+ srcpkg = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi where ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -}) ds' = fmap (partitionEithers . map convConfId) ds
Distribution/Solver/Modular/ConflictSet.hs view
@@ -10,7 +10,9 @@ -- > import qualified Distribution.Solver.Modular.ConflictSet as CS module Distribution.Solver.Modular.ConflictSet ( ConflictSet -- opaque+ , Conflict(..) , ConflictMap+ , OrderedVersionRange(..) #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin #endif@@ -26,19 +28,21 @@ , delete , empty , singleton+ , singletonWithConflict , size , member+ , lookup , filter , fromList ) where -import Prelude hiding (filter)+import Prelude hiding (lookup) import Data.List (intercalate, sortBy) import Data.Map (Map) import Data.Set (Set) import Data.Function (on)+import qualified Data.Map.Strict as M import qualified Data.Set as S-import qualified Data.Map as M #ifdef DEBUG_CONFLICT_SETS import Data.Tree@@ -46,15 +50,14 @@ #endif import Distribution.Solver.Modular.Var+import Distribution.Solver.Modular.Version import Distribution.Solver.Types.PackagePath --- | The set of variables involved in a solver conflict------ Since these variables should be preprocessed in some way, this type is--- kept abstract.+-- | The set of variables involved in a solver conflict, each paired with+-- details about the conflict. data ConflictSet = CS {- -- | The set of variables involved on the conflict- conflictSetToSet :: !(Set (Var QPN))+ -- | The set of variables involved in the conflict+ conflictSetToMap :: !(Map (Var QPN) (Set Conflict)) #ifdef DEBUG_CONFLICT_SETS -- | The origin of the conflict set@@ -72,11 +75,48 @@ } deriving (Show) +-- | More detailed information about how a conflict set variable caused a+-- conflict. This information can be used to determine whether a second value+-- for that variable would lead to the same conflict.+--+-- TODO: Handle dependencies under flags or stanzas.+data Conflict =++ -- | The conflict set variable represents a package which depends on the+ -- specified problematic package. For example, the conflict set entry+ -- '(P x, GoalConflict y)' means that package x introduced package y, and y+ -- led to a conflict.+ GoalConflict QPN++ -- | The conflict set variable represents a package with a constraint that+ -- excluded the specified package and version. For example, the conflict set+ -- entry '(P x, VersionConstraintConflict y (mkVersion [2, 0]))' means that+ -- package x's constraint on y excluded y-2.0.+ | VersionConstraintConflict QPN Ver++ -- | The conflict set variable represents a package that was excluded by a+ -- constraint from the specified package. For example, the conflict set+ -- entry '(P x, VersionConflict y (orLaterVersion (mkVersion [2, 0])))'+ -- means that package y's constraint 'x >= 2.0' excluded some version of x.+ | VersionConflict QPN OrderedVersionRange++ -- | Any other conflict.+ | OtherConflict+ deriving (Eq, Ord, Show)++-- | Version range with an 'Ord' instance.+newtype OrderedVersionRange = OrderedVersionRange VR+ deriving (Eq, Show)++-- TODO: Avoid converting the version ranges to strings.+instance Ord OrderedVersionRange where+ compare = compare `on` show+ instance Eq ConflictSet where- (==) = (==) `on` conflictSetToSet+ (==) = (==) `on` conflictSetToMap instance Ord ConflictSet where- compare = compare `on` conflictSetToSet+ compare = compare `on` conflictSetToMap showConflictSet :: ConflictSet -> String showConflictSet = intercalate ", " . map showVar . toList@@ -102,10 +142,10 @@ -------------------------------------------------------------------------------} toSet :: ConflictSet -> Set (Var QPN)-toSet = conflictSetToSet+toSet = M.keysSet . conflictSetToMap toList :: ConflictSet -> [Var QPN]-toList = S.toList . conflictSetToSet+toList = M.keys . conflictSetToMap union :: #ifdef DEBUG_CONFLICT_SETS@@ -113,7 +153,7 @@ #endif ConflictSet -> ConflictSet -> ConflictSet union cs cs' = CS {- conflictSetToSet = S.union (conflictSetToSet cs) (conflictSetToSet cs')+ conflictSetToMap = M.unionWith S.union (conflictSetToMap cs) (conflictSetToMap cs') #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc (map conflictSetOrigin [cs, cs']) #endif@@ -125,7 +165,7 @@ #endif [ConflictSet] -> ConflictSet unions css = CS {- conflictSetToSet = S.unions (map conflictSetToSet css)+ conflictSetToMap = M.unionsWith S.union (map conflictSetToMap css) #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc (map conflictSetOrigin css) #endif@@ -137,7 +177,7 @@ #endif Var QPN -> ConflictSet -> ConflictSet insert var cs = CS {- conflictSetToSet = S.insert var (conflictSetToSet cs)+ conflictSetToMap = M.insert var (S.singleton OtherConflict) (conflictSetToMap cs) #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [conflictSetOrigin cs] #endif@@ -145,7 +185,7 @@ delete :: Var QPN -> ConflictSet -> ConflictSet delete var cs = CS {- conflictSetToSet = S.delete var (conflictSetToSet cs)+ conflictSetToMap = M.delete var (conflictSetToMap cs) } empty ::@@ -154,7 +194,7 @@ #endif ConflictSet empty = CS {- conflictSetToSet = S.empty+ conflictSetToMap = M.empty #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [] #endif@@ -165,30 +205,28 @@ (?loc :: CallStack) => #endif Var QPN -> ConflictSet-singleton var = CS {- conflictSetToSet = S.singleton var+singleton var = singletonWithConflict var OtherConflict++singletonWithConflict :: #ifdef DEBUG_CONFLICT_SETS+ (?loc :: CallStack) =>+#endif+ Var QPN -> Conflict -> ConflictSet+singletonWithConflict var conflict = CS {+ conflictSetToMap = M.singleton var (S.singleton conflict)+#ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [] #endif } size :: ConflictSet -> Int-size = S.size . conflictSetToSet+size = M.size . conflictSetToMap member :: Var QPN -> ConflictSet -> Bool-member var = S.member var . conflictSetToSet+member var = M.member var . conflictSetToMap -filter ::-#ifdef DEBUG_CONFLICT_SETS- (?loc :: CallStack) =>-#endif- (Var QPN -> Bool) -> ConflictSet -> ConflictSet-filter p cs = CS {- conflictSetToSet = S.filter p (conflictSetToSet cs)-#ifdef DEBUG_CONFLICT_SETS- , conflictSetOrigin = Node ?loc [conflictSetOrigin cs]-#endif- }+lookup :: Var QPN -> ConflictSet -> Maybe (Set Conflict)+lookup var = M.lookup var . conflictSetToMap fromList :: #ifdef DEBUG_CONFLICT_SETS@@ -196,7 +234,7 @@ #endif [Var QPN] -> ConflictSet fromList vars = CS {- conflictSetToSet = S.fromList vars+ conflictSetToMap = M.fromList [(var, S.singleton OtherConflict) | var <- vars] #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin = Node ?loc [] #endif
Distribution/Solver/Modular/Dependency.hs view
@@ -32,8 +32,11 @@ , QGoalReason , goalToVar , varToConflictSet- , goalReasonToCS- , dependencyReasonToCS+ , goalReasonToConflictSet+ , goalReasonToConflictSetWithConflict+ , dependencyReasonToConflictSet+ , dependencyReasonToConflictSetWithVersionConstraintConflict+ , dependencyReasonToConflictSetWithVersionConflict ) where import Prelude ()@@ -279,14 +282,30 @@ varToConflictSet :: Var QPN -> ConflictSet varToConflictSet = CS.singleton -goalReasonToCS :: GoalReason QPN -> ConflictSet-goalReasonToCS UserGoal = CS.empty-goalReasonToCS (DependencyGoal dr) = dependencyReasonToCS dr+-- | Convert a 'GoalReason' to a 'ConflictSet' that can be used when the goal+-- leads to a conflict.+goalReasonToConflictSet :: GoalReason QPN -> ConflictSet+goalReasonToConflictSet UserGoal = CS.empty+goalReasonToConflictSet (DependencyGoal dr) = dependencyReasonToConflictSet dr +-- | Convert a 'GoalReason' to a 'ConflictSet' containing the reason that the+-- conflict occurred, namely the conflict set variables caused a conflict by+-- introducing the given package goal. See the documentation for 'GoalConflict'.+--+-- This function currently only specifies the reason for the conflict in the+-- simple case where the 'GoalReason' does not involve any flags or stanzas.+-- Otherwise, it falls back to calling 'goalReasonToConflictSet'.+goalReasonToConflictSetWithConflict :: QPN -> GoalReason QPN -> ConflictSet+goalReasonToConflictSetWithConflict goal (DependencyGoal (DependencyReason qpn flags stanzas))+ | M.null flags && S.null stanzas =+ CS.singletonWithConflict (P qpn) $ CS.GoalConflict goal+goalReasonToConflictSetWithConflict _ gr = goalReasonToConflictSet gr+ -- | This function returns the solver variables responsible for the dependency.--- It drops the flag and stanza values, which are only needed for log messages.-dependencyReasonToCS :: DependencyReason QPN -> ConflictSet-dependencyReasonToCS (DependencyReason qpn flags stanzas) =+-- It drops the values chosen for flag and stanza variables, which are only+-- needed for log messages.+dependencyReasonToConflictSet :: DependencyReason QPN -> ConflictSet+dependencyReasonToConflictSet (DependencyReason qpn flags stanzas) = CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas) where -- Filter out any flags that introduced the dependency with both values.@@ -297,3 +316,40 @@ stanzaToVar :: Stanza -> Var QPN stanzaToVar = S . SN qpn++-- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the+-- conflict occurred because the conflict set variables introduced a problematic+-- version constraint. See the documentation for 'VersionConstraintConflict'.+--+-- This function currently only specifies the reason for the conflict in the+-- simple case where the 'DependencyReason' does not involve any flags or+-- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'.+dependencyReasonToConflictSetWithVersionConstraintConflict :: QPN+ -> Ver+ -> DependencyReason QPN+ -> ConflictSet+dependencyReasonToConflictSetWithVersionConstraintConflict+ dependency excludedVersion dr@(DependencyReason qpn flags stanzas)+ | M.null flags && S.null stanzas =+ CS.singletonWithConflict (P qpn) $+ CS.VersionConstraintConflict dependency excludedVersion+ | otherwise = dependencyReasonToConflictSet dr++-- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the+-- conflict occurred because the conflict set variables introduced a version of+-- a package that was excluded by a version constraint. See the documentation+-- for 'VersionConflict'.+--+-- This function currently only specifies the reason for the conflict in the+-- simple case where the 'DependencyReason' does not involve any flags or+-- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'.+dependencyReasonToConflictSetWithVersionConflict :: QPN+ -> CS.OrderedVersionRange+ -> DependencyReason QPN+ -> ConflictSet+dependencyReasonToConflictSetWithVersionConflict+ pkgWithVersionConstraint constraint dr@(DependencyReason qpn flags stanzas)+ | M.null flags && S.null stanzas =+ CS.singletonWithConflict (P qpn) $+ CS.VersionConflict pkgWithVersionConstraint constraint+ | otherwise = dependencyReasonToConflictSet dr
Distribution/Solver/Modular/Explore.hs view
@@ -7,19 +7,28 @@ import Data.Foldable as F import Data.List as L (foldl')+import Data.Maybe (fromMaybe) import Data.Map.Strict as M+import Data.Set as S +import Distribution.Simple.Setup (asBool)+ import Distribution.Solver.Modular.Assignment import Distribution.Solver.Modular.Dependency+import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Log import Distribution.Solver.Modular.Message+import Distribution.Solver.Modular.Package import qualified Distribution.Solver.Modular.PSQ as P import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.RetryLog import Distribution.Solver.Modular.Tree+import Distribution.Solver.Modular.Version import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.PackagePath-import Distribution.Solver.Types.Settings (EnableBackjumping(..), CountConflicts(..))+import Distribution.Solver.Types.Settings+ (CountConflicts(..), EnableBackjumping(..), FineGrainedConflicts(..))+import Distribution.Types.VersionRange (anyVersion) -- | This function takes the variable we're currently considering, a -- last conflict set and a list of children's logs. Each log yields@@ -43,25 +52,70 @@ -- with the (virtual) option not to choose anything for the current -- variable. See also the comments for 'avoidSet'. ---backjump :: Maybe Int -> EnableBackjumping -> Var QPN- -> ConflictSet -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a)+-- We can also skip a child if it does not resolve any of the conflicts paired+-- with the current variable in the previous child's conflict set. 'backjump'+-- takes a function to determine whether a child can be skipped. If the child+-- can be skipped, the function returns a new conflict set to be merged with the+-- previous conflict set.+--+backjump :: forall w k a . Maybe Int+ -> EnableBackjumping+ -> FineGrainedConflicts++ -> (k -> S.Set CS.Conflict -> Maybe ConflictSet)+ -- ^ Function that determines whether the given choice could resolve+ -- the given conflict. It indicates false by returning 'Just',+ -- with the new conflicts to be added to the conflict set.++ -> (k -> ConflictSet -> ExploreState -> ConflictSetLog a)+ -- ^ Function that logs the given choice that was skipped.++ -> Var QPN -- ^ The current variable.++ -> ConflictSet -- ^ Conflict set representing the reason that the goal+ -- was introduced.++ -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a)+ -- ^ List of children's logs.+ -> ExploreState -> ConflictSetLog a-backjump mbj (EnableBackjumping enableBj) var lastCS xs =- F.foldr combine avoidGoal xs CS.empty+backjump mbj enableBj fineGrainedConflicts couldResolveConflicts+ logSkippedChoice var lastCS xs =+ F.foldr combine avoidGoal [(k, v) | (_, k, v) <- W.toList xs] CS.empty Nothing where- combine :: forall a . (ExploreState -> ConflictSetLog a)- -> (ConflictSet -> ExploreState -> ConflictSetLog a)- -> ConflictSet -> ExploreState -> ConflictSetLog a- combine x f csAcc es = retryNoSolution (x es) next+ combine :: (k, ExploreState -> ConflictSetLog a)+ -> (ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a)+ -> ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a+ combine (k, x) f csAcc mPreviousCS es =+ case (asBool fineGrainedConflicts, mPreviousCS) of+ (True, Just previousCS) ->+ case CS.lookup var previousCS of+ Just conflicts ->+ case couldResolveConflicts k conflicts of+ Nothing -> retryNoSolution (x es) next+ Just newConflicts -> skipChoice (previousCS `CS.union` newConflicts)+ _ -> skipChoice previousCS+ _ -> retryNoSolution (x es) next where next :: ConflictSet -> ExploreState -> ConflictSetLog a- next !cs es' = if enableBj && not (var `CS.member` cs)+ next !cs es' = if asBool enableBj && not (var `CS.member` cs) then skipLoggingBackjump cs es'- else f (csAcc `CS.union` cs) es'+ else f (csAcc `CS.union` cs) (Just cs) es' + -- This function is for skipping the choice when it cannot resolve any+ -- of the previous conflicts.+ skipChoice :: ConflictSet -> ConflictSetLog a+ skipChoice newCS =+ retryNoSolution (logSkippedChoice k newCS es) $ \cs' es' ->+ f (csAcc `CS.union` cs') (Just cs') $++ -- Update the conflict map with the conflict set, to make up for+ -- skipping the whole subtree.+ es' { esConflictMap = updateCM cs' (esConflictMap es') }+ -- This function represents the option to not choose a value for this goal.- avoidGoal :: ConflictSet -> ExploreState -> ConflictSetLog a- avoidGoal cs !es =+ avoidGoal :: ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a+ avoidGoal cs _mPreviousCS !es = logBackjump mbj (cs `CS.union` lastCS) $ -- Use 'lastCS' below instead of 'cs' since we do not want to@@ -86,7 +140,7 @@ where reachedBjLimit = case mbj of Nothing -> const False- Just limit -> (== limit)+ Just limit -> (>= limit) -- | Like 'retry', except that it only applies the input function when the -- backjump limit has not been reached.@@ -144,15 +198,20 @@ -- | A tree traversal that simultaneously propagates conflict sets up -- the tree from the leaves and creates a log.-exploreLog :: Maybe Int -> EnableBackjumping -> CountConflicts+exploreLog :: Maybe Int+ -> EnableBackjumping+ -> FineGrainedConflicts+ -> CountConflicts+ -> Index -> Tree Assignment QGoalReason -> ConflictSetLog (Assignment, RevDepMap)-exploreLog mbj enableBj (CountConflicts countConflicts) t = para go t initES+exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx t =+ para 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+ | asBool countConflicts = \ ts cm -> getBestGoal cm ts+ | otherwise = \ ts _ -> getFirstGoal ts go :: TreeF Assignment QGoalReason (ExploreState -> ConflictSetLog (Assignment, RevDepMap), Tree Assignment QGoalReason)@@ -162,20 +221,29 @@ in failWith (Failure c fr) (NoSolution c es') go (DoneF rdm a) = \ _ -> succeedWith Success (a, rdm) go (PChoiceF qpn _ gr ts) =- 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))- (fmap fst ts)+ backjump mbj enableBj fineGrainedConflicts+ (couldResolveConflicts qpn)+ (logSkippedPackage qpn)+ (P qpn) (avoidSet (P qpn) gr) $ -- try children in order,+ W.mapWithKey -- when descending ...+ (\ k r es -> tryWith (TryP qpn k) (r es))+ (fmap fst ts) go (FChoiceF qfn _ gr _ _ _ ts) =- 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))- (fmap fst ts)+ backjump mbj enableBj fineGrainedConflicts+ (\_ _ -> Nothing)+ (const logSkippedChoiceSimple)+ (F qfn) (avoidSet (F qfn) gr) $ -- try children in order,+ W.mapWithKey -- when descending ...+ (\ k r es -> tryWith (TryF qfn k) (r es))+ (fmap fst ts) go (SChoiceF qsn _ gr _ ts) =- 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))- (fmap fst ts)+ backjump mbj enableBj fineGrainedConflicts+ (\_ _ -> Nothing)+ (const logSkippedChoiceSimple)+ (S qsn) (avoidSet (S qsn) gr) $ -- try children in order,+ W.mapWithKey -- when descending ...+ (\ k r es -> tryWith (TryS qsn k) (r es))+ (fmap fst ts) go (GoalChoiceF _ ts) = \ es -> let (k, (v, tree)) = getBestGoal' ts (esConflictMap es) in continueWith (Next k) $@@ -194,6 +262,59 @@ , esBackjumps = 0 } + -- Is it possible for this package instance (QPN and POption) to resolve any+ -- of the conflicts that were caused by the previous instance? The default+ -- is true, because it is always safe to explore a package instance.+ -- Skipping it is an optimization. If false, it returns a new conflict set+ -- to be merged with the previous one.+ couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet+ couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts =+ let (PInfo deps _ _ _) = idx ! pn ! i+ qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps++ couldBeResolved :: CS.Conflict -> Maybe ConflictSet+ couldBeResolved CS.OtherConflict = Nothing+ couldBeResolved (CS.GoalConflict conflictingDep) =+ -- Check whether this package instance also has 'conflictingDep'+ -- as a dependency (ignoring flag and stanza choices).+ if F.null [() | Simple (LDep _ (Dep (PkgComponent qpn _) _)) _ <- qdeps, qpn == conflictingDep]+ then Nothing+ else Just CS.empty+ couldBeResolved (CS.VersionConstraintConflict dep excludedVersion) =+ -- Check whether this package instance also excludes version+ -- 'excludedVersion' of 'dep' (ignoring flag and stanza choices).+ let vrs = [vr | Simple (LDep _ (Dep (PkgComponent qpn _) (Constrained vr))) _ <- qdeps, qpn == dep ]+ vrIntersection = L.foldl' (.&&.) anyVersion vrs+ in if checkVR vrIntersection excludedVersion+ then Nothing+ else -- If we skip this package instance, we need to update the+ -- conflict set to say that 'dep' was also excluded by+ -- this package instance's constraint.+ Just $ CS.singletonWithConflict (P dep) $+ CS.VersionConflict currentQPN (CS.OrderedVersionRange vrIntersection)+ couldBeResolved (CS.VersionConflict reverseDep (CS.OrderedVersionRange excludingVR)) =+ -- Check whether this package instance's version is also excluded+ -- by 'excludingVR'.+ if checkVR excludingVR v+ then Nothing+ else -- If we skip this version, we need to update the conflict+ -- set to say that the reverse dependency also excluded this+ -- version.+ Just $ CS.singletonWithConflict (P reverseDep) (CS.VersionConstraintConflict currentQPN v)+ in fmap CS.unions $ traverse couldBeResolved (S.toList conflicts)++ logSkippedPackage :: QPN -> POption -> ConflictSet -> ExploreState -> ConflictSetLog a+ logSkippedPackage qpn pOption cs es =+ tryWith (TryP qpn pOption) $+ failWith (Skip (fromMaybe S.empty $ CS.lookup (P qpn) cs)) $+ NoSolution cs es++ -- This function is used for flag and stanza choices, but it should not be+ -- called, because there is currently no way to skip a value for a flag or+ -- stanza.+ logSkippedChoiceSimple :: ConflictSet -> ExploreState -> ConflictSetLog a+ logSkippedChoiceSimple cs es = fromProgress $ P.Fail $ NoSolution cs es+ -- | Build a conflict set corresponding to the (virtual) option not to -- choose a solution for a goal at all. --@@ -219,8 +340,10 @@ -- conflict set. -- avoidSet :: Var QPN -> QGoalReason -> ConflictSet-avoidSet var gr =- CS.union (CS.singleton var) (goalReasonToCS gr)+avoidSet var@(P qpn) gr =+ CS.union (CS.singleton var) (goalReasonToConflictSetWithConflict qpn gr)+avoidSet var gr =+ CS.union (CS.singleton var) (goalReasonToConflictSet gr) -- | Interface. --@@ -229,11 +352,15 @@ -- backtracking is completely disabled. backjumpAndExplore :: Maybe Int -> EnableBackjumping+ -> FineGrainedConflicts -> CountConflicts+ -> Index -> Tree d QGoalReason -> RetryLog Message SolverFailure (Assignment, RevDepMap)-backjumpAndExplore mbj enableBj countConflicts =- mapFailure convertFailure . exploreLog mbj enableBj countConflicts . assign+backjumpAndExplore mbj enableBj fineGrainedConflicts countConflicts idx =+ mapFailure convertFailure+ . exploreLog mbj enableBj fineGrainedConflicts countConflicts idx+ . assign where convertFailure (NoSolution cs es) = ExhaustiveSearch cs (esConflictMap es) convertFailure BackjumpLimit = BackjumpLimitReached
Distribution/Solver/Modular/IndexConversion.hs view
@@ -341,7 +341,7 @@ -- | Convert condition trees to flagged dependencies. Mutually -- recursive with 'convBranch'. See 'convBranch' for an explanation--- of all arguments preceeding the input 'CondTree'.+-- of all arguments preceding the input 'CondTree'. convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo -> Component -> (a -> BuildInfo) ->
Distribution/Solver/Modular/Linking.hs view
@@ -1,5 +1,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}++-- TODO: remove this+{-# OPTIONS -fno-warn-incomplete-uni-patterns #-} module Distribution.Solver.Modular.Linking ( validateLinking ) where@@ -12,7 +15,6 @@ import Control.Monad.State import Data.Function (on) import Data.Map ((!))-import Data.Set (Set) import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Traversable as T@@ -29,7 +31,7 @@ import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath-import Distribution.Types.GenericPackageDescription (unFlagName)+import Distribution.Types.Flag (unFlagName) {------------------------------------------------------------------------------- Validation@@ -249,7 +251,7 @@ vs <- get let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs- lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToCS) dr1 dr2) lg lg'+ lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToConflictSet) dr1 dr2) lg lg' updateLinkGroup lg'' (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do vs <- get
Distribution/Solver/Modular/Message.hs view
@@ -6,10 +6,16 @@ ) where import qualified Data.List as L+import Data.Map (Map)+import qualified Data.Map as M+import Data.Set (Set)+import qualified Data.Set as S+import Data.Maybe (catMaybes, mapMaybe) import Prelude hiding (pi) import Distribution.Pretty (prettyShow) -- from Cabal +import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package@@ -28,6 +34,7 @@ | TryF QFN Bool | TryS QSN Bool | Next (Goal QPN)+ | Skip (Set CS.Conflict) | Success | Failure ConflictSet FailReason @@ -47,6 +54,8 @@ -- complex patterns go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = goPReject l qpn [i] c fr ms+ go !l (Step (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) =+ goPSkip l qpn [i] conflicts ms go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = (atLevel l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms) go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =@@ -63,6 +72,9 @@ go !l (Step (TryS qsn b) ms) = (atLevel l $ "trying: " ++ showQSNBool qsn b) (go l ms) go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms) go !l (Step (Next _) ms) = go l ms -- ignore flag goals in the log+ go !l (Step (Skip conflicts) ms) =+ -- 'Skip' should always be handled by 'goPSkip' in the case above.+ (atLevel l $ "skipping: " ++ showConflicts conflicts) (go l ms) go !l (Step (Success) ms) = (atLevel l $ "done") (go l ms) go !l (Step (Failure c fr) ms) = (atLevel l $ showFailure c fr) (go l ms) @@ -85,11 +97,111 @@ goPReject l qpn is c fr ms = (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms) + -- Handle many subsequent skipped package instances.+ goPSkip :: Int+ -> QPN+ -> [POption]+ -> Set CS.Conflict+ -> Progress Message a b+ -> Progress String a b+ goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms))))+ | qpn == qpn' && conflicts == conflicts' = goPSkip l qpn (i : is) conflicts ms+ goPSkip l qpn is conflicts ms =+ let msg = "skipping: "+ ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is))+ ++ showConflicts conflicts+ in atLevel l msg (go l ms)+ -- write a message with the current level number atLevel :: Int -> String -> Progress String a b -> Progress String a b atLevel l x xs = let s = show l in Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs++-- | Display the set of 'Conflicts' for a skipped package version.+showConflicts :: Set CS.Conflict -> String+showConflicts conflicts =+ " (has the same characteristics that caused the previous version to fail: "+ ++ conflictMsg ++ ")"+ where+ conflictMsg :: String+ conflictMsg =+ if S.member CS.OtherConflict conflicts+ then+ -- This case shouldn't happen, because an unknown conflict should not+ -- cause a version to be skipped.+ "unknown conflict"+ else let mergedConflicts =+ [ showConflict qpn conflict+ | (qpn, conflict) <- M.toList (mergeConflicts conflicts) ]+ in if L.null mergedConflicts+ then+ -- This case shouldn't happen unless backjumping is turned off.+ "none"+ else L.intercalate "; " mergedConflicts++ -- Merge conflicts to simplify the log message.+ mergeConflicts :: Set CS.Conflict -> Map QPN MergedPackageConflict+ mergeConflicts = M.fromListWith mergeConflict . mapMaybe toMergedConflict . S.toList+ where+ mergeConflict :: MergedPackageConflict+ -> MergedPackageConflict+ -> MergedPackageConflict+ mergeConflict mergedConflict1 mergedConflict2 = MergedPackageConflict {+ isGoalConflict =+ isGoalConflict mergedConflict1 || isGoalConflict mergedConflict2+ , versionConstraintConflict =+ L.nub $ versionConstraintConflict mergedConflict1+ ++ versionConstraintConflict mergedConflict2+ , versionConflict =+ mergeVersionConflicts (versionConflict mergedConflict1)+ (versionConflict mergedConflict2)+ }+ where+ mergeVersionConflicts (Just vr1) (Just vr2) = Just (vr1 .||. vr2)+ mergeVersionConflicts (Just vr1) Nothing = Just vr1+ mergeVersionConflicts Nothing (Just vr2) = Just vr2+ mergeVersionConflicts Nothing Nothing = Nothing++ toMergedConflict :: CS.Conflict -> Maybe (QPN, MergedPackageConflict)+ toMergedConflict (CS.GoalConflict qpn) =+ Just (qpn, MergedPackageConflict True [] Nothing)+ toMergedConflict (CS.VersionConstraintConflict qpn v) =+ Just (qpn, MergedPackageConflict False [v] Nothing)+ toMergedConflict (CS.VersionConflict qpn (CS.OrderedVersionRange vr)) =+ Just (qpn, MergedPackageConflict False [] (Just vr))+ toMergedConflict CS.OtherConflict = Nothing++ showConflict :: QPN -> MergedPackageConflict -> String+ showConflict qpn mergedConflict = L.intercalate "; " conflictStrings+ where+ conflictStrings = catMaybes [+ case () of+ () | isGoalConflict mergedConflict -> Just $+ "depends on '" ++ showQPN qpn ++ "'" +++ (if null (versionConstraintConflict mergedConflict)+ then ""+ else " but excludes "+ ++ showVersions (versionConstraintConflict mergedConflict))+ | not $ L.null (versionConstraintConflict mergedConflict) -> Just $+ "excludes '" ++ showQPN qpn+ ++ "' " ++ showVersions (versionConstraintConflict mergedConflict)+ | otherwise -> Nothing+ , (\vr -> "excluded by constraint '" ++ showVR vr ++ "' from '" ++ showQPN qpn ++ "'")+ <$> versionConflict mergedConflict+ ]++ showVersions [] = "no versions"+ showVersions [v] = "version " ++ showVer v+ showVersions vs = "versions " ++ L.intercalate ", " (map showVer vs)++-- | All conflicts related to one package, used for simplifying the display of+-- a 'Set CS.Conflict'.+data MergedPackageConflict = MergedPackageConflict {+ isGoalConflict :: Bool+ , versionConstraintConflict :: [Ver]+ , versionConflict :: Maybe VR+ } showQPNPOpt :: QPN -> POption -> String showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) =
Distribution/Solver/Modular/Package.hs view
@@ -18,7 +18,8 @@ , unPN ) where -import Data.List as L+import Prelude ()+import Distribution.Solver.Compat.Prelude import Distribution.Package -- from Cabal import Distribution.Deprecated.Text (display)@@ -57,14 +58,12 @@ -- | String representation of an instance. showI :: I -> String showI (I v InRepo) = showVer v-showI (I v (Inst uid)) = showVer v ++ "/installed" ++ shortId uid+showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid where- -- A hack to extract the beginning of the package ABI hash- shortId = snip (splitAt 4) (++ "...")- . snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':)- . display- snip p f xs = case p xs of- (ys, zs) -> (if L.null zs then id else f) ys+ extractPackageAbiHash xs =+ case first reverse $ break (=='-') $ reverse (display xs) of+ (ys, []) -> ys+ (ys, _) -> '-' : ys -- | Package instance. A package name and an instance. data PI qpn = PI qpn I
Distribution/Solver/Modular/Preference.hs view
@@ -343,7 +343,9 @@ onlyConstrained p = trav go where go (PChoiceF v@(Q _ pn) _ gr _) | not (p pn)- = FailF (varToConflictSet (P v) `CS.union` goalReasonToCS gr) NotExplicit+ = FailF+ (varToConflictSet (P v) `CS.union` goalReasonToConflictSetWithConflict v gr)+ NotExplicit go x = x
Distribution/Solver/Modular/Solver.hs view
@@ -57,6 +57,7 @@ data SolverConfig = SolverConfig { reorderGoals :: ReorderGoals, countConflicts :: CountConflicts,+ fineGrainedConflicts :: FineGrainedConflicts, minimizeConflictSet :: MinimizeConflictSet, independentGoals :: IndependentGoals, avoidReinstalls :: AvoidReinstalls,@@ -104,7 +105,9 @@ where explorePhase = backjumpAndExplore (maxBackjumps sc) (enableBackjumping sc)+ (fineGrainedConflicts sc) (countConflicts sc)+ idx detectCycles = traceTree "cycles.json" id . detectCyclesPhase heuristicsPhase = let heuristicsTree = traceTree "heuristics.json" id
Distribution/Solver/Modular/Validate.hs view
@@ -320,7 +320,7 @@ -> (ExposedComponent -> DependencyReason QPN -> FailReason) -> Conflict mkConflict comp dr mkFailure =- (CS.insert (P qpn) (dependencyReasonToCS dr), mkFailure comp dr)+ (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure comp dr) buildableProvidedComps :: [ExposedComponent] buildableProvidedComps = [comp | (comp, IsBuildable True) <- M.toList providedComps]@@ -393,13 +393,13 @@ extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment extendSingle a (LDep dr (Ext ext )) = if extSupported ext then Right a- else Left (dependencyReasonToCS dr, UnsupportedExtension ext)+ else Left (dependencyReasonToConflictSet dr, UnsupportedExtension ext) extendSingle a (LDep dr (Lang lang)) = if langSupported lang then Right a- else Left (dependencyReasonToCS dr, UnsupportedLanguage lang)+ else Left (dependencyReasonToConflictSet dr, UnsupportedLanguage lang) extendSingle a (LDep dr (Pkg pn vr)) = if pkgPresent pn vr then Right a- else Left (dependencyReasonToCS dr, MissingPkgconfigPackage pn vr)+ else Left (dependencyReasonToConflictSet dr, MissingPkgconfigPackage pn vr) 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 dep ci) of@@ -448,14 +448,14 @@ 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+ Left ( (CS.union `on` dependencyReasonToConflictSet) vs1 vs2 , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) 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+ Left ( createConflictSetForVersionConflict p v vs1 vr vs2 , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) @@ -467,7 +467,7 @@ go ((vr, comp1, vs1) : vros) | checkVR vr v = go vros | otherwise =- Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2+ Left ( createConflictSetForVersionConflict p v vs2 vr vs1 , ( ConflictingDep vs1 (PkgComponent p comp1) (Constrained vr) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) @@ -479,6 +479,45 @@ -- no negative performance impact. vrOrigins ++ [(vr, comp2, vs2)]) +-- | Creates a conflict set representing a conflict between a version constraint+-- and the fixed version chosen for a package.+createConflictSetForVersionConflict :: QPN+ -> Ver+ -> DependencyReason QPN+ -> VR+ -> DependencyReason QPN+ -> ConflictSet+createConflictSetForVersionConflict pkg+ conflictingVersion+ versionDR@(DependencyReason p1 _ _)+ conflictingVersionRange+ versionRangeDR@(DependencyReason p2 _ _) =+ let hasFlagsOrStanzas (DependencyReason _ fs ss) = not (M.null fs) || not (S.null ss)+ in+ -- The solver currently only optimizes the case where there is a conflict+ -- between the version chosen for a package and a version constraint that+ -- is not under any flags or stanzas. Here is how we check for this case:+ --+ -- (1) Choosing a specific version for a package foo is implemented as+ -- adding a dependency from foo to that version of foo (See+ -- extendWithPackageChoice), so we check that the DependencyReason+ -- contains the current package and no flag or stanza choices.+ --+ -- (2) We check that the DependencyReason for the version constraint also+ -- contains no flag or stanza choices.+ --+ -- When these criteria are not met, we fall back to calling+ -- dependencyReasonToConflictSet.+ if p1 == pkg && not (hasFlagsOrStanzas versionDR) && not (hasFlagsOrStanzas versionRangeDR)+ then let cs1 = dependencyReasonToConflictSetWithVersionConflict+ p2+ (CS.OrderedVersionRange conflictingVersionRange)+ versionDR+ cs2 = dependencyReasonToConflictSetWithVersionConstraintConflict+ pkg conflictingVersion versionRangeDR+ in cs1 `CS.union` cs2+ else dependencyReasonToConflictSet versionRangeDR `CS.union` dependencyReasonToConflictSet versionDR+ -- | Takes a list of new dependencies and uses it to try to update the map of -- known component dependencies. It returns a failure when a new dependency -- requires a component that is missing or unbuildable in a previously chosen@@ -512,7 +551,7 @@ -> (QPN -> ExposedComponent -> FailReason) -> Conflict mkConflict qpn comp dr mkFailure =- (CS.insert (P qpn) (dependencyReasonToCS dr), mkFailure qpn comp)+ (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure qpn comp) buildableComps :: Map comp IsBuildable -> [comp] buildableComps comps = [comp | (comp, IsBuildable True) <- M.toList comps]
Distribution/Solver/Types/ComponentDeps.hs view
@@ -38,7 +38,7 @@ import Prelude () import Distribution.Types.UnqualComponentName-import Distribution.Solver.Compat.Prelude hiding (empty,zip)+import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip) import qualified Data.Map as Map import Data.Foldable (fold)@@ -62,6 +62,7 @@ deriving (Show, Eq, Ord, Generic) instance Binary Component+instance Structured Component -- | Dependency for a single component. type ComponentDep a = (Component, a)@@ -89,6 +90,7 @@ traverse f = fmap ComponentDeps . traverse f . unComponentDeps instance Binary a => Binary (ComponentDeps a)+instance Structured a => Structured (ComponentDeps a) componentNameToComponent :: CN.ComponentName -> Component componentNameToComponent (CN.CLibName LN.LMainLibName) = ComponentLib
Distribution/Solver/Types/ConstraintSource.hs view
@@ -5,7 +5,8 @@ ) where import GHC.Generics (Generic)-import Distribution.Compat.Binary (Binary(..))+import Distribution.Compat.Binary (Binary)+import Distribution.Utils.Structured (Structured) -- | Source of a 'PackageConstraint'. data ConstraintSource =@@ -56,6 +57,7 @@ deriving (Eq, Show, Generic) instance Binary ConstraintSource+instance Structured ConstraintSource -- | Description of a 'ConstraintSource'. showConstraintSource :: ConstraintSource -> String
Distribution/Solver/Types/InstSolverPackage.hs view
@@ -4,6 +4,7 @@ ) where import Distribution.Compat.Binary (Binary(..))+import Distribution.Utils.Structured (Structured) import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) ) import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) import Distribution.Solver.Types.SolverId@@ -13,7 +14,7 @@ import Distribution.InstalledPackageInfo (InstalledPackageInfo) import GHC.Generics (Generic) --- | An 'InstSolverPackage' is a pre-existing installed pacakge+-- | An 'InstSolverPackage' is a pre-existing installed package -- specified by the dependency solver. data InstSolverPackage = InstSolverPackage { instSolverPkgIPI :: InstalledPackageInfo,@@ -23,6 +24,7 @@ deriving (Eq, Show, Generic) instance Binary InstSolverPackage+instance Structured InstSolverPackage instance Package InstSolverPackage where packageId i =
Distribution/Solver/Types/OptionalStanza.hs view
@@ -8,10 +8,11 @@ import GHC.Generics (Generic) import Data.Typeable-import Distribution.Compat.Binary (Binary(..))+import Distribution.Compat.Binary (Binary) import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec(..), defaultComponentRequestedSpec) import Data.List (foldl')+import Distribution.Utils.Structured (Structured) data OptionalStanza = TestStanzas@@ -32,3 +33,4 @@ addStanza enabled BenchStanzas = enabled { benchmarksRequested = True } instance Binary OptionalStanza+instance Structured OptionalStanza
Distribution/Solver/Types/PackageConstraint.hs view
@@ -18,12 +18,13 @@ packageConstraintToDependency ) where -import Distribution.Compat.Binary (Binary(..))+import Distribution.Compat.Binary (Binary) import Distribution.Package (PackageName) import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) import Distribution.Types.Dependency (Dependency(..)) import Distribution.Types.LibraryName (LibraryName(..)) import Distribution.Version (VersionRange, simplifyVersionRange)+import Distribution.Utils.Structured (Structured) import Distribution.Solver.Compat.Prelude ((<<>>)) import Distribution.Solver.Types.OptionalStanza@@ -102,6 +103,7 @@ deriving (Eq, Show, Generic) instance Binary PackageProperty+instance Structured PackageProperty -- | Pretty-prints a package property. dispPackageProperty :: PackageProperty -> Disp.Doc
Distribution/Solver/Types/PackageIndex.hs view
@@ -50,7 +50,8 @@ import Control.Exception (assert) import qualified Data.Map as Map-import Data.List (groupBy, isInfixOf)+import Data.List (isInfixOf)+import qualified Data.List.NonEmpty as NE import Distribution.Package ( PackageName, unPackageName, PackageIdentifier(..)@@ -136,9 +137,9 @@ where fixBucket = -- out of groups of duplicates, later ones mask earlier ones -- but Map.fromListWith (++) constructs groups in reverse order- map head+ map NE.head -- Eq instance for PackageIdentifier is wrong, so use Ord:- . groupBy (\a b -> EQ == comparing packageId a b)+ . NE.groupBy (\a b -> EQ == comparing packageId a b) -- relies on sortBy being a stable sort so we -- can pick consistently among duplicates . sortBy (comparing packageId)
Distribution/Solver/Types/PkgConfigDb.hs view
@@ -31,7 +31,7 @@ import Distribution.Package (PkgconfigName, mkPkgconfigName) import Distribution.Parsec import Distribution.Simple.Program- (ProgramDb, getProgramOutput, pkgConfigProgram, requireProgram)+ (ProgramDb, getProgramOutput, pkgConfigProgram, needProgram) import Distribution.Simple.Utils (info) import Distribution.Types.PkgconfigVersion import Distribution.Types.PkgconfigVersionRange@@ -50,30 +50,36 @@ deriving (Show, Generic, Typeable) instance Binary PkgConfigDb+instance Structured PkgConfigDb -- | Query pkg-config for the list of installed packages, together -- with their versions. Return a `PkgConfigDb` encapsulating this -- information. readPkgConfigDb :: Verbosity -> ProgramDb -> IO PkgConfigDb readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do- (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram progdb- pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"]- -- The output of @pkg-config --list-all@ also includes a description- -- for each package, which we do not need.- let pkgNames = map (takeWhile (not . isSpace)) pkgList- pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig- ("--modversion" : pkgNames)- (return . pkgConfigDbFromList . zip pkgNames) pkgVersions- where- -- For when pkg-config invocation fails (possibly because of a- -- too long command line).- ioErrorHandler :: IOException -> IO PkgConfigDb- ioErrorHandler e = do- info verbosity ("Failed to query pkg-config, Cabal will continue"- ++ " without solving for pkg-config constraints: "- ++ show e)- return NoPkgConfigDb+ mpkgConfig <- needProgram verbosity pkgConfigProgram progdb+ case mpkgConfig of+ Nothing -> noPkgConfig "Cannot find pkg-config program"+ Just (pkgConfig, _) -> do+ pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"]+ -- The output of @pkg-config --list-all@ also includes a description+ -- for each package, which we do not need.+ let pkgNames = map (takeWhile (not . isSpace)) pkgList+ pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig+ ("--modversion" : pkgNames)+ (return . pkgConfigDbFromList . zip pkgNames) pkgVersions+ where+ -- For when pkg-config invocation fails (possibly because of a+ -- too long command line).+ noPkgConfig extra = do+ info verbosity ("Failed to query pkg-config, Cabal will continue"+ ++ " without solving for pkg-config constraints: "+ ++ extra)+ return NoPkgConfigDb + ioErrorHandler :: IOException -> IO PkgConfigDb+ ioErrorHandler e = noPkgConfig (show e)+ -- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs. pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs@@ -134,10 +140,11 @@ -- > pkg-config --variable pc_path pkg-config -- getDefPath = handle ioErrorHandler $ do- (pkgConfig, _) <- requireProgram verbosity pkgConfigProgram progdb- parseSearchPath <$>- getProgramOutput verbosity pkgConfig- ["--variable", "pc_path", "pkg-config"]+ mpkgConfig <- needProgram verbosity pkgConfigProgram progdb+ case mpkgConfig of+ Nothing -> return []+ Just (pkgConfig, _) -> parseSearchPath <$>+ getProgramOutput verbosity pkgConfig ["--variable", "pc_path", "pkg-config"] parseSearchPath str = case lines str of
Distribution/Solver/Types/ResolverPackage.hs view
@@ -11,7 +11,8 @@ import Distribution.Solver.Types.SolverPackage import qualified Distribution.Solver.Types.ComponentDeps as CD -import Distribution.Compat.Binary (Binary(..))+import Distribution.Compat.Binary (Binary)+import Distribution.Utils.Structured (Structured) import Distribution.Compat.Graph (IsNode(..)) import Distribution.Package (Package(..), HasUnitId(..)) import Distribution.Simple.Utils (ordNub)@@ -27,6 +28,7 @@ deriving (Eq, Show, Generic) instance Binary loc => Binary (ResolverPackage loc)+instance Structured loc => Structured (ResolverPackage loc) instance Package (ResolverPackage loc) where packageId (PreExisting ipkg) = packageId ipkg
Distribution/Solver/Types/Settings.hs view
@@ -11,11 +11,13 @@ , OnlyConstrained(..) , EnableBackjumping(..) , CountConflicts(..)+ , FineGrainedConflicts(..) , SolveExecutables(..) ) where import Distribution.Simple.Setup ( BooleanFlag(..) )-import Distribution.Compat.Binary (Binary(..))+import Distribution.Compat.Binary (Binary)+import Distribution.Utils.Structured (Structured) import Distribution.Pretty ( Pretty(pretty) ) import Distribution.Deprecated.Text ( Text(parse) ) import GHC.Generics (Generic)@@ -29,6 +31,9 @@ newtype CountConflicts = CountConflicts Bool deriving (BooleanFlag, Eq, Generic, Show) +newtype FineGrainedConflicts = FineGrainedConflicts Bool+ deriving (BooleanFlag, Eq, Generic, Show)+ newtype MinimizeConflictSet = MinimizeConflictSet Bool deriving (BooleanFlag, Eq, Generic, Show) @@ -62,6 +67,7 @@ instance Binary ReorderGoals instance Binary CountConflicts+instance Binary FineGrainedConflicts instance Binary IndependentGoals instance Binary MinimizeConflictSet instance Binary AvoidReinstalls@@ -70,6 +76,18 @@ instance Binary AllowBootLibInstalls instance Binary OnlyConstrained instance Binary SolveExecutables++instance Structured ReorderGoals+instance Structured CountConflicts+instance Structured FineGrainedConflicts+instance Structured IndependentGoals+instance Structured MinimizeConflictSet+instance Structured AvoidReinstalls+instance Structured ShadowPkgs+instance Structured StrongFlags+instance Structured AllowBootLibInstalls+instance Structured OnlyConstrained+instance Structured SolveExecutables instance Pretty OnlyConstrained where pretty OnlyConstrainedAll = PP.text "all"
Distribution/Solver/Types/SolverId.hs view
@@ -5,7 +5,8 @@ where -import Distribution.Compat.Binary (Binary(..))+import Distribution.Compat.Binary (Binary)+import Distribution.Utils.Structured (Structured) import Distribution.Package (PackageId, Package(..), UnitId) import GHC.Generics (Generic) @@ -19,6 +20,7 @@ deriving (Eq, Ord, Generic) instance Binary SolverId+instance Structured SolverId instance Show SolverId where show = show . solverSrcId
Distribution/Solver/Types/SolverPackage.hs view
@@ -3,7 +3,8 @@ ( SolverPackage(..) ) where -import Distribution.Compat.Binary (Binary(..))+import Distribution.Compat.Binary (Binary)+import Distribution.Utils.Structured (Structured) import Distribution.Package ( Package(..) ) import Distribution.PackageDescription ( FlagAssignment ) import Distribution.Solver.Types.ComponentDeps ( ComponentDeps )@@ -29,6 +30,7 @@ deriving (Eq, Show, Generic) instance Binary loc => Binary (SolverPackage loc)+instance Structured loc => Structured (SolverPackage loc) instance Package (SolverPackage loc) where packageId = packageId . solverPkgSource
Distribution/Solver/Types/SourcePackage.hs view
@@ -12,8 +12,9 @@ import Data.ByteString.Lazy (ByteString) import GHC.Generics (Generic)-import Distribution.Compat.Binary (Binary(..))+import Distribution.Compat.Binary (Binary) import Data.Typeable+import Distribution.Utils.Structured (Structured) -- | A package description along with the location of the package sources. --@@ -25,7 +26,8 @@ } deriving (Eq, Show, Generic, Typeable) -instance (Binary loc) => Binary (SourcePackage loc)+instance Binary loc => Binary (SourcePackage loc)+instance Structured loc => Structured (SourcePackage loc) instance Package (SourcePackage a) where packageId = packageInfoId
bootstrap.sh view
@@ -224,8 +224,8 @@ # >= 2.6.0.2 && < 2.7 NETWORK_VER="2.7.0.0"; NETWORK_VER_REGEXP="2\.[0-7]\." # >= 2.0 && < 2.7-CABAL_VER="3.0.0.0"; CABAL_VER_REGEXP="3\.0\.[0-9]"- # >= 2.5 && < 2.6+CABAL_VER="3.2.0.0"; CABAL_VER_REGEXP="3\.2\.[0-9]"+ # >= 3.2 && < 3.3 TRANS_VER="0.5.5.0"; TRANS_VER_REGEXP="0\.[45]\." # >= 0.2.* && < 0.6 MTL_VER="2.2.2"; MTL_VER_REGEXP="[2]\."@@ -260,14 +260,14 @@ # 0.2.2.* ED25519_VER="0.0.5.0"; ED25519_VER_REGEXP="0\.0\.?" # 0.0.*-HACKAGE_SECURITY_VER="0.5.3.0"; HACKAGE_SECURITY_VER_REGEXP="0\.5\.((2\.[2-9]|[3-9])|3)"- # >= 0.5.2 && < 0.6+HACKAGE_SECURITY_VER="0.6.0.0"; HACKAGE_SECURITY_VER_REGEXP="0\.6\."+ # >= 0.7.0.0 && < 0.7 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+LUKKO_VER="0.1.1"; LUKKO_VER_REGEXP="0\.1\.[1-9]"+ # >= 0.1.1 && <0.2 HACKAGE_URL="https://hackage.haskell.org/package" @@ -471,7 +471,7 @@ 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 "lukko" ${LUKKO_VER} ${LUKKO_REGEXP} info_pkg "hackage-security" ${HACKAGE_SECURITY_VER} \ ${HACKAGE_SECURITY_VER_REGEXP} @@ -509,7 +509,7 @@ 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 "lukko" ${LUKKO_VER} ${LUKKO_REGEXP} do_pkg "hackage-security" ${HACKAGE_SECURITY_VER} \ ${HACKAGE_SECURITY_VER_REGEXP}
cabal-install.cabal view
@@ -4,7 +4,7 @@ -- 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: 3.0.0.0+Version: 3.2.0.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing@@ -16,12 +16,11 @@ License-File: LICENSE Author: Cabal Development Team (see AUTHORS file) Maintainer: Cabal Development Team <cabal-devel@haskell.org>-Copyright: 2003-2019, Cabal Development Team+Copyright: 2003-2020, Cabal Development Team Category: Distribution Build-type: Custom Extra-Source-Files: README.md bash-completion/cabal bootstrap.sh changelog- tests/README.md -- Generated with 'make gen-extra-source-files' -- Do NOT edit this section manually; instead, run the script.@@ -122,6 +121,11 @@ default: False manual: True +Flag lukko+ description: Use @lukko@ for file-locking+ default: True+ manual: True+ custom-setup setup-depends: Cabal >= 2.2,@@ -133,12 +137,14 @@ main-is: Main.hs hs-source-dirs: main default-language: Haskell2010- ghc-options: -Wall -fwarn-tabs+ ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns if impl(ghc >= 8.0) ghc-options: -Wcompat -Wnoncanonical-monad-instances- -Wnoncanonical-monadfail-instances+ if impl(ghc < 8.8)+ ghc-options: -Wnoncanonical-monadfail-instances + ghc-options: -rtsopts -threaded -- On AIX, some legacy BSD operations such as flock(2) are provided by libbsd.a@@ -171,13 +177,14 @@ Distribution.Client.CmdInstall.ClientInstallFlags Distribution.Client.CmdRepl Distribution.Client.CmdRun+ Distribution.Client.CmdRun.ClientRunFlags Distribution.Client.CmdTest Distribution.Client.CmdLegacy Distribution.Client.CmdSdist Distribution.Client.Compat.Directory Distribution.Client.Compat.ExecutablePath- Distribution.Client.Compat.FileLock Distribution.Client.Compat.FilePerms+ Distribution.Client.Compat.Orphans Distribution.Client.Compat.Prelude Distribution.Client.Compat.Process Distribution.Client.Compat.Semaphore@@ -197,6 +204,7 @@ Distribution.Client.Glob Distribution.Client.GlobalFlags Distribution.Client.Haddock+ Distribution.Client.HashValue Distribution.Client.HttpUtils Distribution.Client.IndexUtils Distribution.Client.IndexUtils.Timestamp@@ -239,7 +247,7 @@ Distribution.Client.SetupWrapper Distribution.Client.SolverInstallPlan Distribution.Client.SourceFiles- Distribution.Client.SourceRepoParse+ Distribution.Client.SourceRepo Distribution.Client.SrcDist Distribution.Client.Store Distribution.Client.Tar@@ -308,11 +316,11 @@ build-depends: async >= 2.0 && < 2.3, array >= 0.4 && < 0.6,- base >= 4.8 && < 4.13,+ base >= 4.8 && < 4.14, base16-bytestring >= 0.1.1 && < 0.2, binary >= 0.7.3 && < 0.9, bytestring >= 0.10.6.0 && < 0.11,- Cabal == 3.0.*,+ Cabal == 3.2.*, containers >= 0.5.6.2 && < 0.7, cryptohash-sha256 >= 0.11 && < 0.12, deepseq >= 1.4.1.1 && < 1.5,@@ -331,13 +339,15 @@ stm >= 2.0 && < 2.6, tar >= 0.5.0.3 && < 0.6, time >= 1.5.0.1 && < 1.10,+ transformers >= 0.4.2.0 && < 0.6, zlib >= 0.5.3 && < 0.7,- hackage-security >= 0.5.2.2 && < 0.6,+ hackage-security >= 0.6.0.0 && < 0.7, text >= 1.2.3 && < 1.3, parsec >= 3.1.13.0 && < 3.2 if !impl(ghc >= 8.0) build-depends: fail == 4.9.*+ build-depends: semigroups >= 0.18.3 && <0.20 if flag(native-dns) if os(windows)@@ -349,6 +359,11 @@ build-depends: Win32 >= 2 && < 3 else build-depends: unix >= 2.5 && < 2.9++ if flag(lukko)+ build-depends: lukko >= 0.1 && <0.2+ else+ build-depends: base >= 4.10 if flag(debug-expensive-assertions) cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS
changelog view
@@ -1,9 +1,44 @@ -*-change-log-*- +3.2.0.0 Herbert Valerio Riedel <hvr@gnu.org> April 2020+ * `v2-build` (and other `v2-`prefixed commands) now accept the+ `--benchmark-option(s)` flags, which pass options to benchmark executables+ (analogous to how `--test-option(s)` works). (#6209)+ * Add solver optimization to skip a version of a package if it does not resolve+ any conflicts encountered in the last version, controlled by flag+ '--fine-grained-conflicts'. (#5918)+ * `cabal v2-exec` doesn't fail in clean package (#6479)+ * Show full ABI hash for installed packages in solver log (#5892)+ * Create incoming directory even for empty packages (#4130)+ * Start GHCi with `main-is` module in scope (#6311)+ * Implement `--benchmark-options` for `v2-bench` (#6224)+ * Fix store-dir in ghc env files generated by `cabal install --lib+ --package-env` (#6298)+ * `cabal v2-run` works with `.lhs` files (#6134)+ * `subdir` in source-repository-package accepts multiple entries (#5472)++3.0.1.0 Herbert Valerio Riedel <hvr@gnu.org> April 2020+ * Create store incoming directory+ ([#4130](https://github.com/haskell/cabal/issues/4130))+ * `fetchRepoTarball` output is not marked+ ([#6385](https://github.com/haskell/cabal/pull/6385))+ * Update `setupMinCabalVersionConstraint` for GHC-8.8+ ([#6217](https://github.com/haskell/cabal/pull/6217))+ * Implement `cabal install --ignore-project`+ ([#5919](https://github.com/haskell/cabal/issues/5919))+ * `cabal install executable` solver isn't affected by default+ environment contents+ ([#6410](https://github.com/haskell/cabal/issues/6410))+ * Use `lukko` for file locking+ ([#6345](https://github.com/haskell/cabal/pull/6345))+ * Use `hackage-security-0.6`+ ([#6388](https://github.com/haskell/cabal/pull/6388))+ * Other dependency upgrades+ 3.0.0.0 Mikhail Glushenkov <mikhail.glushenkov@gmail.com> August 2019 * `v2-haddock` fails on `haddock` failures (#5977) * `v2-run` works when given `File.lhs` literate file. (#6134)- * Parse comma-seperated lists for extra-prog-path, extra-lib-dirs, extra-framework-dirs,+ * Parse comma-separated lists for extra-prog-path, extra-lib-dirs, extra-framework-dirs, and extra-include-dirs as actual lists. (#5420) * `v2-repl` no longer changes directory to a randomized temporary folder when used outside of a project. (#5544)@@ -504,7 +539,7 @@ 0.6.2 Duncan Coutts <duncan@haskell.org> Feb 2009 * The upgrade command has been disabled in this release * The configure and install commands now have consistent behaviour- * Reduce the tendancy to re-install already existing packages+ * Reduce the tendency to re-install already existing packages * The --constraint= flag now works for the install command * New --preference= flag for soft constraints / version preferences * Improved bootstrap.sh script, smarter and better error checking
main/Main.hs view
@@ -236,9 +236,9 @@ mainWorker :: [String] -> IO () mainWorker args = do- hasScript <- if not (null args)- then CmdRun.validScript (head args)- else return False+ maybeScriptAndArgs <- case args of+ [] -> return Nothing+ (h:tl) -> (\b -> if b then Just (h:|tl) else Nothing) <$> CmdRun.validScript h topHandler $ case commandsRun (globalCommand commands) commands args of@@ -253,9 +253,8 @@ -> printNumericVersion CommandHelp help -> printCommandHelp help CommandList opts -> printOptionsList opts- CommandErrors errs- | hasScript -> CmdRun.handleShebang (head args) (tail args)- | otherwise -> printErrors errs+ CommandErrors errs -> maybe (printErrors errs) go maybeScriptAndArgs where+ go (script:|scriptArgs) = CmdRun.handleShebang script scriptArgs CommandReadyToGo action -> do globalFlags' <- updateSandboxConfigFileFlag globalFlags action globalFlags'@@ -554,9 +553,10 @@ either (const onNoPkgDesc) (const onPkgDesc) pkgDesc -installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)+installAction :: ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> Action-installAction (configFlags, _, installFlags, _, _) _ globalFlags+installAction (configFlags, _, installFlags, _, _, _) _ globalFlags | fromFlagOrDefault False (installOnly installFlags) = do let verb = fromFlagOrDefault normal (configVerbosity configFlags) (useSandbox, config) <- loadConfigOrSandboxConfig verb globalFlags@@ -565,10 +565,12 @@ nixShellIfSandboxed verb dist globalFlags config useSandbox $ setupWrapper verb setupOpts Nothing- installCommand (const mempty) (const [])+ installCommand (const (mempty, mempty, mempty, mempty, mempty, mempty))+ (const []) installAction- (configFlags, configExFlags, installFlags, haddockFlags, testFlags)+ ( configFlags, configExFlags, installFlags+ , haddockFlags, testFlags, benchmarkFlags ) extraArgs globalFlags = do let verb = fromFlagOrDefault normal (configVerbosity configFlags) (useSandbox, config) <- updateInstallDirs (configUserInstall configFlags)@@ -607,6 +609,9 @@ testFlags' = Cabal.defaultTestFlags `mappend` savedTestFlags config `mappend` testFlags { testDistPref = toFlag dist }+ benchmarkFlags' = Cabal.defaultBenchmarkFlags `mappend`+ savedBenchmarkFlags config `mappend`+ benchmarkFlags { benchmarkDistPref = toFlag dist } globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, platform, progdb) <- configCompilerAux' configFlags' -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the@@ -643,7 +648,7 @@ comp platform progdb' useSandbox mSandboxPkgInfo globalFlags' configFlags'' configExFlags'- installFlags' haddockFlags' testFlags'+ installFlags' haddockFlags' testFlags' benchmarkFlags' targets where@@ -885,9 +890,10 @@ withRepoContext verbosity globalFlags' $ \repoContext -> update verbosity updateFlags repoContext -upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags, TestFlags)+upgradeAction :: ( ConfigFlags, ConfigExFlags, InstallFlags+ , HaddockFlags, TestFlags, BenchmarkFlags ) -> [String] -> Action-upgradeAction (configFlags, _, _, _, _) _ _ = die' verbosity $+upgradeAction (configFlags, _, _, _, _, _) _ _ = die' verbosity $ "Use the 'cabal install' command instead of 'cabal upgrade'.\n" ++ "You can install the latest version of a package using 'cabal install'. " ++ "The 'cabal upgrade' command has been removed because people found it "
− tests/README.md
@@ -1,27 +0,0 @@-Integration Tests-=================--Each test is a shell script. Tests that share files (e.g., `.cabal` files) are-grouped under a common sub-directory of [IntegrationTests]. The framework-copies the whole group's directory before running each test, which allows tests-to reuse files, yet run independently. A group's tests are further divided into-`should_run` and `should_fail` directories, based on the expected exit status.-For example, the test-`IntegrationTests/exec/should_fail/exit_with_failure_without_args.sh` has access-to all files under `exec` and is expected to fail.--Tests can specify their expected output. For a test named `x.sh`, `x.out`-specifies `stdout` and `x.err` specifies `stderr`. Both files are optional.-The framework expects an exact match between lines in the file and output,-except for lines beginning with "RE:", which are interpreted as regular-expressions.--[IntegrationTests.hs] defines several environment variables:--* `CABAL` - The path to the executable being tested.-* `GHC_PKG` - The path to ghc-pkg.-* `CABAL_ARGS` - A common set of arguments for running cabal.-* `CABAL_ARGS_NO_CONFIG_FILE` - `CABAL_ARGS` without `--config-file`.--[IntegrationTests]: IntegrationTests-[IntegrationTests.hs]: IntegrationTests.hs