cabal-install-bundle 0.10.2.1 → 0.14.0
raw patch · 35 files changed
+2940/−1219 lines, 35 filesdep ~Cabal
Dependency ranges changed: Cabal
Files
- Distribution/Client/BuildReports/Anonymous.hs +8/−4
- Distribution/Client/BuildReports/Storage.hs +4/−4
- Distribution/Client/BuildReports/Types.hs +1/−1
- Distribution/Client/BuildReports/Upload.hs +1/−3
- Distribution/Client/Config.hs +39/−7
- Distribution/Client/Configure.hs +59/−37
- Distribution/Client/Dependency.hs +164/−91
- Distribution/Client/Dependency/TopDown.hs +344/−178
- Distribution/Client/Dependency/TopDown/Constraints.hs +471/−187
- Distribution/Client/Dependency/TopDown/Types.hs +27/−29
- Distribution/Client/Dependency/Types.hs +98/−8
- Distribution/Client/Fetch.hs +33/−15
- Distribution/Client/Haddock.hs +10/−13
- Distribution/Client/HttpUtils.hs +23/−15
- Distribution/Client/IndexUtils.hs +275/−75
- Distribution/Client/Init.hs +250/−87
- Distribution/Client/Init/Heuristics.hs +49/−11
- Distribution/Client/Init/Licenses.hs +1/−1
- Distribution/Client/Init/Types.hs +5/−0
- Distribution/Client/Install.hs +291/−109
- Distribution/Client/InstallPlan.hs +14/−15
- Distribution/Client/InstallSymlink.hs +3/−3
- Distribution/Client/List.hs +101/−96
- Distribution/Client/PackageIndex.hs +11/−2
- Distribution/Client/Setup.hs +297/−92
- Distribution/Client/SetupWrapper.hs +13/−6
- Distribution/Client/SrcDist.hs +108/−28
- Distribution/Client/Tar.hs +1/−1
- Distribution/Client/Targets.hs +139/−36
- Distribution/Client/Types.hs +37/−13
- Distribution/Client/Unpack.hs +9/−7
- Distribution/Client/Update.hs +6/−4
- Distribution/Client/Upload.hs +18/−23
- Main.hs +28/−16
- cabal-install-bundle.cabal +2/−2
Distribution/Client/BuildReports/Anonymous.hs view
@@ -56,9 +56,9 @@ import qualified Distribution.Compat.ReadP as Parse ( ReadP, pfail, munch1, skipSpaces )-import qualified Text.PrettyPrint.HughesPJ as Disp+import qualified Text.PrettyPrint as Disp ( Doc, render, char, text )-import Text.PrettyPrint.HughesPJ+import Text.PrettyPrint ( (<+>), (<>) ) import Data.List@@ -112,6 +112,7 @@ | SetupFailed | ConfigureFailed | BuildFailed+ | TestsFailed | InstallFailed | InstallOk deriving Eq@@ -122,7 +123,7 @@ new :: OS -> Arch -> CompilerId -- -> Version -> ConfiguredPackage -> BR.BuildResult -> BuildReport-new os' arch' comp (ConfiguredPackage pkg flags deps) result =+new os' arch' comp (ConfiguredPackage pkg flags _ deps) result = BuildReport { package = packageId pkg, os = os',@@ -143,6 +144,7 @@ Left (BR.UnpackFailed _) -> UnpackFailed Left (BR.ConfigureFailed _) -> ConfigureFailed Left (BR.BuildFailed _) -> BuildFailed+ Left (BR.TestsFailed _) -> TestsFailed Left (BR.InstallFailed _) -> InstallFailed Right (BR.BuildOk _ _) -> InstallOk convertDocsOutcome = case result of@@ -151,9 +153,9 @@ Right (BR.BuildOk BR.DocsFailed _) -> Failed Right (BR.BuildOk BR.DocsOk _) -> Ok convertTestsOutcome = case result of+ Left (BR.TestsFailed _) -> Failed Left _ -> NotTried Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried- Right (BR.BuildOk _ BR.TestsFailed) -> Failed Right (BR.BuildOk _ BR.TestsOk) -> Ok cabalInstallID :: PackageIdentifier@@ -280,6 +282,7 @@ disp SetupFailed = Disp.text "SetupFailed" disp ConfigureFailed = Disp.text "ConfigureFailed" disp BuildFailed = Disp.text "BuildFailed"+ disp TestsFailed = Disp.text "TestsFailed" disp InstallFailed = Disp.text "InstallFailed" disp InstallOk = Disp.text "InstallOk" @@ -294,6 +297,7 @@ "SetupFailed" -> return SetupFailed "ConfigureFailed" -> return ConfigureFailed "BuildFailed" -> return BuildFailed+ "TestsFailed" -> return TestsFailed "InstallFailed" -> return InstallFailed "InstallOk" -> return InstallOk _ -> Parse.pfail
Distribution/Client/BuildReports/Storage.hs view
@@ -116,12 +116,12 @@ -> Maybe (BuildReport, Repo) fromPlanPackage (Platform arch os) comp planPackage = case planPackage of - InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {- packageSource = RepoTarballPackage repo _ _ }) _ _) result+ InstallPlan.Installed pkg@(ConfiguredPackage (SourcePackage {+ packageSource = RepoTarballPackage repo _ _ }) _ _ _) result -> Just $ (BuildReport.new os arch comp pkg (Right result), repo) - InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage {- packageSource = RepoTarballPackage repo _ _ }) _ _) result+ InstallPlan.Failed pkg@(ConfiguredPackage (SourcePackage {+ packageSource = RepoTarballPackage repo _ _ }) _ _ _) result -> Just $ (BuildReport.new os arch comp pkg (Left result), repo) _ -> Nothing
Distribution/Client/BuildReports/Types.hs view
@@ -19,7 +19,7 @@ import qualified Distribution.Compat.ReadP as Parse ( pfail, munch1 )-import qualified Text.PrettyPrint.HughesPJ as Disp+import qualified Text.PrettyPrint as Disp ( text ) import Data.Char as Char
Distribution/Client/BuildReports/Upload.hs view
@@ -29,10 +29,8 @@ type BuildLog = String uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]- -> BrowserAction (HandleStream String) () -> BrowserAction (HandleStream BuildLog) ()-uploadReports uri reports auth = do- auth+uploadReports uri reports = do forM_ reports $ \(report, mbBuildLog) -> do buildId <- postBuildReport uri report case mbBuildLog of
Distribution/Client/Config.hs view
@@ -37,16 +37,19 @@ , ReportFlags(..), reportCommand , showRepo, parseRepo ) +import Distribution.Simple.Compiler+ ( OptimisationLevel(..) ) import Distribution.Simple.Setup ( ConfigFlags(..), configureOptions, defaultConfigFlags , installDirsOptions- , Flag, toFlag, flagToMaybe, fromFlagOrDefault )+ , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.InstallDirs ( InstallDirs(..), defaultInstallDirs , PathTemplate, toPathTemplate ) import Distribution.ParseUtils ( FieldDescr(..), liftField- , ParseResult(..), locatedErrorMsg, showPWarning+ , ParseResult(..), PError(..), PWarning(..)+ , locatedErrorMsg, showPWarning , readFields, warning, lineNo , simpleField, listField, parseFilePathQ, parseTokenQ ) import qualified Distribution.ParseUtils as ParseUtils@@ -76,9 +79,9 @@ import qualified Data.Map as Map import qualified Distribution.Compat.ReadP as Parse ( option )-import qualified Text.PrettyPrint.HughesPJ as Disp+import qualified Text.PrettyPrint as Disp ( Doc, render, text, colon, vcat, empty, isEmpty, nest )-import Text.PrettyPrint.HughesPJ+import Text.PrettyPrint ( (<>), (<+>), ($$), ($+$) ) import System.Directory ( createDirectoryIfMissing, getAppUserDataDirectory )@@ -343,7 +346,7 @@ ++ toSavedConfig liftConfigFlag (configureOptions ParseArgs)- (["builddir", "configure-option"] ++ map fieldName installDirsFields)+ (["builddir", "configure-option", "constraint"] ++ map fieldName installDirsFields) --FIXME: this is only here because viewAsFieldDescr gives us a parser -- that only recognises 'ghc' etc, the case-sensitive flag names, not@@ -351,6 +354,31 @@ [simpleField "compiler" (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse) configHcFlavor (\v flags -> flags { configHcFlavor = v })+ -- TODO: The following is a temporary fix. The "optimization" field is+ -- OptArg, and viewAsFieldDescr fails on that. Instead of a hand-written+ -- hackaged parser and printer, we should handle this case properly in+ -- the library.+ ,liftField configOptimization (\v flags -> flags { configOptimization = v }) $+ let name = "optimization" in+ FieldDescr name+ (\f -> case f of+ Flag NoOptimisation -> Disp.text "False"+ Flag NormalOptimisation -> Disp.text "True"+ Flag MaximumOptimisation -> Disp.text "2"+ _ -> Disp.empty)+ (\line str _ -> case () of+ _ | str == "False" -> ParseOk [] (Flag NoOptimisation)+ | str == "True" -> ParseOk [] (Flag NormalOptimisation)+ | str == "0" -> ParseOk [] (Flag NoOptimisation)+ | str == "1" -> ParseOk [] (Flag NormalOptimisation)+ | str == "2" -> ParseOk [] (Flag MaximumOptimisation)+ | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)+ | lstr == "true" -> ParseOk [caseWarning] (Flag NormalOptimisation)+ | otherwise -> ParseFailed (NoParse name line)+ where+ lstr = lowercase str+ caseWarning = PWarning $+ "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'.") ] ++ toSavedConfig liftConfigExFlag@@ -359,7 +387,7 @@ ++ toSavedConfig liftInstallFlag (installOptions ParseArgs)- ["dry-run", "reinstall", "only"] []+ ["dry-run", "only"] [] ++ toSavedConfig liftUploadFlag (commandOptions uploadCommand ParseArgs)@@ -367,7 +395,11 @@ ++ toSavedConfig liftReportFlag (commandOptions reportCommand ParseArgs)- ["verbose"] []+ ["verbose", "username", "password"] []+ --FIXME: this is a hack, hiding the username and password.+ -- But otherwise it masks the upload ones. Either need to+ -- share the options or make then distinct. In any case+ -- they should probably be per-server. where toSavedConfig lift options exclusions replacements =
Distribution/Client/Configure.hs view
@@ -18,20 +18,22 @@ import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.IndexUtils as IndexUtils- ( getAvailablePackages, getInstalledPackages )+ ( getSourcePackages, getInstalledPackages ) import Distribution.Client.Setup ( ConfigExFlags(..), configureCommand, filterConfigureFlags )-import Distribution.Client.Types as Available+import Distribution.Client.Types as Source import Distribution.Client.SetupWrapper ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )+import Distribution.Client.Targets+ ( userToPackageConstraint ) import Distribution.Simple.Compiler ( CompilerId(..), Compiler(compilerId) , PackageDB(..), PackageDBStack ) import Distribution.Simple.Program (ProgramConfiguration ) import Distribution.Simple.Setup- ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault )-import Distribution.Client.PackageIndex (PackageIndex)+ ( ConfigFlags(..), fromFlag, toFlag, flagToMaybe, fromFlagOrDefault )+import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Simple.Utils ( defaultPackageDesc ) import Distribution.Package@@ -64,11 +66,11 @@ configure verbosity packageDBs repos comp conf configFlags configExFlags extraArgs = do - installed <- getInstalledPackages verbosity comp packageDBs conf- available <- getAvailablePackages verbosity repos+ installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+ sourcePkgDb <- getSourcePackages verbosity repos progress <- planLocalPackage verbosity comp configFlags configExFlags- installed available+ installedPkgIndex sourcePkgDb notice verbosity "Resolving dependencies..." maybePlan <- foldProgress logMsg (return . Left) (return . Right)@@ -76,15 +78,15 @@ case maybePlan of Left message -> do info verbosity message- setupWrapper verbosity (setupScriptOptions installed) Nothing+ setupWrapper verbosity (setupScriptOptions installedPkgIndex) Nothing configureCommand (const configFlags) extraArgs Right installPlan -> case InstallPlan.ready installPlan of- [pkg@(ConfiguredPackage (AvailablePackage _ _ (LocalUnpackedPackage _)) _ _)] ->+ [pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _)) _ _ _)] -> configurePackage verbosity (InstallPlan.planPlatform installPlan) (InstallPlan.planCompiler installPlan)- (setupScriptOptions installed)+ (setupScriptOptions installedPkgIndex) configFlags pkg extraArgs _ -> die $ "internal error: configure install plan should have exactly "@@ -95,15 +97,8 @@ useCabalVersion = maybe anyVersion thisVersion (flagToMaybe (configCabalVersion configExFlags)), useCompiler = Just comp,- -- Hack: we typically want to allow the UserPackageDB for finding the- -- Cabal lib when compiling any Setup.hs even if we're doing a global- -- install. However we also allow looking in a specific package db.- usePackageDB = if UserPackageDB `elem` packageDBs- then packageDBs- else packageDBs ++ [UserPackageDB],- usePackageIndex = if UserPackageDB `elem` packageDBs- then Just index- else Nothing,+ usePackageDB = packageDBs',+ usePackageIndex = index', useProgramConfig = conf, useDistPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)@@ -111,6 +106,16 @@ useLoggingHandle = Nothing, useWorkingDir = Nothing }+ where+ -- Hack: we typically want to allow the UserPackageDB for finding the+ -- Cabal lib when compiling any Setup.hs even if we're doing a global+ -- install. However we also allow looking in a specific package db.+ (packageDBs', index') =+ case packageDBs of+ (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs+ -> (GlobalPackageDB:UserPackageDB:dbs, Nothing)+ -- but if the user is using an odd db stack, don't touch it+ dbs -> (dbs, Just index) logMsg message rest = debug verbosity message >> rest @@ -119,20 +124,25 @@ -- planLocalPackage :: Verbosity -> Compiler -> ConfigFlags -> ConfigExFlags- -> PackageIndex InstalledPackage- -> AvailablePackageDb+ -> PackageIndex+ -> SourcePackageDb -> IO (Progress String String InstallPlan)-planLocalPackage verbosity comp configFlags configExFlags installed- (AvailablePackageDb _ availablePrefs) = do+planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex+ (SourcePackageDb _ packagePrefs) = do pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity+ solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerId comp) let -- We create a local package and ask to resolve a dependency on it- localPkg = AvailablePackage {- packageInfoId = packageId pkg,- Available.packageDescription = pkg,- packageSource = LocalUnpackedPackage "."+ localPkg = SourcePackage {+ packageInfoId = packageId pkg,+ Source.packageDescription = pkg,+ packageSource = LocalUnpackedPackage "." } + testsEnabled = fromFlagOrDefault False $ configTests configFlags+ benchmarksEnabled =+ fromFlagOrDefault False $ configBenchmarks configFlags+ resolverParams = addPreferences@@ -142,23 +152,33 @@ . addConstraints -- version constraints from the config file or command line- [ PackageVersionConstraint name ver- | Dependency name ver <- configConstraints configFlags ]+ -- TODO: should warn or error on constraints that are not on direct deps+ -- or flag constraints not on the package in question.+ (map userToPackageConstraint (configExConstraints configExFlags)) . addConstraints -- package flags from the config file or command line- [ PackageFlagsConstraint (packageName pkg)+ [ PackageConstraintFlags (packageName pkg) (configConfigurationsFlags configFlags) ] + . addConstraints+ -- '--enable-tests' and '--enable-benchmarks' constraints from+ -- command line+ [ PackageConstraintStanzas (packageName pkg) $ concat+ [ if testsEnabled then [TestStanzas] else []+ , if benchmarksEnabled then [BenchStanzas] else []+ ]+ ]+ $ standardInstallPolicy- installed- (AvailablePackageDb mempty availablePrefs)+ installedPkgIndex+ (SourcePackageDb mempty packagePrefs) [SpecificSourcePackage localPkg] - return (resolveDependencies buildPlatform (compilerId comp) resolverParams)+ return (resolveDependencies buildPlatform (compilerId comp) solver resolverParams) --- | Call an installer for an 'AvailablePackage' but override the configure+-- | Call an installer for an 'SourcePackage' but override the configure -- flags with the ones given by the 'ConfiguredPackage'. In particular the -- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly -- versioned package dependencies. So we ignore any previous partial flag@@ -172,7 +192,7 @@ -> [String] -> IO () configurePackage verbosity platform comp scriptOptions configFlags- (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs =+ (ConfiguredPackage (SourcePackage _ gpkg _) flags stanzas deps) extraArgs = setupWrapper verbosity scriptOptions (Just pkg) configureCommand configureFlags extraArgs@@ -181,11 +201,13 @@ configureFlags = filterConfigureFlags configFlags { configConfigurationsFlags = flags, configConstraints = map thisPackageVersion deps,- configVerbosity = toFlag verbosity+ configVerbosity = toFlag verbosity,+ configBenchmarks = toFlag (BenchStanzas `elem` stanzas),+ configTests = toFlag (TestStanzas `elem` stanzas) } pkg = case finalizePackageDescription flags (const True)- platform comp [] gpkg of+ platform comp [] (enableStanzas stanzas gpkg) of Left _ -> error "finalizePackageDescription ConfiguredPackage failed" Right (desc, _) -> desc
Distribution/Client/Dependency.hs view
@@ -14,6 +14,7 @@ ----------------------------------------------------------------------------- module Distribution.Client.Dependency ( -- * The main package dependency resolver+ chooseSolver, resolveDependencies, Progress(..), foldProgress,@@ -42,44 +43,57 @@ addConstraints, addPreferences, setPreferenceDefault,- addAvailablePackages,- hideInstalledPackagesSpecific,+ setReorderGoals,+ setIndependentGoals,+ setAvoidReinstalls,+ setShadowPkgs,+ setMaxBackjumps,+ addSourcePackages,+ hideInstalledPackagesSpecificByInstalledPackageId,+ hideInstalledPackagesSpecificBySourcePackageId, hideInstalledPackagesAllVersions, ) where -import Distribution.Client.Dependency.TopDown (topDownResolver)+import Distribution.Client.Dependency.TopDown+ ( topDownResolver )+import Distribution.Client.Dependency.Modular+ ( modularResolver, SolverConfig(..) ) import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (PackageIndex)+import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.Types- ( AvailablePackageDb(AvailablePackageDb)- , AvailablePackage(..), InstalledPackage )+ ( SourcePackageDb(SourcePackageDb)+ , SourcePackage(..) ) import Distribution.Client.Dependency.Types- ( DependencyResolver, PackageConstraint(..)+ ( PreSolver(..), Solver(..), DependencyResolver, PackageConstraint(..) , PackagePreferences(..), InstalledPreference(..)+ , PackagesPreferenceDefault(..) , Progress(..), foldProgress ) import Distribution.Client.Targets+import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package ( PackageName(..), PackageId, Package(..), packageVersion- , Dependency(Dependency))+ , InstalledPackageId, Dependency(Dependency)) import Distribution.Version- ( VersionRange, anyVersion, withinRange, simplifyVersionRange )+ ( Version(..), VersionRange, anyVersion, withinRange, simplifyVersionRange ) import Distribution.Compiler- ( CompilerId(..) )+ ( CompilerId(..), CompilerFlavor(..) ) import Distribution.System ( Platform )-import Distribution.Simple.Utils (comparing)+import Distribution.Simple.Utils+ ( comparing, warn, info ) import Distribution.Text ( display )+import Distribution.Verbosity+ ( Verbosity ) import Data.List (maximumBy, foldl')-import Data.Maybe (fromMaybe, isJust)+import Data.Maybe (fromMaybe) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Set (Set) - -- ------------------------------------------------------------ -- * High level planner policy -- ------------------------------------------------------------@@ -93,36 +107,16 @@ depResolverConstraints :: [PackageConstraint], depResolverPreferences :: [PackagePreference], depResolverPreferenceDefault :: PackagesPreferenceDefault,- depResolverInstalled :: PackageIndex InstalledPackage,- depResolverAvailable :: PackageIndex AvailablePackage+ depResolverInstalledPkgIndex :: InstalledPackageIndex.PackageIndex,+ depResolverSourcePkgIndex :: PackageIndex.PackageIndex SourcePackage,+ depResolverReorderGoals :: Bool,+ depResolverIndependentGoals :: Bool,+ depResolverAvoidReinstalls :: Bool,+ depResolverShadowPkgs :: Bool,+ depResolverMaxBackjumps :: Maybe Int } --- | Global policy for all packages to say if we prefer package versions that--- are already installed locally or if we just prefer the latest available.----data PackagesPreferenceDefault =-- -- | Always prefer the latest version irrespective of any existing- -- installed version.- --- -- * This is the standard policy for upgrade.- --- PreferAllLatest-- -- | Always prefer the installed versions over ones that would need to be- -- installed. Secondarily, prefer latest versions (eg the latest installed- -- version or if there are none then the latest available version).- | PreferAllInstalled-- -- | Prefer the latest version for packages that are explicitly requested- -- but prefers the installed version for any other packages.- --- -- * This is the standard policy for install.- --- | PreferLatestForSelected-- -- | A package selection preference for a particular package. -- -- Preferences are soft constraints that the dependency resolver should try to@@ -137,17 +131,22 @@ -- | If we prefer versions of packages that are already installed. | PackageInstalledPreference PackageName InstalledPreference -basicDepResolverParams :: PackageIndex InstalledPackage- -> PackageIndex AvailablePackage+basicDepResolverParams :: InstalledPackageIndex.PackageIndex+ -> PackageIndex.PackageIndex SourcePackage -> DepResolverParams-basicDepResolverParams installed available =+basicDepResolverParams installedPkgIndex sourcePkgIndex = DepResolverParams { depResolverTargets = [], depResolverConstraints = [], depResolverPreferences = [], depResolverPreferenceDefault = PreferLatestForSelected,- depResolverInstalled = installed,- depResolverAvailable = available+ depResolverInstalledPkgIndex = installedPkgIndex,+ depResolverSourcePkgIndex = sourcePkgIndex,+ depResolverReorderGoals = False,+ depResolverIndependentGoals = False,+ depResolverAvoidReinstalls = False,+ depResolverShadowPkgs = False,+ depResolverMaxBackjumps = Nothing } addTargets :: [PackageName]@@ -180,12 +179,42 @@ depResolverPreferenceDefault = preferenceDefault } +setReorderGoals :: Bool -> DepResolverParams -> DepResolverParams+setReorderGoals b params =+ params {+ depResolverReorderGoals = b+ }++setIndependentGoals :: Bool -> DepResolverParams -> DepResolverParams+setIndependentGoals b params =+ params {+ depResolverIndependentGoals = b+ }++setAvoidReinstalls :: Bool -> DepResolverParams -> DepResolverParams+setAvoidReinstalls b params =+ params {+ depResolverAvoidReinstalls = b+ }++setShadowPkgs :: Bool -> DepResolverParams -> DepResolverParams+setShadowPkgs b params =+ params {+ depResolverShadowPkgs = b+ }++setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams+setMaxBackjumps n params =+ params {+ depResolverMaxBackjumps = n+ }+ dontUpgradeBasePackage :: DepResolverParams -> DepResolverParams dontUpgradeBasePackage params = addConstraints extraConstraints params where extraConstraints =- [ PackageInstalledConstraint pkgname+ [ PackageConstraintInstalled pkgname | all (/=PackageName "base") (depResolverTargets params) , pkgname <- [ PackageName "base", PackageName "ghc-prim" ] , isInstalled pkgname ]@@ -193,45 +222,59 @@ -- below when there are no targets and thus no dep on base. -- Need to refactor contraints separate from needing packages. isInstalled = not . null- . PackageIndex.lookupPackageName (depResolverInstalled params)+ . InstalledPackageIndex.lookupPackageName+ (depResolverInstalledPkgIndex params) -addAvailablePackages :: [AvailablePackage]- -> DepResolverParams -> DepResolverParams-addAvailablePackages pkgs params =+addSourcePackages :: [SourcePackage]+ -> DepResolverParams -> DepResolverParams+addSourcePackages pkgs params = params {- depResolverAvailable = foldl (flip PackageIndex.insert)- (depResolverAvailable params) pkgs+ depResolverSourcePkgIndex =+ foldl (flip PackageIndex.insert)+ (depResolverSourcePkgIndex params) pkgs } -hideInstalledPackagesSpecific :: [PackageId]- -> DepResolverParams -> DepResolverParams-hideInstalledPackagesSpecific pkgids params =+hideInstalledPackagesSpecificByInstalledPackageId :: [InstalledPackageId]+ -> DepResolverParams -> DepResolverParams+hideInstalledPackagesSpecificByInstalledPackageId pkgids params = --TODO: this should work using exclude constraints instead params {- depResolverInstalled = foldl' (flip PackageIndex.deletePackageId)- (depResolverInstalled params) pkgids+ depResolverInstalledPkgIndex =+ foldl' (flip InstalledPackageIndex.deleteInstalledPackageId)+ (depResolverInstalledPkgIndex params) pkgids } +hideInstalledPackagesSpecificBySourcePackageId :: [PackageId]+ -> DepResolverParams -> DepResolverParams+hideInstalledPackagesSpecificBySourcePackageId pkgids params =+ --TODO: this should work using exclude constraints instead+ params {+ depResolverInstalledPkgIndex =+ foldl' (flip InstalledPackageIndex.deleteSourcePackageId)+ (depResolverInstalledPkgIndex params) pkgids+ }+ hideInstalledPackagesAllVersions :: [PackageName] -> DepResolverParams -> DepResolverParams hideInstalledPackagesAllVersions pkgnames params = --TODO: this should work using exclude constraints instead params {- depResolverInstalled =- foldl' (flip PackageIndex.deletePackageName)- (depResolverInstalled params) pkgnames+ depResolverInstalledPkgIndex =+ foldl' (flip InstalledPackageIndex.deletePackageName)+ (depResolverInstalledPkgIndex params) pkgnames } hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams hideBrokenInstalledPackages params =- hideInstalledPackagesSpecific pkgids params+ hideInstalledPackagesSpecificByInstalledPackageId pkgids params where- pkgids = map packageId- . PackageIndex.reverseDependencyClosure (depResolverInstalled params)- . map (packageId . fst)- . PackageIndex.brokenPackages- $ depResolverInstalled params+ pkgids = map Installed.installedPackageId+ . InstalledPackageIndex.reverseDependencyClosure+ (depResolverInstalledPkgIndex params)+ . map (Installed.installedPackageId . fst)+ . InstalledPackageIndex.brokenPackages+ $ depResolverInstalledPkgIndex params upgradeDependencies :: DepResolverParams -> DepResolverParams@@ -243,16 +286,17 @@ hideInstalledPackagesAllVersions (depResolverTargets params) params -standardInstallPolicy :: PackageIndex InstalledPackage- -> AvailablePackageDb- -> [PackageSpecifier AvailablePackage]+standardInstallPolicy :: InstalledPackageIndex.PackageIndex+ -> SourcePackageDb+ -> [PackageSpecifier SourcePackage] -> DepResolverParams standardInstallPolicy- installed (AvailablePackageDb available availablePrefs) pkgSpecifiers+ installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs)+ pkgSpecifiers = addPreferences [ PackageVersionPreference name ver- | (name, ver) <- Map.toList availablePrefs ]+ | (name, ver) <- Map.toList sourcePkgPrefs ] . addConstraints (concatMap pkgSpecifierConstraints pkgSpecifiers)@@ -260,23 +304,35 @@ . addTargets (map pkgSpecifierTarget pkgSpecifiers) - . hideInstalledPackagesSpecific+ . hideInstalledPackagesSpecificBySourcePackageId [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] - . addAvailablePackages+ . addSourcePackages [ pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] $ basicDepResolverParams- installed available+ installedPkgIndex sourcePkgIndex -- ------------------------------------------------------------ -- * Interface to the standard resolver -- ------------------------------------------------------------ -defaultResolver :: DependencyResolver-defaultResolver = topDownResolver+chooseSolver :: Verbosity -> PreSolver -> CompilerId -> IO Solver+chooseSolver _ AlwaysTopDown _ = return TopDown+chooseSolver _ AlwaysModular _ = return Modular+chooseSolver verbosity Choose (CompilerId f v) = do+ let chosenSolver | f == GHC && v <= Version [7] [] = TopDown+ | otherwise = Modular+ msg TopDown = warn verbosity "Falling back to topdown solver for GHC < 7."+ msg Modular = info verbosity "Choosing modular solver."+ msg chosenSolver+ return chosenSolver +runSolver :: Solver -> SolverConfig -> DependencyResolver+runSolver TopDown = const topDownResolver -- TODO: warn about unsuported options+runSolver Modular = modularResolver+ -- | Run the dependency solver. -- -- Since this is potentially an expensive operation, the result is wrapped in a@@ -285,26 +341,40 @@ -- resolveDependencies :: Platform -> CompilerId+ -> Solver -> DepResolverParams -> Progress String String InstallPlan --TODO: is this needed here? see dontUpgradeBasePackage-resolveDependencies platform comp params+resolveDependencies platform comp _solver params | null (depResolverTargets params) = return (mkInstallPlan platform comp []) -resolveDependencies platform comp params =+resolveDependencies platform comp solver params = fmap (mkInstallPlan platform comp)- $ defaultResolver platform comp installed available- preferences constraints targets+ $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls shadowing maxBkjumps)+ platform comp installedPkgIndex sourcePkgIndex+ preferences constraints targets where DepResolverParams targets constraints prefs defpref- installed available = dontUpgradeBasePackage- . hideBrokenInstalledPackages- $ params+ installedPkgIndex+ sourcePkgIndex+ reorderGoals+ indGoals+ noReinstalls+ shadowing+ maxBkjumps = dontUpgradeBasePackage+ -- TODO:+ -- The modular solver can properly deal with broken packages+ -- and won't select them. So the 'hideBrokenInstalledPackages'+ -- function should be moved into a module that is specific+ -- to the Topdown solver.+ . (if solver /= Modular then hideBrokenInstalledPackages+ else id)+ $ params preferences = interpretPackagesPreference (Set.fromList targets) defpref prefs@@ -316,8 +386,8 @@ mkInstallPlan :: Platform -> CompilerId -> [InstallPlan.PlanPackage] -> InstallPlan-mkInstallPlan platform comp pkgs =- case InstallPlan.new platform comp (PackageIndex.fromList pkgs) of+mkInstallPlan platform comp pkgIndex =+ case InstallPlan.new platform comp (PackageIndex.fromList pkgIndex) of Right plan -> plan Left problems -> error $ unlines $ "internal error: could not construct a valid install plan."@@ -375,12 +445,13 @@ -- It simply means preferences for installed packages will be ignored. -- resolveWithoutDependencies :: DepResolverParams- -> Either [ResolveNoDepsError] [AvailablePackage]+ -> Either [ResolveNoDepsError] [SourcePackage] resolveWithoutDependencies (DepResolverParams targets constraints- prefs defpref installed available) =+ prefs defpref installedPkgIndex sourcePkgIndex+ _reorderGoals _indGoals _avoidReinstalls _shadowing _maxBjumps) = collectEithers (map selectPackage targets) where- selectPackage :: PackageName -> Either ResolveNoDepsError AvailablePackage+ selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage selectPackage pkgname | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions | otherwise = Right $! maximumBy bestByPrefs choices@@ -389,7 +460,8 @@ -- Constraints requiredVersions = packageConstraints pkgname pkgDependency = Dependency pkgname requiredVersions- choices = PackageIndex.lookupDependency available pkgDependency+ choices = PackageIndex.lookupDependency sourcePkgIndex+ pkgDependency -- Preferences PackagePreferences preferredVersions preferInstalled@@ -399,7 +471,8 @@ (installPref pkg, versionPref pkg, packageVersion pkg) installPref = case preferInstalled of PreferLatest -> const False- PreferInstalled -> isJust . PackageIndex.lookupPackageId installed+ PreferInstalled -> not . null . InstalledPackageIndex.lookupSourcePackageId+ installedPkgIndex . packageId versionPref pkg = packageVersion pkg `withinRange` preferredVersions @@ -408,7 +481,7 @@ Map.findWithDefault anyVersion pkgname packageVersionConstraintMap packageVersionConstraintMap = Map.fromList [ (name, range)- | PackageVersionConstraint name range <- constraints ]+ | PackageConstraintVersion name range <- constraints ] packagePreferences :: PackageName -> PackagePreferences packagePreferences = interpretPackagesPreference
Distribution/Client/Dependency/TopDown.hs view
@@ -18,11 +18,14 @@ import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints import Distribution.Client.Dependency.TopDown.Constraints ( Satisfiable(..) )+import Distribution.Client.IndexUtils+ ( convert ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan ( PlanPackage(..) ) import Distribution.Client.Types- ( AvailablePackage(..), ConfiguredPackage(..), InstalledPackage(..) )+ ( SourcePackage(..), ConfiguredPackage(..), InstalledPackage(..)+ , enableStanzas ) import Distribution.Client.Dependency.Types ( DependencyResolver, PackageConstraint(..) , PackagePreferences(..), InstalledPreference(..)@@ -31,9 +34,9 @@ import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Client.PackageIndex (PackageIndex) import Distribution.Package- ( PackageName(..), PackageIdentifier, Package(packageId), packageVersion, packageName- , Dependency(Dependency), thisPackageVersion, notThisPackageVersion- , PackageFixedDeps(depends) )+ ( PackageName(..), PackageId, Package(..), packageVersion, packageName+ , Dependency(Dependency), thisPackageVersion+ , simplifyDependency, PackageFixedDeps(depends) ) import Distribution.PackageDescription ( PackageDescription(buildDepends) ) import Distribution.Client.PackageUtils@@ -41,7 +44,7 @@ import Distribution.PackageDescription.Configuration ( finalizePackageDescription, flattenPackageDescription ) import Distribution.Version- ( VersionRange, anyVersion, withinRange, simplifyVersionRange+ ( VersionRange, withinRange, simplifyVersionRange , UpperBound(..), asVersionIntervals ) import Distribution.Compiler ( CompilerId )@@ -53,7 +56,7 @@ ( display ) import Data.List- ( foldl', maximumBy, minimumBy, nub, sort, groupBy )+ ( foldl', maximumBy, minimumBy, nub, sort, sortBy, groupBy ) import Data.Maybe ( fromJust, fromMaybe, catMaybes ) import Data.Monoid@@ -105,9 +108,9 @@ (_, node') = maximumBy (bestByPref pkgname) choice where topSortNumber choice = case fst (head choice) of- InstalledOnly (InstalledPackageEx _ i _) -> i- AvailableOnly (UnconfiguredPackage _ i _) -> i- InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i+ InstalledOnly (InstalledPackageEx _ i _) -> i+ SourceOnly (UnconfiguredPackage _ i _ _) -> i+ InstalledAndSource _ (UnconfiguredPackage _ i _ _) -> i bestByPref pkgname = case packageInstalledPreference of PreferLatest ->@@ -115,8 +118,8 @@ PreferInstalled -> comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p)) where- isInstalled (AvailableOnly _) = False- isInstalled _ = True+ isInstalled (SourceOnly _) = False+ isInstalled _ = True isPreferred p = packageVersion p `withinRange` preferredVersions (PackagePreferences preferredVersions packageInstalledPreference) = pref pkgname@@ -135,7 +138,7 @@ -> Either [Dependency] SelectedPackage -- | (packages selected, packages discarded)-type SelectionChanges = ([SelectedPackage], [PackageIdentifier])+type SelectionChanges = ([SelectedPackage], [PackageId]) searchSpace :: ConfigurePackage -> Constraints@@ -145,6 +148,10 @@ -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) SelectablePackage searchSpace configure constraints selected changes next =+ assert (Set.null (selectedSet `Set.intersection` next)) $+ assert (selectedSet `Set.isSubsetOf` Constraints.packages constraints) $+ assert (next `Set.isSubsetOf` Constraints.packages constraints) $+ ChoiceNode (selected, constraints, changes) [ [ (pkg, select name pkg) | pkg <- PackageIndex.lookupPackageName available name ]@@ -152,15 +159,18 @@ where available = Constraints.choices constraints + selectedSet = Set.fromList (map packageName (PackageIndex.allPackages selected))+ select name pkg = case configure available pkg of Left missing -> Failure $ ConfigureFailed pkg [ (dep, Constraints.conflicting constraints dep) | dep <- missing ]- Right pkg' -> case constrainDeps pkg' newDeps constraints [] of- Left failure -> Failure failure- Right (constraints', newDiscarded) ->- searchSpace configure- constraints' selected' (newSelected, newDiscarded) next'+ Right pkg' ->+ case constrainDeps pkg' newDeps (addDeps constraints newPkgs) [] of+ Left failure -> Failure failure+ Right (constraints', newDiscarded) ->+ searchSpace configure+ constraints' selected' (newSelected, newDiscarded) next' where selected' = foldl' (flip PackageIndex.insert) selected newSelected newSelected =@@ -172,39 +182,45 @@ (PackageIndex.lookupPackageId available pkgid') newPkgs = [ name'- | dep <- newDeps- , let (Dependency name' _) = untagDependency dep+ | (Dependency name' _, _) <- newDeps , null (PackageIndex.lookupPackageName selected' name') ] newDeps = concatMap packageConstraints newSelected next' = Set.delete name $ foldl' (flip Set.insert) next newPkgs -packageConstraints :: SelectedPackage -> [TaggedDependency]+packageConstraints :: SelectedPackage -> [(Dependency, Bool)] packageConstraints = either installedConstraints availableConstraints- . preferAvailable+ . preferSource where- preferAvailable (InstalledOnly pkg) = Left pkg- preferAvailable (AvailableOnly pkg) = Right pkg- preferAvailable (InstalledAndAvailable _ pkg) = Right pkg+ preferSource (InstalledOnly pkg) = Left pkg+ preferSource (SourceOnly pkg) = Right pkg+ preferSource (InstalledAndSource _ pkg) = Right pkg installedConstraints (InstalledPackageEx _ _ deps) =- [ TaggedDependency InstalledConstraint (thisPackageVersion dep)+ [ (thisPackageVersion dep, True) | dep <- deps ]- availableConstraints (SemiConfiguredPackage _ _ deps) =- [ TaggedDependency NoInstalledConstraint dep | dep <- deps ]+ availableConstraints (SemiConfiguredPackage _ _ _ deps) =+ [ (dep, False) | dep <- deps ] -constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints- -> [PackageIdentifier]- -> Either Failure (Constraints, [PackageIdentifier])+addDeps :: Constraints -> [PackageName] -> Constraints+addDeps =+ foldr $ \pkgname cs ->+ case Constraints.addTarget pkgname cs of+ Satisfiable cs' () -> cs'+ _ -> impossible "addDeps unsatisfiable"++constrainDeps :: SelectedPackage -> [(Dependency, Bool)] -> Constraints+ -> [PackageId]+ -> Either Failure (Constraints, [PackageId]) constrainDeps pkg [] cs discard = case addPackageSelectConstraint (packageId pkg) cs of Satisfiable cs' discard' -> Right (cs', discard' ++ discard)- _ -> impossible-constrainDeps pkg (dep:deps) cs discard =- case addPackageDependencyConstraint (packageId pkg) dep cs of+ _ -> impossible "constrainDeps unsatisfiable(1)"+constrainDeps pkg ((dep, installedConstraint):deps) cs discard =+ case addPackageDependencyConstraint (packageId pkg) dep installedConstraint cs of Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard)- Unsatisfiable -> impossible+ Unsatisfiable -> impossible "constrainDeps unsatisfiable(2)" ConflictsWith conflicts ->- Left (DependencyConflict pkg dep conflicts)+ Left (DependencyConflict pkg dep installedConstraint conflicts) -- ------------------------------------------------------------ -- * The main algorithm@@ -226,7 +242,11 @@ -- the standard 'DependencyResolver' interface. -- topDownResolver :: DependencyResolver-topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver'+topDownResolver platform comp installedPkgIndex sourcePkgIndex+ preferences constraints targets =+ mapMessages (topDownResolver' platform comp+ (convert installedPkgIndex) sourcePkgIndex+ preferences constraints targets) where mapMessages :: Progress Log Failure a -> Progress String String a mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done@@ -235,45 +255,60 @@ -- topDownResolver' :: Platform -> CompilerId -> PackageIndex InstalledPackage- -> PackageIndex AvailablePackage+ -> PackageIndex SourcePackage -> (PackageName -> PackagePreferences) -> [PackageConstraint] -> [PackageName] -> Progress Log Failure [PlanPackage]-topDownResolver' platform comp installed available+topDownResolver' platform comp installedPkgIndex sourcePkgIndex preferences constraints targets = fmap (uncurry finalise) . (\cs -> search configure preferences cs initialPkgNames)- =<< addTopLevelConstraints constraints constraintSet+ =<< pruneBottomUp platform comp+ =<< addTopLevelConstraints constraints+ =<< addTopLevelTargets targets emptyConstraintSet where configure = configurePackage platform comp- constraintSet :: Constraints- constraintSet = Constraints.empty- (annotateInstalledPackages topSortNumber installed')- (annotateAvailablePackages constraints topSortNumber available')- (installed', available') = selectNeededSubset installed available- initialPkgNames- topSortNumber = topologicalSortNumbering installed' available'+ emptyConstraintSet :: Constraints+ emptyConstraintSet = Constraints.empty+ (annotateInstalledPackages topSortNumber installedPkgIndex')+ (annotateSourcePackages constraints topSortNumber sourcePkgIndex')+ (installedPkgIndex', sourcePkgIndex') =+ selectNeededSubset installedPkgIndex sourcePkgIndex initialPkgNames+ topSortNumber = topologicalSortNumbering installedPkgIndex' sourcePkgIndex' initialPkgNames = Set.fromList targets finalise selected' constraints' = PackageIndex.allPackages- . fst . improvePlan installed' constraints'+ . fst . improvePlan installedPkgIndex' constraints' . PackageIndex.fromList $ finaliseSelectedPackages preferences selected' constraints' ++addTopLevelTargets :: [PackageName]+ -> Constraints+ -> Progress a Failure Constraints+addTopLevelTargets [] cs = Done cs+addTopLevelTargets (pkg:pkgs) cs =+ case Constraints.addTarget pkg cs of+ Satisfiable cs' () -> addTopLevelTargets pkgs cs'+ Unsatisfiable -> Fail (NoSuchPackage pkg)+ ConflictsWith _conflicts -> impossible "addTopLevelTargets conflicts"++ addTopLevelConstraints :: [PackageConstraint] -> Constraints- -> Progress a Failure Constraints+ -> Progress Log Failure Constraints addTopLevelConstraints [] cs = Done cs-addTopLevelConstraints (PackageFlagsConstraint _ _ :deps) cs =+addTopLevelConstraints (PackageConstraintFlags _ _ :deps) cs = addTopLevelConstraints deps cs -addTopLevelConstraints (PackageVersionConstraint pkg ver:deps) cs =+addTopLevelConstraints (PackageConstraintVersion pkg ver:deps) cs = case addTopLevelVersionConstraint pkg ver cs of- Satisfiable cs' _ ->- addTopLevelConstraints deps cs'+ Satisfiable cs' pkgids ->+ Step (AppliedVersionConstraint pkg ver pkgids)+ (addTopLevelConstraints deps cs') Unsatisfiable -> Fail (TopLevelVersionConstraintUnsatisfiable pkg ver)@@ -281,29 +316,93 @@ ConflictsWith conflicts -> Fail (TopLevelVersionConstraintConflict pkg ver conflicts) -addTopLevelConstraints (PackageInstalledConstraint pkg:deps) cs =+addTopLevelConstraints (PackageConstraintInstalled pkg:deps) cs = case addTopLevelInstalledConstraint pkg cs of- Satisfiable cs' _ -> addTopLevelConstraints deps cs'+ Satisfiable cs' pkgids ->+ Step (AppliedInstalledConstraint pkg InstalledConstraint pkgids)+ (addTopLevelConstraints deps cs') Unsatisfiable ->- Fail (TopLevelInstallConstraintUnsatisfiable pkg)+ Fail (TopLevelInstallConstraintUnsatisfiable pkg InstalledConstraint) ConflictsWith conflicts ->- Fail (TopLevelInstallConstraintConflict pkg conflicts)+ Fail (TopLevelInstallConstraintConflict pkg InstalledConstraint conflicts) +addTopLevelConstraints (PackageConstraintSource pkg:deps) cs =+ case addTopLevelSourceConstraint pkg cs of+ Satisfiable cs' pkgids ->+ Step (AppliedInstalledConstraint pkg SourceConstraint pkgids)+ (addTopLevelConstraints deps cs')++ Unsatisfiable ->+ Fail (TopLevelInstallConstraintUnsatisfiable pkg SourceConstraint)++ ConflictsWith conflicts ->+ Fail (TopLevelInstallConstraintConflict pkg SourceConstraint conflicts)++addTopLevelConstraints (PackageConstraintStanzas _ _ : deps) cs =+ addTopLevelConstraints deps cs++-- | Add exclusion on available packages that cannot be configured.+--+pruneBottomUp :: Platform -> CompilerId+ -> Constraints -> Progress Log Failure Constraints+pruneBottomUp platform comp constraints =+ foldr prune Done (initialPackages constraints) constraints++ where+ prune pkgs rest cs = foldr addExcludeConstraint rest unconfigurable cs+ where+ unconfigurable =+ [ (pkg, missing) -- if necessary we could look up missing reasons+ | (Just pkg', pkg) <- zip (map getSourcePkg pkgs) pkgs+ , Left missing <- [configure cs pkg'] ]++ addExcludeConstraint (pkg, missing) rest cs =+ let reason = ExcludedByConfigureFail missing in+ case addPackageExcludeConstraint (packageId pkg) reason cs of+ Satisfiable cs' [pkgid]| packageId pkg == pkgid+ -> Step (ExcludeUnconfigurable pkgid) (rest cs')+ Satisfiable _ _ -> impossible "pruneBottomUp satisfiable"+ _ -> Fail $ ConfigureFailed pkg+ [ (dep, Constraints.conflicting cs dep)+ | dep <- missing ]++ configure cs (UnconfiguredPackage (SourcePackage _ pkg _) _ flags stanzas) =+ finalizePackageDescription flags (dependencySatisfiable cs)+ platform comp [] (enableStanzas stanzas pkg)+ dependencySatisfiable cs =+ not . null . PackageIndex.lookupDependency (Constraints.choices cs)++ -- collect each group of packages (by name) in reverse topsort order+ initialPackages =+ reverse+ . sortBy (comparing (topSortNumber . head))+ . PackageIndex.allPackagesByName+ . Constraints.choices++ topSortNumber (InstalledOnly (InstalledPackageEx _ i _)) = i+ topSortNumber (SourceOnly (UnconfiguredPackage _ i _ _)) = i+ topSortNumber (InstalledAndSource _ (UnconfiguredPackage _ i _ _)) = i++ getSourcePkg (InstalledOnly _ ) = Nothing+ getSourcePkg (SourceOnly spkg) = Just spkg+ getSourcePkg (InstalledAndSource _ spkg) = Just spkg++ configurePackage :: Platform -> CompilerId -> ConfigurePackage configurePackage platform comp available spkg = case spkg of- InstalledOnly ipkg -> Right (InstalledOnly ipkg)- AvailableOnly apkg -> fmap AvailableOnly (configure apkg)- InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg)- (configure apkg)+ InstalledOnly ipkg -> Right (InstalledOnly ipkg)+ SourceOnly apkg -> fmap SourceOnly (configure apkg)+ InstalledAndSource ipkg apkg -> fmap (InstalledAndSource ipkg)+ (configure apkg) where- configure (UnconfiguredPackage apkg@(AvailablePackage _ p _) _ flags) =+ configure (UnconfiguredPackage apkg@(SourcePackage _ p _) _ flags stanzas) = case finalizePackageDescription flags dependencySatisfiable- platform comp [] p of+ platform comp [] (enableStanzas stanzas p) of Left missing -> Left missing Right (pkg, flags') -> Right $- SemiConfiguredPackage apkg flags' (externalBuildDepends pkg)+ SemiConfiguredPackage apkg flags' stanzas (externalBuildDepends pkg) dependencySatisfiable = not . null . PackageIndex.lookupDependency available @@ -317,7 +416,7 @@ [ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg) | pkg <- PackageIndex.allPackages installed ] where- transitiveDepends :: InstalledPackage -> [PackageIdentifier]+ transitiveDepends :: InstalledPackage -> [PackageId] transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph . fromJust . toVertex . packageId (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed@@ -326,19 +425,24 @@ -- | Annotate each available packages with its topological sort number and any -- user-supplied partial flag assignment. ---annotateAvailablePackages :: [PackageConstraint]- -> (PackageName -> TopologicalSortNumber)- -> PackageIndex AvailablePackage- -> PackageIndex UnconfiguredPackage-annotateAvailablePackages constraints dfsNumber available = PackageIndex.fromList- [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name)- | pkg <- PackageIndex.allPackages available- , let name = packageName pkg ]+annotateSourcePackages :: [PackageConstraint]+ -> (PackageName -> TopologicalSortNumber)+ -> PackageIndex SourcePackage+ -> PackageIndex UnconfiguredPackage+annotateSourcePackages constraints dfsNumber sourcePkgIndex =+ PackageIndex.fromList+ [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name) (stanzasFor name)+ | pkg <- PackageIndex.allPackages sourcePkgIndex+ , let name = packageName pkg ] where flagsFor = fromMaybe [] . flip Map.lookup flagsMap flagsMap = Map.fromList [ (name, flags)- | PackageFlagsConstraint name flags <- constraints ]+ | PackageConstraintFlags name flags <- constraints ]+ stanzasFor = fromMaybe [] . flip Map.lookup stanzasMap+ stanzasMap = Map.fromListWith (++)+ [ (name, stanzas)+ | PackageConstraintStanzas name stanzas <- constraints ] -- | One of the heuristics we use when guessing which path to take in the -- search space is an ordering on the choices we make. It's generally better@@ -352,7 +456,7 @@ -- one possible choice for B in which case we pick that immediately). -- -- To construct these topological sort numbers we combine and flatten the--- installed and available package sets. We consider only dependencies between+-- installed and source package sets. We consider only dependencies between -- named packages, not including versions and for not-yet-configured packages -- we look at all the possible dependencies, not just those under any single -- flag assignment. This means we can actually get impossible combinations of@@ -360,9 +464,9 @@ -- heuristic. -- topologicalSortNumbering :: PackageIndex InstalledPackage- -> PackageIndex AvailablePackage+ -> PackageIndex SourcePackage -> (PackageName -> TopologicalSortNumber)-topologicalSortNumbering installed available =+topologicalSortNumbering installedPkgIndex sourcePkgIndex = \pkgname -> let Just vertex = toVertex pkgname in topologicalSortNumbers Array.! vertex where@@ -370,14 +474,14 @@ (zip (Graph.topSort graph) [0..]) (graph, _, toVertex) = Graph.graphFromEdges $ [ ((), packageName pkg, nub deps)- | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installed+ | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installedPkgIndex , let deps = [ packageName dep | pkg' <- pkgs , dep <- depends pkg' ] ] ++ [ ((), packageName pkg, nub deps)- | pkgs@(pkg:_) <- PackageIndex.allPackagesByName available+ | pkgs@(pkg:_) <- PackageIndex.allPackagesByName sourcePkgIndex , let deps = [ depName- | AvailablePackage _ pkg' _ <- pkgs+ | SourcePackage _ pkg' _ <- pkgs , Dependency depName _ <- buildDepends (flattenPackageDescription pkg') ] ] @@ -387,24 +491,24 @@ -- and looking at the names of all possible dependencies. -- selectNeededSubset :: PackageIndex InstalledPackage- -> PackageIndex AvailablePackage+ -> PackageIndex SourcePackage -> Set PackageName -> (PackageIndex InstalledPackage- ,PackageIndex AvailablePackage)-selectNeededSubset installed available = select mempty mempty+ ,PackageIndex SourcePackage)+selectNeededSubset installedPkgIndex sourcePkgIndex = select mempty mempty where select :: PackageIndex InstalledPackage- -> PackageIndex AvailablePackage+ -> PackageIndex SourcePackage -> Set PackageName -> (PackageIndex InstalledPackage- ,PackageIndex AvailablePackage)- select installed' available' remaining- | Set.null remaining = (installed', available')- | otherwise = select installed'' available'' remaining''+ ,PackageIndex SourcePackage)+ select installedPkgIndex' sourcePkgIndex' remaining+ | Set.null remaining = (installedPkgIndex', sourcePkgIndex')+ | otherwise = select installedPkgIndex'' sourcePkgIndex'' remaining'' where (next, remaining') = Set.deleteFindMin remaining- moreInstalled = PackageIndex.lookupPackageName installed next- moreAvailable = PackageIndex.lookupPackageName available next+ moreInstalled = PackageIndex.lookupPackageName installedPkgIndex next+ moreSource = PackageIndex.lookupPackageName sourcePkgIndex next moreRemaining = -- we filter out packages already included in the indexes -- this avoids an infinite loop if a package depends on itself -- like base-3.0.3.0 with base-4.0.0.0@@ -413,14 +517,18 @@ | pkg <- moreInstalled , dep <- depends pkg ] ++ [ name- | AvailablePackage _ pkg _ <- moreAvailable+ | SourcePackage _ pkg _ <- moreSource , Dependency name _ <- buildDepends (flattenPackageDescription pkg) ]- installed'' = foldl' (flip PackageIndex.insert) installed' moreInstalled- available'' = foldl' (flip PackageIndex.insert) available' moreAvailable- remaining'' = foldl' (flip Set.insert) remaining' moreRemaining- notAlreadyIncluded name = null (PackageIndex.lookupPackageName installed' name)- && null (PackageIndex.lookupPackageName available' name)+ installedPkgIndex'' = foldl' (flip PackageIndex.insert)+ installedPkgIndex' moreInstalled+ sourcePkgIndex'' = foldl' (flip PackageIndex.insert)+ sourcePkgIndex' moreSource+ remaining'' = foldl' (flip Set.insert)+ remaining' moreRemaining+ notAlreadyIncluded name =+ null (PackageIndex.lookupPackageName installedPkgIndex' name)+ && null (PackageIndex.lookupPackageName sourcePkgIndex' name) -- ------------------------------------------------------------ -- * Post processing the solution@@ -434,24 +542,26 @@ map finaliseSelected (PackageIndex.allPackages selected) where remainingChoices = Constraints.choices constraints- finaliseSelected (InstalledOnly ipkg ) = finaliseInstalled ipkg- finaliseSelected (AvailableOnly apkg) = finaliseAvailable Nothing apkg- finaliseSelected (InstalledAndAvailable ipkg apkg) =+ finaliseSelected (InstalledOnly ipkg ) = finaliseInstalled ipkg+ finaliseSelected (SourceOnly apkg) = finaliseSource Nothing apkg+ finaliseSelected (InstalledAndSource ipkg apkg) = case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of- Nothing -> impossible --picked package not in constraints- Just (AvailableOnly _) -> impossible --to constrain to avail only- Just (InstalledOnly _) -> finaliseInstalled ipkg- Just (InstalledAndAvailable _ _) -> finaliseAvailable (Just ipkg) apkg+ --picked package not in constraints+ Nothing -> impossible "finaliseSelected no pkg"+ -- to constrain to avail only:+ Just (SourceOnly _) -> impossible "finaliseSelected src only"+ Just (InstalledOnly _) -> finaliseInstalled ipkg+ Just (InstalledAndSource _ _) -> finaliseSource (Just ipkg) apkg finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg- finaliseAvailable mipkg (SemiConfiguredPackage pkg flags deps) =- InstallPlan.Configured (ConfiguredPackage pkg flags deps')+ finaliseSource mipkg (SemiConfiguredPackage pkg flags stanzas deps) =+ InstallPlan.Configured (ConfiguredPackage pkg flags stanzas deps') where deps' = map (packageId . pickRemaining mipkg) deps pickRemaining mipkg dep@(Dependency _name versionRange) = case PackageIndex.lookupDependency remainingChoices dep of- [] -> impossible+ [] -> impossible "pickRemaining no pkg" [pkg'] -> pkg' remaining -> assert (checkIsPaired remaining) $ maximumBy bestByPref remaining@@ -540,14 +650,14 @@ constraintsOk _ [] constraints = Just constraints constraintsOk pkgid (pkgid':pkgids) constraints =- case addPackageDependencyConstraint pkgid dep constraints of+ case addPackageDependencyConstraint pkgid dep True constraints of Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints' _ -> Nothing where- dep = TaggedDependency InstalledConstraint (thisPackageVersion pkgid')+ dep = thisPackageVersion pkgid' reverseTopologicalOrder :: PackageFixedDeps pkg- => PackageIndex pkg -> [PackageIdentifier]+ => PackageIndex pkg -> [PackageId] reverseTopologicalOrder index = map (packageId . toPkg) . Graph.topSort . Graph.transposeG@@ -558,55 +668,68 @@ -- * Adding and recording constraints -- ------------------------------------------------------------ -addPackageSelectConstraint :: PackageIdentifier -> Constraints+addPackageSelectConstraint :: PackageId -> Constraints -> Satisfiable Constraints- [PackageIdentifier] ExclusionReason-addPackageSelectConstraint pkgid constraints =- Constraints.constrain dep reason constraints+ [PackageId] ExclusionReason+addPackageSelectConstraint pkgid =+ Constraints.constrain pkgname constraint reason where- dep = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid)- reason = SelectedOther pkgid+ pkgname = packageName pkgid+ constraint ver _ = ver == packageVersion pkgid+ reason = SelectedOther pkgid -addPackageExcludeConstraint :: PackageIdentifier -> Constraints+addPackageExcludeConstraint :: PackageId -> ExclusionReason+ -> Constraints -> Satisfiable Constraints- [PackageIdentifier] ExclusionReason-addPackageExcludeConstraint pkgid constraints =- Constraints.constrain dep reason constraints+ [PackageId] ExclusionReason+addPackageExcludeConstraint pkgid reason =+ Constraints.constrain pkgname constraint reason where- dep = TaggedDependency NoInstalledConstraint- (notThisPackageVersion pkgid)- reason = ExcludedByConfigureFail+ pkgname = packageName pkgid+ constraint ver installed+ | ver == packageVersion pkgid = installed+ | otherwise = True -addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints+addPackageDependencyConstraint :: PackageId -> Dependency -> Bool+ -> Constraints -> Satisfiable Constraints- [PackageIdentifier] ExclusionReason-addPackageDependencyConstraint pkgid dep constraints =- Constraints.constrain dep reason constraints+ [PackageId] ExclusionReason+addPackageDependencyConstraint pkgid dep@(Dependency pkgname verrange)+ installedConstraint =+ Constraints.constrain pkgname constraint reason where- reason = ExcludedByPackageDependency pkgid dep+ constraint ver installed = ver `withinRange` verrange+ && if installedConstraint then installed else True+ reason = ExcludedByPackageDependency pkgid dep installedConstraint addTopLevelVersionConstraint :: PackageName -> VersionRange -> Constraints -> Satisfiable Constraints- [PackageIdentifier] ExclusionReason-addTopLevelVersionConstraint pkg ver constraints =- Constraints.constrain taggedDep reason constraints+ [PackageId] ExclusionReason+addTopLevelVersionConstraint pkgname verrange =+ Constraints.constrain pkgname constraint reason where- dep = Dependency pkg ver- taggedDep = TaggedDependency NoInstalledConstraint dep- reason = ExcludedByTopLevelDependency dep+ constraint ver _installed = ver `withinRange` verrange+ reason = ExcludedByTopLevelConstraintVersion pkgname verrange -addTopLevelInstalledConstraint :: PackageName- -> Constraints- -> Satisfiable Constraints- [PackageIdentifier] ExclusionReason-addTopLevelInstalledConstraint pkg constraints =- Constraints.constrain taggedDep reason constraints+addTopLevelInstalledConstraint,+ addTopLevelSourceConstraint :: PackageName+ -> Constraints+ -> Satisfiable Constraints+ [PackageId] ExclusionReason+addTopLevelInstalledConstraint pkgname =+ Constraints.constrain pkgname constraint reason where- dep = Dependency pkg anyVersion- taggedDep = TaggedDependency InstalledConstraint dep- reason = ExcludedByTopLevelDependency dep+ constraint _ver installed = installed+ reason = ExcludedByTopLevelConstraintInstalled pkgname +addTopLevelSourceConstraint pkgname =+ Constraints.constrain pkgname constraint reason+ where+ constraint _ver installed = not installed+ reason = ExcludedByTopLevelConstraintSource pkgname++ -- ------------------------------------------------------------ -- * Reasons for constraints -- ------------------------------------------------------------@@ -619,60 +742,80 @@ -- | We selected this other version of the package. That means we exclude -- all the other versions.- SelectedOther PackageIdentifier+ SelectedOther PackageId -- | We excluded this version of the package because it failed to -- configure probably because of unsatisfiable deps.- | ExcludedByConfigureFail+ | ExcludedByConfigureFail [Dependency] -- | We excluded this version of the package because another package that -- we selected imposed a dependency which this package did not satisfy.- | ExcludedByPackageDependency PackageIdentifier TaggedDependency+ | ExcludedByPackageDependency PackageId Dependency Bool -- | We excluded this version of the package because it did not satisfy -- a dependency given as an original top level input. --- | ExcludedByTopLevelDependency Dependency+ | ExcludedByTopLevelConstraintVersion PackageName VersionRange+ | ExcludedByTopLevelConstraintInstalled PackageName+ | ExcludedByTopLevelConstraintSource PackageName + deriving Eq+ -- | Given an excluded package and the reason it was excluded, produce a human -- readable explanation. ---showExclusionReason :: PackageIdentifier -> ExclusionReason -> String+showExclusionReason :: PackageId -> ExclusionReason -> String showExclusionReason pkgid (SelectedOther pkgid') = display pkgid ++ " was excluded because " ++ display pkgid' ++ " was selected instead"-showExclusionReason pkgid ExcludedByConfigureFail =- display pkgid ++ " was excluded because it could not be configured"-showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) =- display pkgid ++ " was excluded because " ++- display pkgid' ++ " requires " ++ displayDep (untagDependency dep)-showExclusionReason pkgid (ExcludedByTopLevelDependency dep) =- display pkgid ++ " was excluded because of the top level dependency " ++- displayDep dep+showExclusionReason pkgid (ExcludedByConfigureFail missingDeps) =+ display pkgid ++ " was excluded because it could not be configured. "+ ++ "It requires " ++ listOf displayDep missingDeps+showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep installedConstraint)+ = display pkgid ++ " was excluded because " ++ display pkgid' ++ " requires "+ ++ (if installedConstraint then "an installed instance of " else "")+ ++ displayDep dep+showExclusionReason pkgid (ExcludedByTopLevelConstraintVersion pkgname verRange) =+ display pkgid ++ " was excluded because of the top level constraint " +++ displayDep (Dependency pkgname verRange)+showExclusionReason pkgid (ExcludedByTopLevelConstraintInstalled pkgname)+ = display pkgid ++ " was excluded because of the top level constraint '"+ ++ display pkgname ++ " installed' which means that only installed instances "+ ++ "of the package may be selected."+showExclusionReason pkgid (ExcludedByTopLevelConstraintSource pkgname)+ = display pkgid ++ " was excluded because of the top level constraint '"+ ++ display pkgname ++ " source' which means that only source versions "+ ++ "of the package may be selected." -- ------------------------------------------------------------ -- * Logging progress and failures -- ------------------------------------------------------------ -data Log = Select [SelectedPackage] [PackageIdentifier]+data Log = Select [SelectedPackage] [PackageId]+ | AppliedVersionConstraint PackageName VersionRange [PackageId]+ | AppliedInstalledConstraint PackageName InstalledConstraint [PackageId]+ | ExcludeUnconfigurable PackageId+ data Failure- = ConfigureFailed+ = NoSuchPackage+ PackageName+ | ConfigureFailed SelectablePackage- [(Dependency, [(PackageIdentifier, [ExclusionReason])])]+ [(Dependency, [(PackageId, [ExclusionReason])])] | DependencyConflict- SelectedPackage TaggedDependency- [(PackageIdentifier, [ExclusionReason])]+ SelectedPackage Dependency Bool+ [(PackageId, [ExclusionReason])] | TopLevelVersionConstraintConflict PackageName VersionRange- [(PackageIdentifier, [ExclusionReason])]+ [(PackageId, [ExclusionReason])] | TopLevelVersionConstraintUnsatisfiable PackageName VersionRange | TopLevelInstallConstraintConflict- PackageName- [(PackageIdentifier, [ExclusionReason])]+ PackageName InstalledConstraint+ [(PackageId, [ExclusionReason])] | TopLevelInstallConstraintUnsatisfiable- PackageName+ PackageName InstalledConstraint showLog :: Log -> String showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of@@ -689,9 +832,9 @@ : [ display (packageVersion s') ++ " " ++ kind s' | s' <- ss ] - kind (InstalledOnly _) = "(installed)"- kind (AvailableOnly _) = "(hackage)"- kind (InstalledAndAvailable _ _) = "(installed or hackage)"+ kind (InstalledOnly _) = "(installed)"+ kind (SourceOnly _) = "(source)"+ kind (InstalledAndSource _ _) = "(installed or source)" discardedMsg = case discarded of [] -> ""@@ -699,8 +842,23 @@ [ element | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded) , element <- display pkgid : map (display . packageVersion) pkgids ]+showLog (AppliedVersionConstraint pkgname ver pkgids) =+ "applying constraint " ++ display (Dependency pkgname ver)+ ++ if null pkgids+ then ""+ else "which excludes " ++ listOf display pkgids+showLog (AppliedInstalledConstraint pkgname inst pkgids) =+ "applying constraint " ++ display pkgname ++ " '"+ ++ (case inst of InstalledConstraint -> "installed"; _ -> "source") ++ "' "+ ++ if null pkgids+ then ""+ else "which excludes " ++ listOf display pkgids+showLog (ExcludeUnconfigurable pkgid) =+ "excluding " ++ display pkgid ++ " (it cannot be configured)" showFailure :: Failure -> String+showFailure (NoSuchPackage pkgname) =+ "The package " ++ display pkgname ++ " is unknown." showFailure (ConfigureFailed pkg missingDeps) = "cannot configure " ++ displayPkg pkg ++ ". It requires " ++ listOf (displayDep . fst) missingDeps@@ -720,15 +878,17 @@ where pkgs = map fst conflicts -showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) =+showFailure (DependencyConflict pkg dep installedConstraint conflicts) = "dependencies conflict: "- ++ displayPkg pkg ++ " requires " ++ displayDep dep ++ " however\n"+ ++ displayPkg pkg ++ " requires "+ ++ (if installedConstraint then "an installed instance of " else "")+ ++ displayDep dep ++ " however:\n" ++ unlines [ showExclusionReason (packageId pkg') reason | (pkg', reasons) <- conflicts, reason <- reasons ] showFailure (TopLevelVersionConstraintConflict name ver conflicts) =- "constraints conflict: "- ++ "top level constraint " ++ displayDep (Dependency name ver) ++ " however\n"+ "constraints conflict: we have the top level constraint "+ ++ displayDep (Dependency name ver) ++ ", but\n" ++ unlines [ showExclusionReason (packageId pkg') reason | (pkg', reasons) <- conflicts, reason <- reasons ] @@ -736,31 +896,37 @@ "There is no available version of " ++ display name ++ " that satisfies " ++ displayVer ver -showFailure (TopLevelInstallConstraintConflict name conflicts) =+showFailure (TopLevelInstallConstraintConflict name InstalledConstraint conflicts) = "constraints conflict: "- ++ "top level constraint " ++ display name ++ "-installed however\n"+ ++ "top level constraint '" ++ display name ++ " installed' however\n" ++ unlines [ showExclusionReason (packageId pkg') reason | (pkg', reasons) <- conflicts, reason <- reasons ] -showFailure (TopLevelInstallConstraintUnsatisfiable name) =+showFailure (TopLevelInstallConstraintUnsatisfiable name InstalledConstraint) = "There is no installed version of " ++ display name +showFailure (TopLevelInstallConstraintConflict name SourceConstraint conflicts) =+ "constraints conflict: "+ ++ "top level constraint '" ++ display name ++ " source' however\n"+ ++ unlines [ showExclusionReason (packageId pkg') reason+ | (pkg', reasons) <- conflicts, reason <- reasons ]++showFailure (TopLevelInstallConstraintUnsatisfiable name SourceConstraint) =+ "There is no available source version of " ++ display name+ displayVer :: VersionRange -> String displayVer = display . simplifyVersionRange displayDep :: Dependency -> String displayDep = display . simplifyDependency -simplifyDependency :: Dependency -> Dependency-simplifyDependency (Dependency name range) =- Dependency name (simplifyVersionRange range) -- ------------------------------------------------------------ -- * Utils -- ------------------------------------------------------------ -impossible :: a-impossible = internalError "impossible"+impossible :: String -> a+impossible msg = internalError $ "assertion failure: " ++ msg internalError :: String -> a internalError msg = error $ "internal error: " ++ msg
Distribution/Client/Dependency/TopDown/Constraints.hs view
@@ -8,14 +8,16 @@ -- Stability : provisional -- Portability : portable ----- A set of satisfiable dependencies (package version constraints).+-- A set of satisfiable constraints on a set of packages. ----------------------------------------------------------------------------- module Distribution.Client.Dependency.TopDown.Constraints ( Constraints, empty,+ packages, choices, isPaired, + addTarget, constrain, Satisfiable(..), conflicting,@@ -25,61 +27,103 @@ import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Client.PackageIndex (PackageIndex) import Distribution.Package- ( PackageName, PackageIdentifier(..)+ ( PackageName, PackageId, PackageIdentifier(..) , Package(packageId), packageName, packageVersion- , PackageFixedDeps(depends)- , Dependency(Dependency) )+ , Dependency, PackageFixedDeps(depends) ) import Distribution.Version- ( Version, withinRange )+ ( Version ) import Distribution.Client.Utils ( mergeBy, MergeResult(..) ) -import Data.List- ( foldl' ) import Data.Monoid ( Monoid(mempty) )-import Data.Maybe- ( catMaybes )+import Data.Either+ ( partitionEithers ) import qualified Data.Map as Map import Data.Map (Map)+import qualified Data.Set as Set+import Data.Set (Set) import Control.Exception ( assert ) --- | A set of constraints on package versions. For each package name we record--- what other packages depends on it and what constraints they impose on the--- version of the package.++-- | A set of satisfiable constraints on a set of packages. ---data (Package installed, Package available)- => Constraints installed available reason+-- The 'Constraints' type keeps track of a set of targets (identified by+-- package name) that we know that we need. It also keeps track of a set of+-- constraints over all packages in the environment.+--+-- It maintains the guarantee that, for the target set, the constraints are+-- satisfiable, meaning that there is at least one instance available for each+-- package name that satisfies the constraints on that package name.+--+-- Note that it is possible to over-constrain a package in the environment that+-- is not in the target set -- the satisfiability guarantee is only maintained+-- for the target set. This is useful because it allows us to exclude packages+-- without needing to know if it would ever be needed or not (e.g. allows+-- excluding broken installed packages).+--+-- Adding a constraint for a target package can fail if it would mean that+-- there are no remaining choices.+--+-- Adding a constraint for package that is not a target never fails.+--+-- Adding a new target package can fail if that package already has conflicting+-- constraints.+--+data Constraints installed source reason = Constraints - -- Remaining available choices- (PackageIndex (InstalledOrAvailable installed available))+ -- | Targets that we know we need. This is the set for which we+ -- guarantee the constraints are satisfiable.+ !(Set PackageName) - -- Paired choices- (Map PackageName (Version, Version))+ -- | The available/remaining set. These are packages that have available+ -- choices remaining. This is guaranteed to cover the target packages,+ -- but can also cover other packages in the environment. New targets can+ -- only be added if there are available choices remaining for them.+ !(PackageIndex (InstalledOrSource installed source)) - -- Choices that we have excluded for some reason- -- usually by applying constraints- (PackageIndex (ExcludedPackage PackageIdentifier reason))+ -- | The excluded set. Choices that we have excluded by applying+ -- constraints. Excluded choices are tagged with the reason.+ !(PackageIndex (ExcludedPkg (InstalledOrSource installed source) reason)) - -- Purely for the invariant, we keep a copy of the original index- (PackageIndex (InstalledOrAvailable installed available))+ -- | Paired choices, this is an ugly hack.+ !(Map PackageName (Version, Version)) + -- | Purely for the invariant, we keep a copy of the original index+ !(PackageIndex (InstalledOrSource installed source)) -data ExcludedPackage pkg reason- = ExcludedPackage pkg [reason] -- reasons for excluding just the available- [reason] -- reasons for excluding installed and avail -instance Package pkg => Package (ExcludedPackage pkg reason) where- packageId (ExcludedPackage p _ _) = packageId p+-- | Reasons for excluding all, or some choices for a package version.+--+-- Each package version can have a source instance, an installed instance or+-- both. We distinguish reasons for constraints that excluded both instances,+-- from reasons for constraints that excluded just one instance.+--+data ExcludedPkg pkg reason+ = ExcludedPkg pkg+ [reason] -- ^ reasons for excluding both source and installed instances+ [reason] -- ^ reasons for excluding the installed instance+ [reason] -- ^ reasons for excluding the source instance +instance Package pkg => Package (ExcludedPkg pkg reason) where+ packageId (ExcludedPkg p _ _ _) = packageId p++ -- | There is a conservation of packages property. Packages are never gained or--- lost, they just transfer from the remaining pot to the excluded pot.+-- lost, they just transfer from the remaining set to the excluded set. ---invariant :: (Package installed, Package available)- => Constraints installed available a -> Bool-invariant (Constraints available _ excluded original) = all check merged+invariant :: (Package installed, Package source)+ => Constraints installed source a -> Bool+invariant (Constraints targets available excluded _ original) =++ -- Relationship between available, excluded and original+ all check merged++ -- targets is a subset of available+ && all (PackageIndex.elemByPackageName available) (Set.elems targets)+ where merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b) (PackageIndex.allPackages original)@@ -91,86 +135,113 @@ mergedPackageId (OnlyInRight p) = packageId p mergedPackageId (InBoth p _) = packageId p + -- If the package was originally installed only, then check (InBoth (InstalledOnly _) cur) = case cur of- -- If the package was originally installed only then -- now it's either still remaining as installed only- -- or it has been excluded in which case we excluded both- -- installed and available since it was only installed- OnlyInLeft (InstalledOnly _) -> True- OnlyInRight (ExcludedPackage _ [] (_:_)) -> True- _ -> False+ OnlyInLeft (InstalledOnly _) -> True+ -- or it has been excluded+ OnlyInRight (ExcludedPkg (InstalledOnly _) [] (_:_) []) -> True+ _ -> False - check (InBoth (AvailableOnly _) cur) = case cur of- -- If the package was originally available only then- -- now it's either still remaining as available only- -- or it has been excluded in which case we excluded both- -- installed and available since it was only available- OnlyInLeft (AvailableOnly _) -> True- OnlyInRight (ExcludedPackage _ [] (_:_)) -> True- _ -> True+ -- If the package was originally available only, then+ check (InBoth (SourceOnly _) cur) = case cur of+ -- now it's either still remaining as source only+ OnlyInLeft (SourceOnly _) -> True+ -- or it has been excluded+ OnlyInRight (ExcludedPkg (SourceOnly _) [] [] (_:_)) -> True+ _ -> False - -- If the package was originally installed and available- -- then there are three cases.- check (InBoth (InstalledAndAvailable _ _) cur) = case cur of+ -- If the package was originally installed and source, then+ check (InBoth (InstalledAndSource _ _) cur) = case cur of -- We can have both remaining:- OnlyInLeft (InstalledAndAvailable _ _) -> True- -- both excluded, in particular it can have had the available excluded- -- and later had both excluded so we do not mind if the available excluded- -- is empty or non-empty.- OnlyInRight (ExcludedPackage _ _ (_:_)) -> True- -- the installed remaining and the available excluded:- InBoth (InstalledOnly _) (ExcludedPackage _ (_:_) []) -> True- _ -> False+ OnlyInLeft (InstalledAndSource _ _) -> True + -- both excluded, in particular it can have had the just source or+ -- installed excluded and later had both excluded so we do not mind if+ -- the source or installed excluded is empty or non-empty.+ OnlyInRight (ExcludedPkg (InstalledAndSource _ _) _ _ _) -> True++ -- the installed remaining and the source excluded:+ InBoth (InstalledOnly _)+ (ExcludedPkg (SourceOnly _) [] [] (_:_)) -> True++ -- the source remaining and the installed excluded:+ InBoth (SourceOnly _)+ (ExcludedPkg (InstalledOnly _) [] (_:_) []) -> True+ _ -> False+ check _ = False + -- | An update to the constraints can move packages between the two piles -- but not gain or loose packages.-transitionsTo :: (Package installed, Package available)- => Constraints installed available a- -> Constraints installed available a -> Bool-transitionsTo constraints @(Constraints available _ excluded _)- constraints'@(Constraints available' _ excluded' _) =+transitionsTo :: (Package installed, Package source)+ => Constraints installed source a+ -> Constraints installed source a -> Bool+transitionsTo constraints @(Constraints _ available excluded _ _)+ constraints'@(Constraints _ available' excluded' _ _) =+ invariant constraints && invariant constraints' && null availableGained && null excludedLost- && map packageId availableLost == map packageId excludedGained+ && map (mapInstalledOrSource packageId packageId) availableLost+ == map (mapInstalledOrSource packageId packageId) excludedGained where- availableLost = foldr lost [] availableChange where- lost (OnlyInLeft pkg) rest = pkg : rest- lost (InBoth (InstalledAndAvailable _ pkg)- (InstalledOnly _)) rest = AvailableOnly pkg : rest- lost _ rest = rest- availableGained = [ pkg | OnlyInRight pkg <- availableChange ]- excludedLost = [ pkg | OnlyInLeft pkg <- excludedChange ]- excludedGained = [ pkg | OnlyInRight pkg <- excludedChange ]- ++ [ pkg | InBoth (ExcludedPackage _ (_:_) [])- pkg@(ExcludedPackage _ (_:_) (_:_))- <- excludedChange ]- availableChange = mergeBy (\a b -> packageId a `compare` packageId b)- (PackageIndex.allPackages available)- (PackageIndex.allPackages available')- excludedChange = mergeBy (\a b -> packageId a `compare` packageId b)- (PackageIndex.allPackages excluded)- (PackageIndex.allPackages excluded')+ (availableLost, availableGained)+ = partitionEithers (foldr lostAndGained [] availableChange) + (excludedLost, excludedGained)+ = partitionEithers (foldr lostAndGained [] excludedChange)++ availableChange =+ mergeBy (\a b -> packageId a `compare` packageId b)+ (PackageIndex.allPackages available)+ (PackageIndex.allPackages available')++ excludedChange =+ mergeBy (\a b -> packageId a `compare` packageId b)+ [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded ]+ [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded' ]++ lostAndGained mr rest = case mr of+ OnlyInLeft pkg -> Left pkg : rest+ InBoth (InstalledAndSource pkg _)+ (SourceOnly _) -> Left (InstalledOnly pkg) : rest+ InBoth (InstalledAndSource _ pkg)+ (InstalledOnly _) -> Left (SourceOnly pkg) : rest+ InBoth (SourceOnly _)+ (InstalledAndSource pkg _) -> Right (InstalledOnly pkg) : rest+ InBoth (InstalledOnly _)+ (InstalledAndSource _ pkg) -> Right (SourceOnly pkg) : rest+ OnlyInRight pkg -> Right pkg : rest+ _ -> rest++ mapInstalledOrSource f g pkg = case pkg of+ InstalledOnly a -> InstalledOnly (f a)+ SourceOnly b -> SourceOnly (g b)+ InstalledAndSource a b -> InstalledAndSource (f a) (g b)++ -- | We construct 'Constraints' with an initial 'PackageIndex' of all the -- packages available. ---empty :: (PackageFixedDeps installed, Package available)+empty :: (PackageFixedDeps installed, Package source) => PackageIndex installed- -> PackageIndex available- -> Constraints installed available reason-empty installed available = Constraints pkgs pairs mempty pkgs+ -> PackageIndex source+ -> Constraints installed source reason+empty installed source =+ Constraints targets pkgs excluded pairs pkgs where+ targets = mempty+ excluded = mempty pkgs = PackageIndex.fromList- . map toInstalledOrAvailable+ . map toInstalledOrSource $ mergeBy (\a b -> packageId a `compare` packageId b) (PackageIndex.allPackages installed)- (PackageIndex.allPackages available)- toInstalledOrAvailable (OnlyInLeft i ) = InstalledOnly i- toInstalledOrAvailable (OnlyInRight a) = AvailableOnly a- toInstalledOrAvailable (InBoth i a) = InstalledAndAvailable i a+ (PackageIndex.allPackages source)+ toInstalledOrSource (OnlyInLeft i ) = InstalledOnly i+ toInstalledOrSource (OnlyInRight a) = SourceOnly a+ toInstalledOrSource (InBoth i a) = InstalledAndSource i a -- pick up cases like base-3 and 4 where one version depends on the other: pairs = Map.fromList@@ -182,135 +253,348 @@ , any ((pkgid1==) . packageId) (depends pkg2) || any ((pkgid2==) . packageId) (depends pkg1) ] ++-- | The package targets.+--+packages :: (Package installed, Package source)+ => Constraints installed source reason+ -> Set PackageName+packages (Constraints ts _ _ _ _) = ts++ -- | The package choices that are still available. ---choices :: (Package installed, Package available)- => Constraints installed available reason- -> PackageIndex (InstalledOrAvailable installed available)-choices (Constraints available _ _ _) = available+choices :: (Package installed, Package source)+ => Constraints installed source reason+ -> PackageIndex (InstalledOrSource installed source)+choices (Constraints _ available _ _ _) = available -isPaired :: (Package installed, Package available)- => Constraints installed available reason- -> PackageIdentifier -> Maybe PackageIdentifier-isPaired (Constraints _ pairs _ _) (PackageIdentifier name version) =+isPaired :: (Package installed, Package source)+ => Constraints installed source reason+ -> PackageId -> Maybe PackageId+isPaired (Constraints _ _ _ pairs _) (PackageIdentifier name version) = case Map.lookup name pairs of Just (v1, v2) | version == v1 -> Just (PackageIdentifier name v2) | version == v2 -> Just (PackageIdentifier name v1) _ -> Nothing + data Satisfiable constraints discarded reason = Satisfiable constraints discarded | Unsatisfiable- | ConflictsWith [(PackageIdentifier, [reason])]+ | ConflictsWith [(PackageId, [reason])] -constrain :: (Package installed, Package available)- => TaggedDependency- -> reason- -> Constraints installed available reason- -> Satisfiable (Constraints installed available reason)- [PackageIdentifier] reason-constrain (TaggedDependency installedConstraint (Dependency name versionRange))- reason constraints@(Constraints available paired excluded original) - | not anyRemaining+addTarget :: (Package installed, Package source)+ => PackageName+ -> Constraints installed source reason+ -> Satisfiable (Constraints installed source reason)+ () reason+addTarget pkgname+ constraints@(Constraints targets available excluded paired original)++ -- If it's already a target then there's no change+ | pkgname `Set.member` targets+ = Satisfiable constraints ()++ -- If there is some possible choice available for this target then we're ok+ | PackageIndex.elemByPackageName available pkgname+ = let targets' = Set.insert pkgname targets+ constraints' = Constraints targets' available excluded paired original+ in assert (constraints `transitionsTo` constraints') $+ Satisfiable constraints' ()++ -- If it's not available and it is excluded then we return the conflicts+ | PackageIndex.elemByPackageName excluded pkgname+ = ConflictsWith conflicts++ -- Otherwise, it's not available and it has not been excluded so the+ -- package is simply completely unknown.+ | otherwise+ = Unsatisfiable++ where+ conflicts =+ [ (packageId pkg, reasons)+ | let excludedChoices = PackageIndex.lookupPackageName excluded pkgname+ , ExcludedPkg pkg isReasons iReasons sReasons <- excludedChoices+ , let reasons = isReasons ++ iReasons ++ sReasons ]+++constrain :: (Package installed, Package source)+ => PackageName -- ^ which package to constrain+ -> (Version -> Bool -> Bool) -- ^ the constraint test+ -> reason -- ^ the reason for the constraint+ -> Constraints installed source reason+ -> Satisfiable (Constraints installed source reason)+ [PackageId] reason+constrain pkgname constraint reason+ constraints@(Constraints targets available excluded paired original)++ | pkgname `Set.member` targets && not anyRemaining = if null conflicts then Unsatisfiable else ConflictsWith conflicts | otherwise- = let constraints' = Constraints available' paired excluded' original+ = let constraints' = Constraints targets available' excluded' paired original in assert (constraints `transitionsTo` constraints') $ Satisfiable constraints' (map packageId newExcluded) where- -- This tells us if any packages would remain at all for this package name if- -- we applied this constraint. This amounts to checking if any package- -- satisfies the given constraint, including version range and installation- -- status.- --- anyRemaining = any satisfiesConstraint availableChoices+ -- This tells us if any packages would remain at all for this package name if+ -- we applied this constraint. This amounts to checking if any package+ -- satisfies the given constraint, including version range and installation+ -- status.+ --+ (available', excluded', newExcluded, anyRemaining, conflicts) =+ updatePkgsStatus+ available excluded+ [] False []+ (mergeBy (\pkg pkg' -> packageVersion pkg `compare` packageVersion pkg')+ (PackageIndex.lookupPackageName available pkgname)+ (PackageIndex.lookupPackageName excluded pkgname)) - conflicts = [ (packageId pkg, reasonsAvail ++ reasonsAll)- | ExcludedPackage pkg reasonsAvail reasonsAll <- excludedChoices- , satisfiesVersionConstraint pkg ]+ testConstraint pkg =+ let ver = packageVersion pkg in+ case Map.lookup (packageName pkg) paired of - -- Applying this constraint may involve deleting some choices for this- -- package name, or restricting which install states are available.- available' = updateAvailable available- updateAvailable = flip (foldl' (flip update)) availableChoices where- update pkg | not (satisfiesVersionConstraint pkg)- = PackageIndex.deletePackageId (packageId pkg)- update _ | installedConstraint == NoInstalledConstraint- = id- update pkg = case pkg of- InstalledOnly _ -> id- AvailableOnly _ -> PackageIndex.deletePackageId (packageId pkg)- InstalledAndAvailable i _ -> PackageIndex.insert (InstalledOnly i)+ Just (v1, v2)+ | ver == v1 || ver == v2+ -> case pkg of+ InstalledOnly ipkg -> InstalledOnly (ipkg, iOk)+ SourceOnly spkg -> SourceOnly (spkg, sOk)+ InstalledAndSource ipkg spkg ->+ InstalledAndSource (ipkg, iOk) (spkg, sOk)+ where+ iOk = constraint v1 True || constraint v2 True+ sOk = constraint v1 False || constraint v2 False - -- Applying the constraint means adding exclusions for the packages that- -- we're just freshly excluding, ie the ones we're removing from available.- excluded' = foldl' (flip PackageIndex.insert) excluded- (newExcluded ++ oldExcluded)+ _ -> case pkg of+ InstalledOnly ipkg -> InstalledOnly (ipkg, iOk)+ SourceOnly spkg -> SourceOnly (spkg, sOk)+ InstalledAndSource ipkg spkg ->+ InstalledAndSource (ipkg, iOk) (spkg, sOk)+ where+ iOk = constraint ver True+ sOk = constraint ver False - newExcluded = catMaybes (map exclude availableChoices) where- exclude pkg- | not (satisfiesVersionConstraint pkg)- = Just (ExcludedPackage pkgid [] [reason])- | installedConstraint == NoInstalledConstraint- = Nothing- | otherwise = case pkg of- InstalledOnly _ -> Nothing- AvailableOnly _ -> Just (ExcludedPackage pkgid [] [reason])- InstalledAndAvailable _ _ ->- case PackageIndex.lookupPackageId excluded pkgid of- Just (ExcludedPackage _ avail both)- -> Just (ExcludedPackage pkgid (reason:avail) both)- Nothing -> Just (ExcludedPackage pkgid [reason] [])- where pkgid = packageId pkg+ -- For the info about available and excluded versions of the package in+ -- question, update the info given the current constraint+ --+ -- We update the available package map and the excluded package map+ -- we also collect:+ -- * the change in available packages (for logging)+ -- * whether there are any remaining choices+ -- * any constraints that conflict with the current constraint - -- Additionally we have to add extra exclusions for any already-excluded- -- packages that happen to be covered by the (inverse of the) constraint.- oldExcluded = catMaybes (map exclude excludedChoices) where- exclude (ExcludedPackage pkgid avail both)- -- if it doesn't satisfy the version constraint then we exclude the- -- package as a whole, the available or the installed instances or both.- | not (satisfiesVersionConstraint pkgid)- = Just (ExcludedPackage pkgid avail (reason:both))- -- if on the other hand it does satisfy the constraint and we were also- -- constraining to just the installed version then we exclude just the- -- available instance.- | installedConstraint == InstalledConstraint- = Just (ExcludedPackage pkgid (reason:avail) both)- | otherwise = Nothing+ updatePkgsStatus _ _ nePkgs ok cs _+ | seq nePkgs $ seq ok $ seq cs False = undefined - -- util definitions- availableChoices = PackageIndex.lookupPackageName available name- excludedChoices = PackageIndex.lookupPackageName excluded name+ updatePkgsStatus aPkgs ePkgs nePkgs ok cs []+ = (aPkgs, ePkgs, reverse nePkgs, ok, reverse cs) - satisfiesConstraint pkg = satisfiesVersionConstraint pkg- && satisfiesInstallStateConstraint pkg+ updatePkgsStatus aPkgs ePkgs nePkgs ok cs (pkg:pkgs) =+ let (aPkgs', ePkgs', mnePkg, ok', mc) = updatePkgStatus aPkgs ePkgs pkg+ nePkgs' = maybeCons mnePkg nePkgs+ cs' = maybeCons mc cs+ in updatePkgsStatus aPkgs' ePkgs' nePkgs' (ok' || ok) cs' pkgs - satisfiesVersionConstraint :: Package pkg => pkg -> Bool- satisfiesVersionConstraint = case Map.lookup name paired of- Nothing -> \pkg ->- packageVersion pkg `withinRange` versionRange- Just (v1, v2) -> \pkg -> case packageVersion pkg of- v | v == v1- || v == v2 -> v1 `withinRange` versionRange- || v2 `withinRange` versionRange- | otherwise -> v `withinRange` versionRange+ maybeCons Nothing xs = xs+ maybeCons (Just x) xs = x:xs - satisfiesInstallStateConstraint = case installedConstraint of- NoInstalledConstraint -> \_ -> True- InstalledConstraint -> \pkg -> case pkg of- AvailableOnly _ -> False- _ -> True -conflicting :: (Package installed, Package available)- => Constraints installed available reason+ -- For the info about an available or excluded version of the package in+ -- question, update the info given the current constraint.+ --+ updatePkgStatus aPkgs ePkgs pkg =+ case viewPackageStatus pkg of+ AllAvailable (InstalledOnly (aiPkg, False)) ->+ removeAvailable False+ (InstalledOnly aiPkg)+ (PackageIndex.deletePackageId pkgid)+ (ExcludedPkg (InstalledOnly aiPkg) [] [reason] [])+ Nothing++ AllAvailable (SourceOnly (asPkg, False)) ->+ removeAvailable False+ (SourceOnly asPkg)+ (PackageIndex.deletePackageId pkgid)+ (ExcludedPkg (SourceOnly asPkg) [] [] [reason])+ Nothing++ AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, False)) ->+ removeAvailable False+ (InstalledAndSource aiPkg asPkg)+ (PackageIndex.deletePackageId pkgid)+ (ExcludedPkg (InstalledAndSource aiPkg asPkg) [reason] [] [])+ Nothing++ AllAvailable (InstalledAndSource (aiPkg, True) (asPkg, False)) ->+ removeAvailable True+ (SourceOnly asPkg)+ (PackageIndex.insert (InstalledOnly aiPkg))+ (ExcludedPkg (SourceOnly asPkg) [] [] [reason])+ Nothing++ AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, True)) ->+ removeAvailable True+ (InstalledOnly aiPkg)+ (PackageIndex.insert (SourceOnly asPkg))+ (ExcludedPkg (InstalledOnly aiPkg) [] [reason] [])+ Nothing++ AllAvailable _ -> noChange True Nothing++ AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, False) _ _ srs) ->+ removeAvailable False+ (InstalledOnly aiPkg)+ (PackageIndex.deletePackageId pkgid)+ (ExcludedPkg (InstalledAndSource aiPkg esPkg) [reason] [] srs)+ Nothing++ AvailableExcluded (_aiPkg, True) (ExcludedPkg (esPkg, False) _ _ srs) ->+ addExtraExclusion True+ (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs))+ Nothing++ AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, True) _ _ srs) ->+ removeAvailable True+ (InstalledOnly aiPkg)+ (PackageIndex.deletePackageId pkgid)+ (ExcludedPkg (InstalledAndSource aiPkg esPkg) [] [reason] srs)+ (Just (pkgid, srs))++ AvailableExcluded (_aiPkg, True) (ExcludedPkg (_esPkg, True) _ _ srs) ->+ noChange True+ (Just (pkgid, srs))++ ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (asPkg, False) ->+ removeAvailable False+ (SourceOnly asPkg)+ (PackageIndex.deletePackageId pkgid)+ (ExcludedPkg (InstalledAndSource eiPkg asPkg) [reason] irs [])+ Nothing++ ExcludedAvailable (ExcludedPkg (eiPkg, True) _ irs _) (asPkg, False) ->+ removeAvailable False+ (SourceOnly asPkg)+ (PackageIndex.deletePackageId pkgid)+ (ExcludedPkg (InstalledAndSource eiPkg asPkg) [] irs [reason])+ (Just (pkgid, irs))++ ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (_asPkg, True) ->+ addExtraExclusion True+ (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) [])+ Nothing++ ExcludedAvailable (ExcludedPkg (_eiPkg, True) _ irs _) (_asPkg, True) ->+ noChange True+ (Just (pkgid, irs))++ AllExcluded (ExcludedPkg (InstalledOnly (eiPkg, False)) _ irs _) ->+ addExtraExclusion False+ (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) [])+ Nothing++ AllExcluded (ExcludedPkg (InstalledOnly (_eiPkg, True)) _ irs _) ->+ noChange False+ (Just (pkgid, irs))++ AllExcluded (ExcludedPkg (SourceOnly (esPkg, False)) _ _ srs) ->+ addExtraExclusion False+ (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs))+ Nothing++ AllExcluded (ExcludedPkg (SourceOnly (_esPkg, True)) _ _ srs) ->+ noChange False+ (Just (pkgid, srs))++ AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, False)) isrs irs srs) ->+ addExtraExclusion False+ (ExcludedPkg (InstalledAndSource eiPkg esPkg) (reason:isrs) irs srs)+ Nothing++ AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, True) (esPkg, False)) isrs irs srs) ->+ addExtraExclusion False+ (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs irs (reason:srs))+ (Just (pkgid, irs))++ AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, True)) isrs irs srs) ->+ addExtraExclusion False+ (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs (reason:irs) srs)+ (Just (pkgid, srs))++ AllExcluded (ExcludedPkg (InstalledAndSource (_eiPkg, True) (_esPkg, True)) isrs irs srs) ->+ noChange False+ (Just (pkgid, isrs ++ irs ++ srs))++ where+ removeAvailable ok nePkg adjustAvailable ePkg c =+ let aPkgs' = adjustAvailable aPkgs+ ePkgs' = PackageIndex.insert ePkg ePkgs+ in aPkgs' `seq` ePkgs' `seq`+ (aPkgs', ePkgs', Just nePkg, ok, c)++ addExtraExclusion ok ePkg c =+ let ePkgs' = PackageIndex.insert ePkg ePkgs+ in ePkgs' `seq`+ (aPkgs, ePkgs', Nothing, ok, c)++ noChange ok c =+ (aPkgs, ePkgs, Nothing, ok, c)++ pkgid = case pkg of OnlyInLeft p -> packageId p+ OnlyInRight p -> packageId p+ InBoth p _ -> packageId p+++ viewPackageStatus+ :: (Package installed, Package source)+ => MergeResult (InstalledOrSource installed source)+ (ExcludedPkg (InstalledOrSource installed source) reason)+ -> PackageStatus (installed, Bool) (source, Bool) reason+ viewPackageStatus merged =+ case merged of+ OnlyInLeft aPkg ->+ AllAvailable (testConstraint aPkg)++ OnlyInRight (ExcludedPkg ePkg isrs irs srs) ->+ AllExcluded (ExcludedPkg (testConstraint ePkg) isrs irs srs)++ InBoth (InstalledOnly aiPkg)+ (ExcludedPkg (SourceOnly esPkg) [] [] srs) ->+ case testConstraint (InstalledAndSource aiPkg esPkg) of+ InstalledAndSource (aiPkg', iOk) (esPkg', sOk) ->+ AvailableExcluded (aiPkg', iOk) (ExcludedPkg (esPkg', sOk) [] [] srs)+ _ -> impossible++ InBoth (SourceOnly asPkg)+ (ExcludedPkg (InstalledOnly eiPkg) [] irs []) ->+ case testConstraint (InstalledAndSource eiPkg asPkg) of+ InstalledAndSource (eiPkg', iOk) (asPkg', sOk) ->+ ExcludedAvailable (ExcludedPkg (eiPkg', iOk) [] irs []) (asPkg', sOk)+ _ -> impossible+ _ -> impossible+ where+ impossible = error "impossible: viewPackageStatus invariant violation"++-- A intermediate structure that enumerates all the possible cases given the+-- invariant. This helps us to get simpler and complete pattern matching in+-- updatePkg above+--+data PackageStatus installed source reason+ = AllAvailable (InstalledOrSource installed source)+ | AllExcluded (ExcludedPkg (InstalledOrSource installed source) reason)+ | AvailableExcluded installed (ExcludedPkg source reason)+ | ExcludedAvailable (ExcludedPkg installed reason) source+++conflicting :: (Package installed, Package source)+ => Constraints installed source reason -> Dependency- -> [(PackageIdentifier, [reason])]-conflicting (Constraints _ _ excluded _) dep =- [ (pkgid, reasonsAvail ++ reasonsAll) --TODO- | ExcludedPackage pkgid reasonsAvail reasonsAll <-+ -> [(PackageId, [reason])]+conflicting (Constraints _ _ excluded _ _) dep =+ [ (packageId pkg, reasonsAll ++ reasonsAvail ++ reasonsInstalled) --TODO+ | ExcludedPkg pkg reasonsAll reasonsAvail reasonsInstalled <- PackageIndex.lookupDependency excluded dep ]
Distribution/Client/Dependency/TopDown/Types.hs view
@@ -13,7 +13,7 @@ module Distribution.Client.Dependency.TopDown.Types where import Distribution.Client.Types- ( AvailablePackage(..), InstalledPackage )+ ( SourcePackage(..), InstalledPackage, OptionalStanza ) import Distribution.Package ( PackageIdentifier, Dependency@@ -26,15 +26,16 @@ -- ------------------------------------------------------------ type SelectablePackage- = InstalledOrAvailable InstalledPackageEx UnconfiguredPackage+ = InstalledOrSource InstalledPackageEx UnconfiguredPackage type SelectedPackage- = InstalledOrAvailable InstalledPackageEx SemiConfiguredPackage+ = InstalledOrSource InstalledPackageEx SemiConfiguredPackage -data InstalledOrAvailable installed available- = InstalledOnly installed- | AvailableOnly available- | InstalledAndAvailable installed available+data InstalledOrSource installed source+ = InstalledOnly installed+ | SourceOnly source+ | InstalledAndSource installed source+ deriving Eq type TopologicalSortNumber = Int @@ -46,14 +47,16 @@ data UnconfiguredPackage = UnconfiguredPackage- AvailablePackage+ SourcePackage !TopologicalSortNumber FlagAssignment+ [OptionalStanza] data SemiConfiguredPackage = SemiConfiguredPackage- AvailablePackage -- package info+ SourcePackage -- package info FlagAssignment -- total flag assignment for the package+ [OptionalStanza] -- enabled optional stanzas [Dependency] -- dependencies we end up with when we apply -- the flag assignment @@ -64,30 +67,25 @@ depends (InstalledPackageEx _ _ deps) = deps instance Package UnconfiguredPackage where- packageId (UnconfiguredPackage p _ _) = packageId p+ packageId (UnconfiguredPackage p _ _ _) = packageId p instance Package SemiConfiguredPackage where- packageId (SemiConfiguredPackage p _ _) = packageId p+ packageId (SemiConfiguredPackage p _ _ _) = packageId p -instance (Package installed, Package available)- => Package (InstalledOrAvailable installed available) where- packageId (InstalledOnly p ) = packageId p- packageId (AvailableOnly p ) = packageId p- packageId (InstalledAndAvailable p _) = packageId p+instance (Package installed, Package source)+ => Package (InstalledOrSource installed source) where+ packageId (InstalledOnly p ) = packageId p+ packageId (SourceOnly p ) = packageId p+ packageId (InstalledAndSource p _) = packageId p --- --------------------------------------------------------------- * Tagged Dependency type--- ------------------------------------------------------------ --- | Installed packages can only depend on other installed packages while--- packages that are not yet installed but which we plan to install can depend--- on installed or other not-yet-installed packages.+-- | We can have constraints on selecting just installed or just source+-- packages. ----- This makes life more complex as we have to remember these constraints.+-- In particular, installed packages can only depend on other installed+-- packages while packages that are not yet installed but which we plan to+-- install can depend on installed or other not-yet-installed packages. ---data TaggedDependency = TaggedDependency InstalledConstraint Dependency-data InstalledConstraint = InstalledConstraint | NoInstalledConstraint- deriving Eq--untagDependency :: TaggedDependency -> Dependency-untagDependency (TaggedDependency _ dep) = dep+data InstalledConstraint = InstalledConstraint+ | SourceConstraint+ deriving (Eq, Show)
Distribution/Client/Dependency/Types.hs view
@@ -11,35 +11,91 @@ -- Common types for dependency resolution. ----------------------------------------------------------------------------- module Distribution.Client.Dependency.Types (+ ExtDependency(..),++ PreSolver(..),+ Solver(..), DependencyResolver, PackageConstraint(..), PackagePreferences(..), InstalledPreference(..),+ PackagesPreferenceDefault(..), Progress(..), foldProgress, ) where +import Control.Applicative+ ( Applicative(..), Alternative(..) )++import Data.Char+ ( isAlpha, toLower )+import Data.Monoid+ ( Monoid(..) )+ import Distribution.Client.Types- ( AvailablePackage(..), InstalledPackage )+ ( OptionalStanza, SourcePackage(..) ) import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Compat.ReadP+ ( (<++) )++import qualified Distribution.Compat.ReadP as Parse+ ( pfail, munch1 ) import Distribution.PackageDescription ( FlagAssignment )-import Distribution.Client.PackageIndex+import qualified Distribution.Client.PackageIndex as PackageIndex ( PackageIndex )+import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex+ ( PackageIndex ) import Distribution.Package- ( PackageName )+ ( Dependency, PackageName, InstalledPackageId ) import Distribution.Version ( VersionRange ) import Distribution.Compiler ( CompilerId ) import Distribution.System ( Platform )+import Distribution.Text+ ( Text(..) ) +import Text.PrettyPrint+ ( text )+ import Prelude hiding (fail) +-- | Covers source dependencies and installed dependencies in+-- one type.+data ExtDependency = SourceDependency Dependency+ | InstalledDependency InstalledPackageId++instance Text ExtDependency where+ disp (SourceDependency dep) = disp dep+ disp (InstalledDependency dep) = disp dep++ parse = (SourceDependency `fmap` parse) <++ (InstalledDependency `fmap` parse)++-- | All the solvers that can be selected.+data PreSolver = AlwaysTopDown | AlwaysModular | Choose+ deriving (Eq, Ord, Show, Bounded, Enum)++-- | All the solvers that can be used.+data Solver = TopDown | Modular+ deriving (Eq, Ord, Show, Bounded, Enum)++instance Text PreSolver where+ disp AlwaysTopDown = text "topdown"+ disp AlwaysModular = text "modular"+ disp Choose = text "choose"+ parse = do+ name <- Parse.munch1 isAlpha+ case map toLower name of+ "topdown" -> return AlwaysTopDown+ "modular" -> return AlwaysModular+ "choose" -> return Choose+ _ -> Parse.pfail+ -- | A dependency resolver is a function that works out an installation plan -- given the set of installed and available packages and a set of deps to -- solve for.@@ -50,8 +106,8 @@ -- type DependencyResolver = Platform -> CompilerId- -> PackageIndex InstalledPackage- -> PackageIndex AvailablePackage+ -> InstalledPackageIndex.PackageIndex+ -> PackageIndex.PackageIndex SourcePackage -> (PackageName -> PackagePreferences) -> [PackageConstraint] -> [PackageName]@@ -63,9 +119,11 @@ -- range or inconsistent flag assignment). -- data PackageConstraint- = PackageVersionConstraint PackageName VersionRange- | PackageInstalledConstraint PackageName- | PackageFlagsConstraint PackageName FlagAssignment+ = PackageConstraintVersion PackageName VersionRange+ | PackageConstraintInstalled PackageName+ | PackageConstraintSource PackageName+ | PackageConstraintFlags PackageName FlagAssignment+ | PackageConstraintStanzas PackageName [OptionalStanza] deriving (Show,Eq) -- | A per-package preference on the version. It is a soft constraint that the@@ -85,6 +143,30 @@ -- data InstalledPreference = PreferInstalled | PreferLatest +-- | Global policy for all packages to say if we prefer package versions that+-- are already installed locally or if we just prefer the latest available.+--+data PackagesPreferenceDefault =++ -- | Always prefer the latest version irrespective of any existing+ -- installed version.+ --+ -- * This is the standard policy for upgrade.+ --+ PreferAllLatest++ -- | Always prefer the installed versions over ones that would need to be+ -- installed. Secondarily, prefer latest versions (eg the latest installed+ -- version or if there are none then the latest source version).+ | PreferAllInstalled++ -- | Prefer the latest version for packages that are explicitly requested+ -- but prefers the installed version for any other packages.+ --+ -- * This is the standard policy for install.+ --+ | PreferLatestForSelected+ -- | A type to represent the unfolding of an expensive long running -- calculation that may fail. We may get intermediate steps before the final -- retult which may be used to indicate progress and\/or logging messages.@@ -113,3 +195,11 @@ instance Monad (Progress step fail) where return a = Done a p >>= f = foldProgress Step Fail f p++instance Applicative (Progress step fail) where+ pure a = Done a+ p <*> x = foldProgress Step Fail (flip fmap x) p++instance Monoid fail => Alternative (Progress step fail) where+ empty = Fail mempty+ p <|> q = foldProgress Step (const q) Done p
Distribution/Client/Fetch.hs view
@@ -19,9 +19,8 @@ import Distribution.Client.Targets import Distribution.Client.FetchUtils hiding (fetchPackage) import Distribution.Client.Dependency-import Distribution.Client.PackageIndex (PackageIndex) import Distribution.Client.IndexUtils as IndexUtils- ( getAvailablePackages, getInstalledPackages )+ ( getSourcePackages, getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.Setup ( GlobalFlags(..), FetchFlags(..) )@@ -30,6 +29,7 @@ ( packageId ) import Distribution.Simple.Compiler ( Compiler(compilerId), PackageDBStack )+import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Simple.Program ( ProgramConfiguration ) import Distribution.Simple.Setup@@ -79,15 +79,17 @@ mapM_ checkTarget userTargets - installed <- getInstalledPackages verbosity comp packageDBs conf- availableDb <- getAvailablePackages verbosity repos+ installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+ sourcePkgDb <- getSourcePackages verbosity repos pkgSpecifiers <- resolveUserTargets verbosity- globalFlags (packageIndex availableDb) userTargets+ (fromFlag $ globalWorldFile globalFlags)+ (packageIndex sourcePkgDb)+ userTargets pkgs <- planPackages verbosity comp fetchFlags- installed availableDb pkgSpecifiers+ installedPkgIndex sourcePkgDb pkgSpecifiers pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs if null pkgs'@@ -110,25 +112,27 @@ planPackages :: Verbosity -> Compiler -> FetchFlags- -> PackageIndex InstalledPackage- -> AvailablePackageDb- -> [PackageSpecifier AvailablePackage]- -> IO [AvailablePackage]+ -> PackageIndex+ -> SourcePackageDb+ -> [PackageSpecifier SourcePackage]+ -> IO [SourcePackage] planPackages verbosity comp fetchFlags- installed availableDb pkgSpecifiers+ installedPkgIndex sourcePkgDb pkgSpecifiers | includeDependencies = do+ solver <- chooseSolver verbosity (fromFlag (fetchSolver fetchFlags)) (compilerId comp) notice verbosity "Resolving dependencies..." installPlan <- foldProgress logMsg die return $ resolveDependencies buildPlatform (compilerId comp)+ solver resolverParams -- The packages we want to fetch are those packages the 'InstallPlan' -- that are in the 'InstallPlan.Configured' state. return [ pkg- | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _))+ | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _ _)) <- InstallPlan.toList installPlan ] | otherwise =@@ -138,16 +142,30 @@ where resolverParams = + setMaxBackjumps (if maxBackjumps < 0 then Nothing+ else Just maxBackjumps)++ . setIndependentGoals independentGoals++ . setReorderGoals reorderGoals++ . setShadowPkgs shadowPkgs+ -- Reinstall the targets given on the command line so that the dep -- resolver will decide that they need fetching, even if they're- -- already installed. Sicne we want to get the source packages of+ -- already installed. Since we want to get the source packages of -- things we might have installed (but not have the sources for).- reinstallTargets+ . reinstallTargets - $ standardInstallPolicy installed availableDb pkgSpecifiers+ $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers includeDependencies = fromFlag (fetchDeps fetchFlags) logMsg message rest = debug verbosity message >> rest++ reorderGoals = fromFlag (fetchReorderGoals fetchFlags)+ independentGoals = fromFlag (fetchIndependentGoals fetchFlags)+ shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags)+ maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags) checkTarget :: UserTarget -> IO ()
Distribution/Client/Haddock.hs view
@@ -10,7 +10,7 @@ -- Interfacing with Haddock -- ------------------------------------------------------------------------------module Distribution.Client.Haddock +module Distribution.Client.Haddock ( regenerateHaddockIndex )@@ -28,24 +28,22 @@ import Distribution.Version (Version(Version), orLaterVersion) import Distribution.Verbosity (Verbosity) import Distribution.Text (display)-import Distribution.Client.PackageIndex(PackageIndex, allPackages,- allPackagesByName, fromList)+import Distribution.Simple.PackageIndex (PackageIndex, allPackages,+ allPackagesByName, fromList) import Distribution.Simple.Utils ( comparing, intercalate, debug , installDirectoryContents, withTempDirectory )-import Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.InstalledPackageInfo as InstalledPackageInfo ( InstalledPackageInfo , InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed) )-import Distribution.Client.Types- ( InstalledPackage(..) ) -regenerateHaddockIndex :: Verbosity -> PackageIndex InstalledPackage -> ProgramConfiguration -> FilePath -> IO ()+regenerateHaddockIndex :: Verbosity -> PackageIndex -> ProgramConfiguration -> FilePath -> IO () regenerateHaddockIndex verbosity pkgs conf index = do (paths,warns) <- haddockPackagePaths pkgs' case warns of Nothing -> return () Just m -> debug verbosity m- + (confHaddock, _, _) <- requireProgramVersion verbosity haddockProgram (orLaterVersion (Version [0,6] [])) conf@@ -63,14 +61,13 @@ rawSystemProgram verbosity confHaddock flags renameFile (tempDir </> "index.html") (tempDir </> destFile) installDirectoryContents verbosity tempDir destDir- - where ++ where (destDir,destFile) = splitFileName index- pkgs' = map (maximumBy $ comparing packageId) - . allPackagesByName + pkgs' = map (maximumBy $ comparing packageId)+ . allPackagesByName . fromList . filter exposed- . map (\(InstalledPackage pkg _) -> pkg) . allPackages $ pkgs
Distribution/Client/HttpUtils.hs view
@@ -1,10 +1,11 @@ {-# OPTIONS -cpp #-} -------------------------------------------------------------------------------- | Separate module for HTTP actions, using a proxy server if one exists+-- | Separate module for HTTP actions, using a proxy server if one exists ----------------------------------------------------------------------------- module Distribution.Client.HttpUtils ( downloadURI, getHTTP,+ cabalBrowse, proxy, isOldHackageURI ) where@@ -17,10 +18,10 @@ import Network.Stream ( Result, ConnError(..) ) import Network.Browser- ( Proxy (..), Authority (..), browse- , setOutHandler, setErrHandler, setProxy, request)+ ( Proxy (..), Authority (..), BrowserAction, browse+ , setOutHandler, setErrHandler, setProxy, setAuthorityGen, request) import Control.Monad- ( mplus, join, liftM2 )+ ( mplus, join, liftM, liftM2 ) import qualified Data.ByteString.Lazy.Char8 as ByteString import Data.ByteString.Lazy (ByteString) #ifdef WIN32@@ -63,7 +64,7 @@ then fmap Just $ regQueryValue hkey (Just "ProxyServer") else return Nothing where- -- some sources say proxy settings should be at+ -- some sources say proxy settings should be at -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows -- \CurrentVersion\Internet Settings\ProxyServer -- but if the user sets them with IE connection panel they seem to@@ -87,7 +88,7 @@ proxyString = liftM2 mplus envProxyString registryProxyString --- |Get the local proxy settings+-- |Get the local proxy settings proxy :: Verbosity -> IO Proxy proxy verbosity = do mstr <- proxyString@@ -151,15 +152,22 @@ -- |Carry out a GET request, using the local proxy settings getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString))-getHTTP verbosity uri = do- p <- proxy verbosity- let req = mkRequest uri- (_, resp) <- browse $ do- setErrHandler (warn verbosity . ("http error: "++))- setOutHandler (debug verbosity)- setProxy p- request req- return (Right resp)+getHTTP verbosity uri = liftM (\(_, resp) -> Right resp) $+ cabalBrowse verbosity (return ()) (request (mkRequest uri))++cabalBrowse :: Verbosity+ -> BrowserAction s ()+ -> BrowserAction s a+ -> IO a+cabalBrowse verbosity auth act = do+ p <- proxy verbosity+ browse $ do+ setProxy p+ setErrHandler (warn verbosity . ("http error: "++))+ setOutHandler (debug verbosity)+ auth+ setAuthorityGen (\_ _ -> return Nothing)+ act downloadURI :: Verbosity -> URI -- ^ What to download
Distribution/Client/IndexUtils.hs view
@@ -12,10 +12,13 @@ ----------------------------------------------------------------------------- module Distribution.Client.IndexUtils ( getInstalledPackages,- getAvailablePackages,+ getSourcePackages,+ convert, readPackageIndexFile,- parseRepoIndex,+ parsePackageIndex,+ readRepoIndex,+ updateRepoIndexCache, ) where import qualified Distribution.Client.Tar as Tar@@ -23,7 +26,7 @@ import Distribution.Package ( PackageId, PackageIdentifier(..), PackageName(..)- , Package(..), packageVersion+ , Package(..), packageVersion, packageName , Dependency(Dependency), InstalledPackageId(..) ) import Distribution.Client.PackageIndex (PackageIndex) import qualified Distribution.Client.PackageIndex as PackageIndex@@ -44,53 +47,57 @@ import Distribution.Version ( Version(Version), intersectVersionRanges ) import Distribution.Text- ( simpleParse )+ ( display, simpleParse ) import Distribution.Verbosity ( Verbosity, lessVerbose ) import Distribution.Simple.Utils- ( warn, info, fromUTF8, equating )+ ( die, warn, info, fromUTF8, equating ) +import Data.Char (isAlphaNum) import Data.Maybe (catMaybes, fromMaybe) import Data.List (isPrefixOf, groupBy) import Data.Monoid (Monoid(..)) import qualified Data.Map as Map-import Control.Monad (MonadPlus(mplus), when)+import Control.Monad (MonadPlus(mplus), when, unless, liftM) import Control.Exception (evaluate) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import qualified Data.ByteString.Char8 as BSS import Data.ByteString.Lazy (ByteString) import Distribution.Client.GZipUtils (maybeDecompress) import System.FilePath ((</>), takeExtension, splitDirectories, normalise) import System.FilePath.Posix as FilePath.Posix ( takeFileName )+import System.IO+import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error (isDoesNotExistError) import System.Directory- ( getModificationTime )+ ( getModificationTime, doesFileExist ) import System.Time ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) ) + getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration- -> IO (PackageIndex InstalledPackage)+ -> IO InstalledPackageIndex.PackageIndex getInstalledPackages verbosity comp packageDbs conf =- fmap convert (Configure.getInstalledPackages verbosity'- comp packageDbs conf)+ Configure.getInstalledPackages verbosity' comp packageDbs conf where --FIXME: make getInstalledPackages use sensible verbosity in the first place verbosity' = lessVerbose verbosity - convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage- convert index = PackageIndex.fromList- -- There can be multiple installed instances of each package version,- -- like when the same package is installed in the global & user dbs.- -- InstalledPackageIndex.allPackagesByName gives us the installed- -- packages with the most preferred instances first, so by picking the- -- first we should get the user one. This is almost but not quite the- -- same as what ghc does.- [ InstalledPackage ipkg (sourceDeps index ipkg)- | ipkgs <- InstalledPackageIndex.allPackagesByName index- , (ipkg:_) <- groupBy (equating packageVersion) ipkgs ]-+convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage+convert index' = PackageIndex.fromList+ -- There can be multiple installed instances of each package version,+ -- like when the same package is installed in the global & user dbs.+ -- InstalledPackageIndex.allPackagesByName gives us the installed+ -- packages with the most preferred instances first, so by picking the+ -- first we should get the user one. This is almost but not quite the+ -- same as what ghc does.+ [ InstalledPackage ipkg (sourceDeps index' ipkg)+ | ipkgs <- InstalledPackageIndex.allPackagesByName index'+ , (ipkg:_) <- groupBy (equating packageVersion) ipkgs ]+ where -- The InstalledPackageInfo only lists dependencies by the -- InstalledPackageId, which means we do not directly know the corresponding -- source dependency. The only way to find out is to lookup the@@ -109,23 +116,27 @@ brokenPackageId (InstalledPackageId str) = PackageIdentifier (PackageName (str ++ "-broken")) (Version [] []) +------------------------------------------------------------------------+-- Reading the source package index+--+ -- | Read a repository index from disk, from the local files specified by -- a list of 'Repo's. ----- All the 'AvailablePackage's are marked as having come from the appropriate+-- All the 'SourcePackage's are marked as having come from the appropriate -- 'Repo'. -- -- This is a higher level wrapper used internally in cabal-install. ---getAvailablePackages :: Verbosity -> [Repo] -> IO AvailablePackageDb-getAvailablePackages verbosity [] = do+getSourcePackages :: Verbosity -> [Repo] -> IO SourcePackageDb+getSourcePackages verbosity [] = do warn verbosity $ "No remote package servers have been specified. Usually " ++ "you would have one specified in the config file."- return AvailablePackageDb {+ return SourcePackageDb { packageIndex = mempty, packagePreferences = mempty }-getAvailablePackages verbosity repos = do+getSourcePackages verbosity repos = do info verbosity "Reading available packages..." pkgss <- mapM (readRepoIndex verbosity) repos let (pkgs, prefs) = mconcat pkgss@@ -133,50 +144,39 @@ [ (name, range) | Dependency name range <- prefs ] _ <- evaluate pkgs _ <- evaluate prefs'- return AvailablePackageDb {+ return SourcePackageDb { packageIndex = pkgs, packagePreferences = prefs' } + -- | Read a repository index from disk, from the local file specified by -- the 'Repo'. ----- All the 'AvailablePackage's are marked as having come from the given 'Repo'.+-- All the 'SourcePackage's are marked as having come from the given 'Repo'. -- -- This is a higher level wrapper used internally in cabal-install. -- readRepoIndex :: Verbosity -> Repo- -> IO (PackageIndex AvailablePackage, [Dependency])-readRepoIndex verbosity repo = handleNotFound $ do+ -> IO (PackageIndex SourcePackage, [Dependency])+readRepoIndex verbosity repo = let indexFile = repoLocalDir repo </> "00-index.tar"- (pkgs, prefs) <- either fail return- . foldlTarball extract ([], [])- =<< BS.readFile indexFile+ cacheFile = repoLocalDir repo </> "00-index.cache"+ in handleNotFound $ do+ warnIfIndexIsOld indexFile+ whenCacheOutOfDate indexFile cacheFile $ do+ info verbosity $ "Updating the index cache file..."+ updatePackageIndexCacheFile indexFile cacheFile+ readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile - pkgIndex <- evaluate $ PackageIndex.fromList- [ AvailablePackage {+ where+ mkAvailablePackage pkgid pkg =+ SourcePackage { packageInfoId = pkgid, packageDescription = pkg, packageSource = RepoTarballPackage repo pkgid Nothing }- | (pkgid, pkg) <- pkgs] - warnIfIndexIsOld indexFile- return (pkgIndex, prefs)-- where- extract (pkgs, prefs) entry = fromMaybe (pkgs, prefs) $- (do pkg <- extractPkg entry; return (pkg:pkgs, prefs))- `mplus` (do prefs' <- extractPrefs entry; return (pkgs, prefs'++prefs))-- extractPrefs :: Tar.Entry -> Maybe [Dependency]- extractPrefs entry = case Tar.entryContent entry of- Tar.NormalFile content _- | takeFileName (Tar.entryPath entry) == "preferred-versions"- -> Just . parsePreferredVersions- . BS.Char8.unpack $ content- _ -> Nothing- handleNotFound action = catch action $ \e -> if isDoesNotExistError e then do case repoKind repo of@@ -201,12 +201,33 @@ ++ "'cabal update' to get the latest list of available packages." Right _localRepo -> return () -parsePreferredVersions :: String -> [Dependency]-parsePreferredVersions = catMaybes- . map simpleParse- . filter (not . isPrefixOf "--")- . lines+-- | It is not necessary to call this, as the cache will be updated when the+-- index is read normally. However you can do the work earlier if you like.+--+updateRepoIndexCache :: Verbosity -> Repo -> IO ()+updateRepoIndexCache verbosity repo =+ whenCacheOutOfDate indexFile cacheFile $ do+ info verbosity $ "Updating the index cache file..."+ updatePackageIndexCacheFile indexFile cacheFile+ where+ indexFile = repoLocalDir repo </> "00-index.tar"+ cacheFile = repoLocalDir repo </> "00-index.cache" +whenCacheOutOfDate :: FilePath-> FilePath -> IO () -> IO ()+whenCacheOutOfDate origFile cacheFile action = do+ exists <- doesFileExist cacheFile+ if not exists+ then action+ else do+ origTime <- getModificationTime origFile+ cacheTime <- getModificationTime cacheFile+ unless (cacheTime >= origTime) action+++------------------------------------------------------------------------+-- Reading the index file+--+ -- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'. -- -- This is supposed to be an \"all in one\" way to easily get at the info in@@ -218,23 +239,56 @@ -- readPackageIndexFile :: Package pkg => (PackageId -> GenericPackageDescription -> pkg)- -> FilePath -> IO (PackageIndex pkg)+ -> FilePath+ -> IO (PackageIndex pkg, [Dependency]) readPackageIndexFile mkPkg indexFile = do- pkgs <- either fail return- . parseRepoIndex- . maybeDecompress- =<< BS.readFile indexFile- - evaluate $ PackageIndex.fromList- [ mkPkg pkgid pkg | (pkgid, pkg) <- pkgs]+ (pkgs, prefs) <- either fail return+ . parsePackageIndex+ . maybeDecompress+ =<< BS.readFile indexFile + pkgs' <- evaluate $ PackageIndex.fromList+ [ mkPkg pkgid pkg | (pkgid, pkg, _) <- pkgs]+ return (pkgs', prefs)+ -- | Parse an uncompressed \"00-index.tar\" repository index file represented -- as a 'ByteString'. ---parseRepoIndex :: ByteString- -> Either String [(PackageId, GenericPackageDescription)]-parseRepoIndex = foldlTarball (\pkgs -> maybe pkgs (:pkgs) . extractPkg) []+parsePackageIndex :: ByteString+ -> Either String+ ( [(PackageId, GenericPackageDescription, BlockNo)]+ , [Dependency] )+parsePackageIndex = accum 0 [] [] . Tar.read+ where+ accum blockNo pkgs prefs es = case es of+ Tar.Fail err -> Left err+ Tar.Done -> Right (reverse pkgs, reverse prefs)+ Tar.Next e es' -> accum blockNo' pkgs' prefs' es'+ where+ (pkgs', prefs') = extract blockNo pkgs prefs e+ blockNo' = blockNo + sizeInBlocks e + extract blockNo pkgs prefs entry =+ fromMaybe (pkgs, prefs) $+ tryExtractPkg+ `mplus` tryExtractPrefs+ where+ tryExtractPkg = do+ (pkgid, pkg) <- extractPkg entry+ return ((pkgid, pkg, blockNo):pkgs, prefs)++ tryExtractPrefs = do+ prefs' <- extractPrefs entry+ return (pkgs, prefs'++prefs)++ sizeInBlocks entry =+ 1 + case Tar.entryContent entry of+ Tar.NormalFile _ size -> bytesToBlocks size+ Tar.OtherEntryType _ _ size -> bytesToBlocks size+ _ -> 0+ where+ bytesToBlocks s = 1 + ((fromIntegral s - 1) `div` 512)+ extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription) extractPkg entry = case Tar.entryContent entry of Tar.NormalFile content _@@ -256,10 +310,156 @@ where fileName = Tar.entryPath entry -foldlTarball :: (a -> Tar.Entry -> a) -> a- -> ByteString -> Either String a-foldlTarball f z = either Left (Right . foldl f z) . check [] . Tar.read+extractPrefs :: Tar.Entry -> Maybe [Dependency]+extractPrefs entry = case Tar.entryContent entry of+ Tar.NormalFile content _+ | takeFileName (Tar.entryPath entry) == "preferred-versions"+ -> Just . parsePreferredVersions+ . BS.Char8.unpack $ content+ _ -> Nothing++parsePreferredVersions :: String -> [Dependency]+parsePreferredVersions = catMaybes+ . map simpleParse+ . filter (not . isPrefixOf "--")+ . lines++------------------------------------------------------------------------+-- Reading and updating the index cache+--++updatePackageIndexCacheFile :: FilePath -> FilePath -> IO ()+updatePackageIndexCacheFile indexFile cacheFile = do+ (pkgs, prefs) <- either fail return+ . parsePackageIndex+ . maybeDecompress+ =<< BS.readFile indexFile+ let cache = mkCache pkgs prefs+ writeFile cacheFile (showIndexCache cache) where- check _ (Tar.Fail err) = Left err- check ok Tar.Done = Right ok- check ok (Tar.Next e es) = check (e:ok) es+ mkCache pkgs prefs =+ [ CachePrefrence pref | pref <- prefs ]+ ++ [ CachePackageId pkgid blockNo | (pkgid, _, blockNo) <- pkgs ]++readPackageIndexCacheFile :: Package pkg+ => (PackageId -> GenericPackageDescription -> pkg)+ -> FilePath+ -> FilePath+ -> IO (PackageIndex pkg, [Dependency])+readPackageIndexCacheFile mkPkg indexFile cacheFile = do+ indexHnd <- openFile indexFile ReadMode+ cache <- liftM readIndexCache (BSS.readFile cacheFile)+ packageIndexFromCache mkPkg indexHnd cache+++packageIndexFromCache :: Package pkg+ => (PackageId -> GenericPackageDescription -> pkg)+ -> Handle+ -> [IndexCacheEntry]+ -> IO (PackageIndex pkg, [Dependency])+packageIndexFromCache mkPkg hnd = accum mempty []+ where+ accum srcpkgs prefs [] = do+ -- Have to reverse entries, since in a tar file, later entries mask+ -- earlier ones, and PackageIndex.fromList does the same, but we+ -- accumulate the list of entries in reverse order, so need to reverse.+ pkgIndex <- evaluate $ PackageIndex.fromList (reverse srcpkgs)+ return (pkgIndex, prefs)++ accum srcpkgs prefs (CachePackageId pkgid blockno : entries) = do+ -- Given the cache entry, make a package index entry.+ -- The magic here is that we use lazy IO to read the .cabal file+ -- from the index tarball if it turns out that we need it.+ -- Most of the time we only need the package id.+ pkg <- unsafeInterleaveIO $ do+ getPackageDescription blockno+ let srcpkg = mkPkg pkgid pkg+ accum (srcpkg:srcpkgs) prefs entries++ accum srcpkgs prefs (CachePrefrence pref : entries) =+ accum srcpkgs (pref:prefs) entries++ getPackageDescription blockno = do+ hSeek hnd AbsoluteSeek (fromIntegral (blockno * 512))+ header <- BS.hGet hnd 512+ size <- getEntrySize header+ content <- BS.hGet hnd (fromIntegral size)+ readPackageDescription content++ getEntrySize header =+ case Tar.read header of+ Tar.Next e _ ->+ case Tar.entryContent e of+ Tar.NormalFile _ size -> return size+ _ -> interror "unexpected tar entry type"+ _ -> interror "could not read tar file entry"++ readPackageDescription content =+ case parsePackageDescription . fromUTF8 . BS.Char8.unpack $ content of+ ParseOk _ d -> return d+ _ -> interror "failed to parse .cabal file"++ interror msg = die $ "internal error when reading package index: " ++ msg+ ++ "The package index or index cache is probably "+ ++ "corrupt. Running cabal update might fix it."++------------------------------------------------------------------------+-- Index cache data structure+--++-- | Tar files are block structured with 512 byte blocks. Every header and file+-- content starts on a block boundary.+--+type BlockNo = Int++data IndexCacheEntry = CachePackageId PackageId BlockNo+ | CachePrefrence Dependency+ deriving (Eq, Show)++readIndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry+readIndexCacheEntry = \line ->+ case BSS.words line of+ [key, pkgnamestr, pkgverstr, sep, blocknostr]+ | key == packageKey && sep == blocknoKey ->+ case (parseName pkgnamestr, parseVer pkgverstr [], parseBlockNo blocknostr) of+ (Just pkgname, Just pkgver, Just blockno)+ -> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno)+ _ -> Nothing+ (key: remainder) | key == preferredVersionKey ->+ fmap CachePrefrence (simpleParse (BSS.unpack (BSS.unwords remainder)))+ _ -> Nothing+ where+ packageKey = BSS.pack "pkg:"+ blocknoKey = BSS.pack "b#"+ preferredVersionKey = BSS.pack "pref-ver:"++ parseName str+ | BSS.all (\c -> isAlphaNum c || c == '-') str+ = Just (PackageName (BSS.unpack str))+ | otherwise = Nothing++ parseVer str vs =+ case BSS.readInt str of+ Nothing -> Nothing+ Just (v, str') -> case BSS.uncons str' of+ Just ('.', str'') -> parseVer str'' (v:vs)+ Just _ -> Nothing+ Nothing -> Just (Version (reverse (v:vs)) [])++ parseBlockNo str =+ case BSS.readInt str of+ Just (blockno, remainder) | BSS.null remainder -> Just blockno+ _ -> Nothing++showIndexCacheEntry :: IndexCacheEntry -> String+showIndexCacheEntry entry = case entry of+ CachePackageId pkgid b -> "pkg: " ++ display (packageName pkgid)+ ++ " " ++ display (packageVersion pkgid)+ ++ " b# " ++ show b+ CachePrefrence dep -> "pref-ver: " ++ display dep++readIndexCache :: BSS.ByteString -> [IndexCacheEntry]+readIndexCache = catMaybes . map readIndexCacheEntry . BSS.lines++showIndexCache :: [IndexCacheEntry] -> String+showIndexCache = unlines . map showIndexCacheEntry
Distribution/Client/Init.hs view
@@ -24,29 +24,45 @@ import System.IO ( hSetBuffering, stdout, BufferMode(..) ) import System.Directory- ( getCurrentDirectory )+ ( getCurrentDirectory, doesDirectoryExist )+import System.FilePath+ ( (</>) ) import Data.Time ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) import Data.List- ( intersperse )+ ( intersperse, intercalate, nub, groupBy, (\\) ) import Data.Maybe- ( fromMaybe, isJust )+ ( fromMaybe, isJust, catMaybes )+import Data.Function+ ( on )+import qualified Data.Map as M import Data.Traversable ( traverse )+import Control.Applicative+ ( (<$>) ) import Control.Monad ( when ) #if MIN_VERSION_base(3,0,0) import Control.Monad- ( (>=>) )+ ( (>=>), join ) #endif+import Control.Arrow+ ( (&&&) ) -import Text.PrettyPrint.HughesPJ hiding (mode, cat)+import Text.PrettyPrint hiding (mode, cat) import Data.Version ( Version(..) ) import Distribution.Version- ( orLaterVersion )+ ( orLaterVersion, withinVersion, VersionRange )+import Distribution.Verbosity+ ( Verbosity )+import Distribution.ModuleName+ ( ModuleName, fromString )+import Distribution.InstalledPackageInfo+ ( InstalledPackageInfo, sourcePackageId, exposed )+import qualified Distribution.Package as P import Distribution.Client.Init.Types ( InitFlags(..), PackageType(..), Category(..) )@@ -64,14 +80,30 @@ ( runReadE, readP_to_E ) import Distribution.Simple.Setup ( Flag(..), flagToMaybe )+import Distribution.Simple.Configure+ ( getInstalledPackages )+import Distribution.Simple.Compiler+ ( PackageDBStack, Compiler )+import Distribution.Simple.Program+ ( ProgramConfiguration )+import Distribution.Simple.PackageIndex+ ( PackageIndex, moduleNameIndex ) import Distribution.Text ( display, Text(..) ) -initCabal :: InitFlags -> IO ()-initCabal initFlags = do+initCabal :: Verbosity+ -> PackageDBStack+ -> Compiler+ -> ProgramConfiguration+ -> InitFlags+ -> IO ()+initCabal verbosity packageDBs comp conf initFlags = do++ installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+ hSetBuffering stdout NoBuffering - initFlags' <- extendFlags initFlags+ initFlags' <- extendFlags installedPkgIndex initFlags writeLicense initFlags' writeSetupFile initFlags'@@ -85,17 +117,19 @@ -- | Fill in more details by guessing, discovering, or prompting the -- user.-extendFlags :: InitFlags -> IO InitFlags-extendFlags = getPackageName- >=> getVersion- >=> getLicense- >=> getAuthorInfo- >=> getHomepage- >=> getSynopsis- >=> getCategory- >=> getLibOrExec- >=> getSrcDir- >=> getModulesAndBuildTools+extendFlags :: PackageIndex -> InitFlags -> IO InitFlags+extendFlags pkgIx =+ getPackageName+ >=> getVersion+ >=> getLicense+ >=> getAuthorInfo+ >=> getHomepage+ >=> getSynopsis+ >=> getCategory+ >=> getLibOrExec+ >=> getGenComments+ >=> getSrcDir+ >=> getModulesBuildToolsAndDeps pkgIx -- | Combine two actions which may return a value, preferring the first. That -- is, run the second action only if the first doesn't return a value.@@ -124,11 +158,11 @@ return $ flags { packageName = maybeToFlag pkgName' } --- | Package version: use 0.1 as a last resort, but try prompting the user if--- possible.+-- | Package version: use 0.1.0.0 as a last resort, but try prompting the user+-- if possible. getVersion :: InitFlags -> IO InitFlags getVersion flags = do- let v = Just $ Version { versionBranch = [0,1], versionTags = [] }+ let v = Just $ Version { versionBranch = [0,1,0,0], versionTags = [] } v' <- return (flagToMaybe $ version flags) ?>> maybePrompt flags (prompt "Package version" v) ?>> return v@@ -138,11 +172,13 @@ getLicense :: InitFlags -> IO InitFlags getLicense flags = do lic <- return (flagToMaybe $ license flags)- ?>> fmap (fmap (either UnknownLicense id))+ ?>> fmap (fmap (either UnknownLicense id) . join) (maybePrompt flags- (promptList "Please choose a license"- knownLicenses (Just BSD3) True))+ (promptListOptional "Please choose a license" listedLicenses)) return $ flags { license = maybeToFlag lic }+ where+ listedLicenses =+ knownLicenses \\ [GPL Nothing, LGPL Nothing, OtherLicense] -- | The author's name and email. Prompt, or try to guess from an existing -- darcs repo.@@ -166,7 +202,7 @@ getHomepage flags = do hp <- queryHomepage hp' <- return (flagToMaybe $ homepage flags)- ?>> maybePrompt flags (promptStr "Project homepage/repo URL" hp)+ ?>> maybePrompt flags (promptStr "Project homepage URL" hp) ?>> return hp return $ flags { homepage = maybeToFlag hp' }@@ -190,8 +226,8 @@ getCategory :: InitFlags -> IO InitFlags getCategory flags = do cat <- return (flagToMaybe $ category flags)- ?>> maybePrompt flags (promptList "Project category" [Codec ..]- Nothing True)+ ?>> fmap join (maybePrompt flags+ (promptListOptional "Project category" [Codec ..])) return $ flags { category = maybeToFlag cat } -- | Ask whether the project builds a library or executable.@@ -201,42 +237,122 @@ ?>> maybePrompt flags (either (const Library) id `fmap` (promptList "What does the package build" [Library, Executable]- Nothing False))+ Nothing display False)) ?>> return (Just Library) return $ flags { packageType = maybeToFlag isLib } +-- | Ask whether to generate explanitory comments.+getGenComments :: InitFlags -> IO InitFlags+getGenComments flags = do+ genComments <- return (flagToMaybe $ noComments flags)+ ?>> maybePrompt flags (promptYesNo promptMsg (Just False))+ ?>> return (Just False)+ return $ flags { noComments = maybeToFlag (fmap not genComments) }+ where+ promptMsg = "Include documentation on what each field means (y/n)"+ -- | Try to guess the source root directory (don't prompt the user). getSrcDir :: InitFlags -> IO InitFlags getSrcDir flags = do srcDirs <- return (sourceDirs flags)- ?>> guessSourceDirs+ ?>> Just `fmap` (guessSourceDirs flags) return $ flags { sourceDirs = srcDirs } --- XXX--- | Try to guess source directories.-guessSourceDirs :: IO (Maybe [String])-guessSourceDirs = return Nothing+-- | Try to guess source directories. Could try harder; for the+-- moment just looks to see whether there is a directory called 'src'.+guessSourceDirs :: InitFlags -> IO [String]+guessSourceDirs flags = do+ dir <- fromMaybe getCurrentDirectory+ (fmap return . flagToMaybe $ packageDir flags)+ srcIsDir <- doesDirectoryExist (dir </> "src")+ if srcIsDir+ then return ["src"]+ else return [] -- | Get the list of exposed modules and extra tools needed to build them.-getModulesAndBuildTools :: InitFlags -> IO InitFlags-getModulesAndBuildTools flags = do+getModulesBuildToolsAndDeps :: PackageIndex -> InitFlags -> IO InitFlags+getModulesBuildToolsAndDeps pkgIx flags = do dir <- fromMaybe getCurrentDirectory (fmap return . flagToMaybe $ packageDir flags) -- XXX really should use guessed source roots. sourceFiles <- scanForModules dir - mods <- return (exposedModules flags)+ Just mods <- return (exposedModules flags) ?>> (return . Just . map moduleName $ sourceFiles) tools <- return (buildTools flags) ?>> (return . Just . neededBuildPrograms $ sourceFiles) - return $ flags { exposedModules = mods- , buildTools = tools }+ deps <- return (dependencies flags)+ ?>> Just <$> importsToDeps flags+ (fromString "Prelude" : concatMap imports sourceFiles)+ pkgIx + return $ flags { exposedModules = Just mods+ , buildTools = tools+ , dependencies = deps+ }++importsToDeps :: InitFlags -> [ModuleName] -> PackageIndex -> IO [P.Dependency]+importsToDeps flags mods pkgIx = do++ let modMap :: M.Map ModuleName [InstalledPackageInfo]+ modMap = M.map (filter exposed) $ moduleNameIndex pkgIx++ modDeps :: [(ModuleName, Maybe [InstalledPackageInfo])]+ modDeps = map (id &&& flip M.lookup modMap) mods++ message flags "\nGuessing dependencies..."+ nub . catMaybes <$> mapM (chooseDep flags) modDeps++-- Given a module and a list of installed packages providing it,+-- choose a dependency (i.e. package + version range) to use for that+-- module.+chooseDep :: InitFlags -> (ModuleName, Maybe [InstalledPackageInfo])+ -> IO (Maybe P.Dependency)++chooseDep flags (m, Nothing)+ = message flags ("\nWarning: no package found providing " ++ display m ++ ".")+ >> return Nothing++chooseDep flags (m, Just [])+ = message flags ("\nWarning: no package found providing " ++ display m ++ ".")+ >> return Nothing++ -- We found some packages: group them by name.+chooseDep flags (m, Just ps)+ = case pkgGroups of+ -- if there's only one group, i.e. multiple versions of a single package,+ -- we make it into a dependency, choosing the latest-ish version (see toDep).+ [grp] -> Just <$> toDep grp+ -- otherwise, we refuse to choose between different packages and make the user+ -- do it.+ grps -> do message flags ("\nWarning: multiple packages found providing "+ ++ display m+ ++ ": " ++ intercalate ", " (map (display . P.pkgName . 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 sourcePackageId ps)++ -- Given a list of available versions of the same package, pick a dependency.+ toDep :: [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 . P.pkgVersion $ pid)++ -- 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 . maximum . map P.pkgVersion $ pids)++ pvpize :: Version -> VersionRange+ pvpize v = withinVersion $ v { versionBranch = take 2 (versionBranch v) }+ --------------------------------------------------------------------------- -- Prompting/user interaction ------------------------------------------- ---------------------------------------------------------------------------@@ -254,6 +370,18 @@ promptStr :: String -> Maybe String -> IO String promptStr = promptDefault' Just id +-- | Create a yes/no prompt with optional default value.+--+promptYesNo :: String -> Maybe Bool -> IO Bool+promptYesNo =+ promptDefault' recogniseYesNo showYesNo+ where+ recogniseYesNo s | s == "y" || s == "Y" = Just True+ | s == "n" || s == "N" = Just False+ | otherwise = Nothing+ showYesNo True = "y"+ showYesNo False = "n"+ -- | Create a prompt with optional default value that returns a value -- of some Text instance. prompt :: Text t => String -> Maybe t -> IO t@@ -280,34 +408,46 @@ -- | Create a prompt from a prompt string and a String representation -- of an optional default value. mkDefPrompt :: String -> Maybe String -> String-mkDefPrompt pr def = pr ++ defStr def ++ "? "- where defStr Nothing = ""- defStr (Just s) = " [default \"" ++ s ++ "\"]"+mkDefPrompt pr def = pr ++ "?" ++ defStr def+ where defStr Nothing = " "+ defStr (Just s) = " [default: " ++ s ++ "] " +promptListOptional :: (Text t, Eq t)+ => String -- ^ prompt+ -> [t] -- ^ choices+ -> IO (Maybe (Either String t))+promptListOptional pr choices =+ fmap rearrange+ $ promptList pr (Nothing : map Just choices) (Just Nothing)+ (maybe "(none)" display) True+ where+ rearrange = either (Just . Left) (maybe Nothing (Just . Right))+ -- | Create a prompt from a list of items.-promptList :: (Text t, Eq t)+promptList :: Eq t => String -- ^ prompt -> [t] -- ^ choices -> Maybe t -- ^ optional default value+ -> (t -> String) -- ^ show an item -> Bool -- ^ whether to allow an 'other' option -> IO (Either String t)-promptList pr choices def other = do+promptList pr choices def displayItem other = do putStrLn $ pr ++ ":"- let options1 = map (\c -> (Just c == def, display c)) choices+ let options1 = map (\c -> (Just c == def, displayItem c)) choices options2 = zip ([1..]::[Int]) (options1 ++ if other then [(False, "Other (specify)")] else []) mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2- promptList' (length options2) choices def other+ promptList' displayItem (length options2) choices def other where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest | otherwise = " " ++ star i ++ rest where rest = show n ++ ") " star True = "*" star False = " " -promptList' :: Text t => Int -> [t] -> Maybe t -> Bool -> IO (Either String t)-promptList' numChoices choices def other = do- putStr $ mkDefPrompt "Your choice" (display `fmap` def)+promptList' :: (t -> String) -> Int -> [t] -> Maybe t -> Bool -> IO (Either String t)+promptList' displayItem numChoices choices def other = do+ putStr $ mkDefPrompt "Your choice" (displayItem `fmap` def) inp <- getLine case (inp, def) of ("", Just d) -> return $ Right d@@ -315,7 +455,7 @@ Nothing -> invalidChoice inp Just n -> getChoice n where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice."- promptList' numChoices choices def other+ promptList' displayItem numChoices choices def other getChoice n | n < 1 || n > numChoices = invalidChoice (show n) | n < numChoices || (n == numChoices && not other)@@ -333,7 +473,7 @@ writeLicense :: InitFlags -> IO () writeLicense flags = do- message flags "Generating LICENSE..."+ message flags "\nGenerating LICENSE..." year <- getYear let licenseFile = case license flags of@@ -379,6 +519,8 @@ , "main = defaultMain" ] +-- XXX ought to do something sensible if a .cabal file already exists,+-- instead of overwriting. writeCabalFile :: InitFlags -> IO Bool writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do message flags "Error: no package name provided."@@ -398,105 +540,114 @@ -- structure onto a low-level AST structure and use the existing -- pretty-printing code to generate the file. generateCabalFile :: String -> InitFlags -> String-generateCabalFile fileName c = render $+generateCabalFile fileName c =+ renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $ (if (minimal c /= Flag True)- then showComment (Just $ fileName ++ " auto-generated by cabal init. For additional options, see http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.")+ then showComment (Just $ "Initial " ++ fileName ++ " generated by cabal "+ ++ "init. For further documentation, see "+ ++ "http://haskell.org/cabal/users-guide/")+ $$ text "" else empty) $$- vcat [ fieldS "Name" (packageName c)+ vcat [ fieldS "name" (packageName c) (Just "The name of the package.") True - , field "Version" (version c)- (Just "The package version. See the Haskell package versioning policy (http://www.haskell.org/haskellwiki/Package_versioning_policy) for standards guiding when and how versions should be incremented.")+ , field "version" (version c)+ (Just $ "The package version. See the Haskell package versioning policy (PVP) for standards guiding when and how versions should be incremented.\nhttp://www.haskell.org/haskellwiki/Package_versioning_policy\n"+ ++ "PVP summary: +-+------- breaking API changes\n"+ ++ " | | +----- non-breaking API additions\n"+ ++ " | | | +--- code changes with no API change") True - , fieldS "Synopsis" (synopsis c)+ , fieldS "synopsis" (synopsis c) (Just "A short (one-line) description of the package.") True - , fieldS "Description" NoFlag+ , fieldS "description" NoFlag (Just "A longer description of the package.") True - , fieldS "Homepage" (homepage c)+ , fieldS "homepage" (homepage c) (Just "URL for the project homepage or repository.") False - , fieldS "Bug-reports" NoFlag+ , fieldS "bug-reports" NoFlag (Just "A URL where users can report bugs.") False - , field "License" (license c)+ , field "license" (license c) (Just "The license under which the package is released.") True - , fieldS "License-file" (Flag "LICENSE")+ , fieldS "license-file" (Flag "LICENSE") (Just "The file containing the license text.") True - , fieldS "Author" (author c)+ , fieldS "author" (author c) (Just "The package author(s).") True - , fieldS "Maintainer" (email c)+ , fieldS "maintainer" (email c) (Just "An email address to which users can send suggestions, bug reports, and patches.") True - , fieldS "Copyright" NoFlag+ , fieldS "copyright" NoFlag (Just "A copyright notice.") True - , fieldS "Category" (either id display `fmap` category c)+ , fieldS "category" (either id display `fmap` category c) Nothing True - , fieldS "Build-type" (Flag "Simple")+ , fieldS "build-type" (Flag "Simple") Nothing True - , fieldS "Extra-source-files" NoFlag+ , fieldS "extra-source-files" NoFlag (Just "Extra files to be distributed with the package, such as examples or a README.")- True+ False - , field "Cabal-version" (Flag $ orLaterVersion (Version [1,2] []))+ , field "cabal-version" (Flag $ orLaterVersion (Version [1,8] [])) (Just "Constraint on the version of Cabal needed to build this package.") False , case packageType c of Flag Executable ->- text "\nExecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat- [ fieldS "Main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True+ text "\nexecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat+ [ fieldS "main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True - , generateBuildInfo c+ , generateBuildInfo Executable c ])- Flag Library -> text "\nLibrary" $$ (nest 2 $ vcat- [ fieldS "Exposed-modules" (listField (exposedModules c))+ Flag Library -> text "\nlibrary" $$ (nest 2 $ vcat+ [ fieldS "exposed-modules" (listField (exposedModules c)) (Just "Modules exported by the library.") True - , generateBuildInfo c+ , generateBuildInfo Library c ]) _ -> empty ] where- generateBuildInfo :: InitFlags -> Doc- generateBuildInfo c' = vcat- [ fieldS "Build-depends" (listField (dependencies c'))- (Just "Packages needed in order to build this package.")+ generateBuildInfo :: PackageType -> InitFlags -> Doc+ generateBuildInfo pkgtype c' = vcat+ [ fieldS "other-modules" (listField (otherModules c'))+ (Just $ case pkgtype of+ Library -> "Modules included in this library but not exported."+ Executable -> "Modules included in this executable, other than Main.") True - , fieldS "Other-modules" (listField (otherModules c'))- (Just "Modules not exported by this package.")+ , fieldS "build-depends" (listField (dependencies c'))+ (Just "Other library packages from which modules are imported.") True , fieldS "hs-source-dirs" (listFieldS (sourceDirs c'))- (Just "Directories other than the root containing source files.")+ (Just "Directories containing source files.") False - , fieldS "Build-tools" (listFieldS (buildTools c'))+ , fieldS "build-tools" (listFieldS (buildTools c')) (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.")- True+ False ] listField :: Text s => Maybe [s] -> Flag String@@ -531,8 +682,20 @@ showComment :: Maybe String -> Doc showComment (Just t) = vcat . map text . map ("-- "++) . lines- . render . fsep . map text . words $ t+ . renderStyle style {+ lineLength = 76,+ ribbonsPerLine = 1.05+ }+ . vcat+ . map (fcat . map text . breakLine)+ . lines+ $ t showComment Nothing = text ""++ breakLine [] = []+ breakLine cs = case break (==' ') cs of (w,cs') -> w : breakLine' cs'+ breakLine' [] = []+ breakLine' cs = case span (==' ') cs of (w,cs') -> w : breakLine cs' -- | Generate warnings for missing fields etc. generateWarnings :: InitFlags -> IO ()
Distribution/Client/Init/Heuristics.hs view
@@ -19,8 +19,10 @@ guessAuthorNameMail, knownCategories, ) where-import Distribution.Simple.Setup(Flag(..))-import Distribution.ModuleName ( ModuleName, fromString )+import Distribution.Text (simpleParse)+import Distribution.Simple.Setup (Flag(..))+import Distribution.ModuleName+ ( ModuleName, fromString, toFilePath ) import Distribution.Client.PackageIndex ( allPackagesByName ) import qualified Distribution.PackageDescription as PD@@ -28,12 +30,13 @@ import Distribution.Simple.Utils ( intercalate ) -import Distribution.Client.Types ( packageDescription, AvailablePackageDb(..) )+import Distribution.Client.Types ( packageDescription, SourcePackageDb(..) ) import Control.Monad (liftM ) import Data.Char ( isUpper, isLower, isSpace ) #if MIN_VERSION_base(3,0,3) import Data.Either ( partitionEithers ) #endif+import Data.List ( isPrefixOf ) import Data.Maybe ( catMaybes ) import Data.Monoid ( mempty, mappend ) import qualified Data.Set as Set ( fromList, toList )@@ -41,7 +44,7 @@ getHomeDirectory, canonicalizePath ) import System.Environment ( getEnvironment ) import System.FilePath ( takeExtension, takeBaseName, dropExtension,- (</>), splitDirectories, makeRelative )+ (</>), (<.>), splitDirectories, makeRelative ) -- |Guess the package name based on the given root directory guessPackageName :: FilePath -> IO String@@ -50,10 +53,15 @@ -- |Data type of source files found in the working directory data SourceFileEntry = SourceFileEntry { relativeSourcePath :: FilePath- , moduleName :: ModuleName- , fileExtension :: String+ , moduleName :: ModuleName+ , fileExtension :: String+ , imports :: [ModuleName] } deriving Show +sfToFileName :: FilePath -> SourceFileEntry -> FilePath+sfToFileName projectRoot (SourceFileEntry relPath m ext _)+ = projectRoot </> relPath </> toFilePath m <.> ext+ -- |Search for source files in the given directory -- and return pairs of guessed haskell source path and -- module names.@@ -69,14 +77,15 @@ let modules = catMaybes [ guessModuleName hierarchy file | file <- files , isUpper (head file) ]+ modules' <- mapM (findImports projectRoot) modules recMods <- mapM (scanRecursive dir hierarchy) dirs- return $ concat (modules : recMods)+ return $ concat (modules' : recMods) tagIsDir parent entry = do isDir <- doesDirectoryExist (parent </> entry) return $ (if isDir then Right else Left) entry guessModuleName hierarchy entry | takeBaseName entry == "Setup" = Nothing- | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext+ | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext [] | otherwise = Nothing where relRoot = makeRelative projectRoot srcRoot@@ -91,6 +100,35 @@ ignoreDir ('.':_) = True ignoreDir dir = dir `elem` ["dist", "_darcs"] +findImports :: FilePath -> SourceFileEntry -> IO SourceFileEntry+findImports projectRoot sf = do+ s <- readFile (sfToFileName projectRoot sf)++ let modules = catMaybes+ . map ( getModName+ . drop 1+ . filter (not . null)+ . dropWhile (/= "import")+ . words+ )+ . filter (not . ("--" `isPrefixOf`)) -- poor man's comment filtering+ . lines+ $ s++ -- XXX we should probably make a better attempt at parsing+ -- comments above. Unfortunately we can't use a full-fledged+ -- Haskell parser since cabal's dependencies must be kept at a+ -- minimum.++ return sf { imports = modules }++ where getModName :: [String] -> Maybe ModuleName+ getModName [] = Nothing+ getModName ("qualified":ws) = getModName ws+ getModName (ms:_) = simpleParse ms+++ -- Unfortunately we cannot use the version exported by Distribution.Simple.Program knownSuffixHandlers :: [(String,String)] knownSuffixHandlers =@@ -134,9 +172,9 @@ authorRepoFile = "_darcs" </> "prefs" </> "author" -- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached-knownCategories :: AvailablePackageDb -> [String]-knownCategories (AvailablePackageDb available _) = nubSet $- [ cat | pkg <- map head (allPackagesByName available)+knownCategories :: SourcePackageDb -> [String]+knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet $+ [ cat | pkg <- map head (allPackagesByName sourcePkgIndex) , let catList = (PD.category . PD.packageDescription . packageDescription) pkg , cat <- splitString ',' catList ]
Distribution/Client/Init/Licenses.hs view
@@ -12,7 +12,7 @@ bsd3 :: String -> String -> License bsd3 authors year = unlines- [ "Copyright (c)" ++ year ++ ", " ++ authors+ [ "Copyright (c) " ++ year ++ ", " ++ authors , "" , "All rights reserved." , ""
Distribution/Client/Init/Types.hs view
@@ -18,6 +18,7 @@ ( Flag(..) ) import Distribution.Version+import Distribution.Verbosity import qualified Distribution.Package as P import Distribution.License import Distribution.ModuleName@@ -59,6 +60,8 @@ , dependencies :: Maybe [P.Dependency] , sourceDirs :: Maybe [String] , buildTools :: Maybe [String]++ , initVerbosity :: Flag Verbosity } deriving (Show) @@ -91,6 +94,7 @@ , dependencies = mempty , sourceDirs = mempty , buildTools = mempty+ , initVerbosity = mempty } mappend a b = InitFlags { nonInteractive = combine nonInteractive@@ -113,6 +117,7 @@ , dependencies = combine dependencies , sourceDirs = combine sourceDirs , buildTools = combine buildTools+ , initVerbosity = combine initVerbosity } where combine field = field a `mappend` field b
Distribution/Client/Install.hs view
@@ -19,9 +19,9 @@ ) where import Data.List- ( unfoldr, find, nub, sort )+ ( unfoldr, nub, sort, (\\) ) import Data.Maybe- ( isJust, fromMaybe )+ ( isJust, fromMaybe, maybeToList ) import Control.Exception as Exception ( handleJust ) #if MIN_VERSION_base(4,0,0)@@ -42,17 +42,19 @@ import System.FilePath ( (</>), (<.>), takeDirectory ) import System.IO- ( openFile, IOMode(AppendMode) )+ ( openFile, IOMode(AppendMode), stdout, hFlush ) import System.IO.Error ( isDoesNotExistError, ioeGetFileName ) import Distribution.Client.Targets import Distribution.Client.Dependency+import Distribution.Client.Dependency.Types+ ( Solver(..) ) import Distribution.Client.FetchUtils import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) -- import qualified Distribution.Client.Info as Info import Distribution.Client.IndexUtils as IndexUtils- ( getAvailablePackages, getInstalledPackages )+ ( getSourcePackages, getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.Setup@@ -62,7 +64,7 @@ import Distribution.Client.Config ( defaultCabalDir ) import Distribution.Client.Tar (extractTarGzFile)-import Distribution.Client.Types as Available+import Distribution.Client.Types as Source import Distribution.Client.BuildReports.Types ( ReportLevel(..) ) import Distribution.Client.SetupWrapper@@ -74,6 +76,7 @@ ( symlinkBinaries ) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.Client.World as World+import qualified Distribution.InstalledPackageInfo as Installed import Paths_cabal_install_bundle (getBinDir) import Distribution.Simple.Compiler@@ -81,14 +84,15 @@ , PackageDB(..), PackageDBStack ) import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration) import qualified Distribution.Simple.InstallDirs as InstallDirs-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (PackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Simple.Setup- ( haddockCommand, HaddockFlags(..), emptyHaddockFlags+ ( haddockCommand, HaddockFlags(..) , buildCommand, BuildFlags(..), emptyBuildFlags , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe ) import qualified Distribution.Simple.Setup as Cabal- ( installCommand, InstallFlags(..), emptyInstallFlags )+ ( installCommand, InstallFlags(..), emptyInstallFlags+ , emptyTestFlags, testCommand ) import Distribution.Simple.Utils ( rawSystemExit, comparing ) import Distribution.Simple.InstallDirs as InstallDirs@@ -97,16 +101,17 @@ import Distribution.Package ( PackageIdentifier, packageName, packageVersion , Package(..), PackageFixedDeps(..)- , Dependency(..), thisPackageVersion )+ , Dependency(..), thisPackageVersion, InstalledPackageId ) import qualified Distribution.PackageDescription as PackageDescription import Distribution.PackageDescription- ( PackageDescription )+ ( PackageDescription, GenericPackageDescription(..), Flag(..)+ , FlagName(..), FlagAssignment ) import Distribution.PackageDescription.Configuration ( finalizePackageDescription ) import Distribution.Version ( Version, anyVersion, thisVersion ) import Distribution.Simple.Utils as Utils- ( notice, info, debug, warn, die, intercalate, withTempDirectory )+ ( notice, info, warn, die, intercalate, withTempDirectory ) import Distribution.Client.Utils ( inDir, mergeBy, MergeResult(..) ) import Distribution.System@@ -114,7 +119,7 @@ import Distribution.Text ( display ) import Distribution.Verbosity as Verbosity- ( Verbosity, showForCabal, verbose )+ ( Verbosity, showForCabal, verbose, deafening ) import Distribution.Simple.BuildPaths ( exeExtension ) --TODO:@@ -145,45 +150,53 @@ -> ConfigFlags -> ConfigExFlags -> InstallFlags+ -> HaddockFlags -> [UserTarget] -> IO () install verbosity packageDBs repos comp conf- globalFlags configFlags configExFlags installFlags userTargets0 = do+ globalFlags configFlags configExFlags installFlags haddockFlags userTargets0 = do - installed <- getInstalledPackages verbosity comp packageDBs conf- availableDb <- getAvailablePackages verbosity repos+ installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+ sourcePkgDb <- getSourcePackages verbosity repos + solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags)) (compilerId comp)+ let -- For install, if no target is given it means we use the -- current directory as the single target userTargets | null userTargets0 = [UserTargetLocalDir "."] | otherwise = userTargets0 pkgSpecifiers <- resolveUserTargets verbosity- globalFlags (packageIndex availableDb) userTargets+ (fromFlag $ globalWorldFile globalFlags)+ (packageIndex sourcePkgDb)+ userTargets notice verbosity "Resolving dependencies..." installPlan <- foldProgress logMsg die return $ planPackages- comp configFlags configExFlags installFlags- installed availableDb pkgSpecifiers+ comp solver configFlags configExFlags installFlags+ installedPkgIndex sourcePkgDb pkgSpecifiers - printPlanMessages verbosity installed installPlan dryRun+ checkPrintPlan verbosity installedPkgIndex installPlan installFlags pkgSpecifiers unless dryRun $ do installPlan' <- performInstallations verbosity- context installed installPlan+ context installedPkgIndex installPlan postInstallActions verbosity context userTargets installPlan' where context :: InstallContext context = (packageDBs, repos, comp, conf,- globalFlags, configFlags, configExFlags, installFlags)+ globalFlags, configFlags, configExFlags, installFlags, haddockFlags) dryRun = fromFlag (installDryRun installFlags)- logMsg message rest = debug verbosity message >> rest-+ logMsg message rest = debugNoWrap message >> rest+ -- Solver debug output really looks better without automatic+ -- line wrapping. TODO: This should probably be moved into+ -- the utilities module.+ debugNoWrap xs = when (verbosity >= deafening) (putStrLn xs >> hFlush stdout) -upgrade _ _ _ _ _ _ _ _ _ _ = die $+upgrade _ _ _ _ _ _ _ _ _ _ _ = die $ "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 "@@ -203,25 +216,28 @@ , GlobalFlags , ConfigFlags , ConfigExFlags- , InstallFlags )+ , InstallFlags+ , HaddockFlags ) -- ------------------------------------------------------------ -- * Installation planning -- ------------------------------------------------------------ planPackages :: Compiler+ -> Solver -> ConfigFlags -> ConfigExFlags -> InstallFlags- -> PackageIndex InstalledPackage- -> AvailablePackageDb- -> [PackageSpecifier AvailablePackage]+ -> PackageIndex+ -> SourcePackageDb+ -> [PackageSpecifier SourcePackage] -> Progress String String InstallPlan-planPackages comp configFlags configExFlags installFlags- installed availableDb pkgSpecifiers =+planPackages comp solver configFlags configExFlags installFlags+ installedPkgIndex sourcePkgDb pkgSpecifiers = resolveDependencies buildPlatform (compilerId comp)+ solver resolverParams >>= if onlyDeps then adjustPlanOnlyDeps else return@@ -229,7 +245,18 @@ where resolverParams = - setPreferenceDefault (if upgradeDeps then PreferAllLatest+ setMaxBackjumps (if maxBackjumps < 0 then Nothing+ else Just maxBackjumps)++ . setIndependentGoals independentGoals++ . setReorderGoals reorderGoals++ . setAvoidReinstalls avoidReinstalls++ . setShadowPkgs shadowPkgs++ . setPreferenceDefault (if upgradeDeps then PreferAllLatest else PreferLatestForSelected) . addPreferences@@ -239,32 +266,39 @@ . addConstraints -- version constraints from the config file or command line- [ PackageVersionConstraint name ver- | Dependency name ver <- configConstraints configFlags ]+ (map userToPackageConstraint (configExConstraints configExFlags)) . addConstraints --FIXME: this just applies all flags to all targets which -- is silly. We should check if the flags are appropriate- [ PackageFlagsConstraint (pkgSpecifierTarget pkgSpecifier) flags+ [ PackageConstraintFlags (pkgSpecifierTarget pkgSpecifier) flags | let flags = configConfigurationsFlags configFlags , not (null flags) , pkgSpecifier <- pkgSpecifiers ] + . addConstraints+ [ PackageConstraintStanzas (pkgSpecifierTarget pkgSpecifier) stanzas+ | pkgSpecifier <- pkgSpecifiers ]+ . (if reinstall then reinstallTargets else id) - $ standardInstallPolicy installed availableDb pkgSpecifiers+ $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + stanzas = concat+ [ if testsEnabled then [TestStanzas] else []+ , if benchmarksEnabled then [BenchStanzas] else []+ ]+ testsEnabled = fromFlagOrDefault False $ configTests configFlags+ benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags+ --TODO: this is a general feature and should be moved to D.C.Dependency -- Also, the InstallPlan.remove should return info more precise to the -- problem, rather than the very general PlanProblem type. adjustPlanOnlyDeps :: InstallPlan -> Progress String String InstallPlan adjustPlanOnlyDeps = either (Fail . explain) Done- . InstallPlan.remove isTarget+ . InstallPlan.remove (isTarget pkgSpecifiers) where- isTarget pkg = packageName pkg `elem` targetnames- targetnames = map pkgSpecifierTarget pkgSpecifiers- explain :: [InstallPlan.PlanProblem] -> String explain problems = "Cannot select only the dependencies (as requested by the "@@ -281,74 +315,210 @@ , depid <- depids , packageName depid `elem` targetnames ] - reinstall = fromFlag (installReinstall installFlags)- upgradeDeps = fromFlag (installUpgradeDeps installFlags)- onlyDeps = fromFlag (installOnlyDeps installFlags)+ targetnames = map pkgSpecifierTarget pkgSpecifiers ++ reinstall = fromFlag (installReinstall installFlags)+ reorderGoals = fromFlag (installReorderGoals installFlags)+ independentGoals = fromFlag (installIndependentGoals installFlags)+ avoidReinstalls = fromFlag (installAvoidReinstalls installFlags)+ shadowPkgs = fromFlag (installShadowPkgs installFlags)+ maxBackjumps = fromFlag (installMaxBackjumps installFlags)+ upgradeDeps = fromFlag (installUpgradeDeps installFlags)+ onlyDeps = fromFlag (installOnlyDeps installFlags)+ -- ------------------------------------------------------------ -- * Informational messages -- ------------------------------------------------------------ -printPlanMessages :: Verbosity- -> PackageIndex InstalledPackage- -> InstallPlan- -> Bool- -> IO ()-printPlanMessages verbosity installed installPlan dryRun = do+-- | Perform post-solver checks of the install plan and print it if+-- either requested or needed.+checkPrintPlan :: Verbosity+ -> PackageIndex+ -> InstallPlan+ -> InstallFlags+ -> [PackageSpecifier SourcePackage]+ -> IO ()+checkPrintPlan verbosity installed installPlan installFlags pkgSpecifiers = do + -- User targets that are already installed.+ let preExistingTargets =+ [ p | let tgts = map pkgSpecifierTarget pkgSpecifiers,+ InstallPlan.PreExisting p <- InstallPlan.toList installPlan,+ packageName p `elem` tgts ]++ -- If there's nothing to install, we print the already existing+ -- target packages as an explanation. when nothingToInstall $- notice verbosity $- "No packages to be installed. All the requested packages are "- ++ "already installed.\n If you want to reinstall anyway then use "- ++ "the --reinstall flag."+ notice verbosity $ unlines $+ "All the requested packages are already installed:"+ : map (display . packageId) preExistingTargets+ ++ ["Use --reinstall if you want to reinstall anyway."] - when (dryRun || verbosity >= verbose) $- printDryRun verbosity installed installPlan+ let lPlan = linearizeInstallPlan installed installPlan+ -- Are any packages classified as reinstalls?+ let reinstalledPkgs = concatMap (extractReinstalls . snd) lPlan+ -- Packages that are already broken.+ let oldBrokenPkgs =+ map Installed.installedPackageId+ . PackageIndex.reverseDependencyClosure installed+ . map (Installed.installedPackageId . fst)+ . PackageIndex.brokenPackages+ $ installed+ let excluded = reinstalledPkgs ++ oldBrokenPkgs+ -- Packages that are reverse dependencies of replaced packages are very+ -- likely to be broken. We exclude packages that are already broken.+ let newBrokenPkgs =+ filter (\ p -> not (Installed.installedPackageId p `elem` excluded))+ (PackageIndex.reverseDependencyClosure installed reinstalledPkgs)+ let containsReinstalls = not (null reinstalledPkgs)+ let breaksPkgs = not (null newBrokenPkgs) + let adaptedVerbosity+ | containsReinstalls && not overrideReinstall = verbosity `max` verbose+ | otherwise = verbosity++ -- We print the install plan if we are in a dry-run or if we are confronted+ -- with a dangerous install plan.+ when (dryRun || containsReinstalls && not overrideReinstall) $+ printPlan (dryRun || breaksPkgs && not overrideReinstall) adaptedVerbosity lPlan++ -- If the install plan is dangerous, we print various warning messages. In+ -- particular, if we can see that packages are likely to be broken, we even+ -- bail out (unless installation has been forced with --force-reinstalls).+ when containsReinstalls $ do+ if breaksPkgs+ then do+ (if dryRun || overrideReinstall then warn verbosity else die) $ unlines $+ "The following packages are likely to be broken by the reinstalls:"+ : map (display . Installed.sourcePackageId) newBrokenPkgs+ ++ if overrideReinstall+ then if dryRun then [] else+ ["Continuing even though the plan contains dangerous reinstalls."]+ else+ ["Use --force-reinstalls if you want to install anyway."]+ else unless dryRun $ warn verbosity+ "Note that reinstalls are always dangerous. Continuing anyway..."+ where nothingToInstall = null (InstallPlan.ready installPlan) + dryRun = fromFlag (installDryRun installFlags)+ overrideReinstall = fromFlag (installOverrideReinstall installFlags) -printDryRun :: Verbosity- -> PackageIndex InstalledPackage- -> InstallPlan- -> IO ()-printDryRun verbosity installed plan = case unfoldr next plan of- [] -> return ()- pkgs- | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $- "In order, the following would be installed:"- : map showPkgAndReason pkgs- | otherwise -> notice verbosity $ unlines $- "In order, the following would be installed (use -v for more details):"- : map (display . packageId) pkgs+linearizeInstallPlan :: PackageIndex+ -> InstallPlan+ -> [(ConfiguredPackage, PackageStatus)]+linearizeInstallPlan installedPkgIndex plan = unfoldr next plan where next plan' = case InstallPlan.ready plan' of [] -> Nothing- (pkg:_) -> Just (pkg, InstallPlan.completed pkgid result plan')- where pkgid = packageId pkg+ (pkg:_) -> Just ((pkg, status), InstallPlan.completed pkgid result plan')+ where pkgid = packageId pkg+ status = packageStatus installedPkgIndex pkg result = BuildOk DocsNotTried TestsNotTried --FIXME: This is a bit of a hack, -- pretending that each package is installed - showPkgAndReason pkg' = display (packageId pkg') ++ " " ++- case PackageIndex.lookupPackageName installed (packageName pkg') of- [] -> "(new package)"- ps -> case find ((==packageId pkg') . packageId) ps of- Nothing -> "(new version)"- Just pkg -> "(reinstall)" ++ case changes pkg pkg' of- [] -> ""- diff -> " changes: " ++ intercalate ", " diff- changes pkg pkg' = map change . filter changed+data PackageStatus = NewPackage+ | NewVersion [Version]+ | Reinstall [InstalledPackageId] [PackageChange]++type PackageChange = MergeResult PackageIdentifier PackageIdentifier++isTarget :: Package pkg => [PackageSpecifier SourcePackage] -> pkg -> Bool+isTarget pkgSpecifiers pkg = packageName pkg `elem` targetnames+ where+ targetnames = map pkgSpecifierTarget pkgSpecifiers++extractReinstalls :: PackageStatus -> [InstalledPackageId]+extractReinstalls (Reinstall ipids _) = ipids+extractReinstalls _ = []++packageStatus :: PackageIndex -> ConfiguredPackage -> PackageStatus+packageStatus installedPkgIndex cpkg =+ case PackageIndex.lookupPackageName installedPkgIndex+ (packageName cpkg) of+ [] -> NewPackage+ ps -> case filter ((==packageId cpkg) . Installed.sourcePackageId) (concatMap snd ps) of+ [] -> NewVersion (map fst ps)+ pkgs@(pkg:_) -> Reinstall (map Installed.installedPackageId pkgs)+ (changes pkg cpkg)++ where++ changes :: Installed.InstalledPackageInfo+ -> ConfiguredPackage+ -> [MergeResult PackageIdentifier PackageIdentifier]+ changes pkg pkg' = filter changed $ mergeBy (comparing packageName)- (nub . sort . depends $ pkg)+ -- get dependencies of installed package (convert to source pkg ids via index)+ (nub . sort . concatMap (maybeToList .+ fmap Installed.sourcePackageId .+ PackageIndex.lookupInstalledPackageId installedPkgIndex) .+ Installed.depends $ pkg)+ -- get dependencies of configured package (nub . sort . depends $ pkg')++ changed (InBoth pkgid pkgid') = pkgid /= pkgid'+ changed _ = True++printPlan :: Bool -- is dry run+ -> Verbosity+ -> [(ConfiguredPackage, PackageStatus)]+ -> IO ()+printPlan dryRun verbosity plan = case plan of+ [] -> return ()+ pkgs+ | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $+ ("In order, the following " ++ wouldWill ++ " be installed:")+ : map showPkgAndReason pkgs+ | otherwise -> notice verbosity $ unlines $+ ("In order, the following " ++ wouldWill ++ " be installed (use -v for more details):")+ : map (display . packageId) (map fst pkgs)+ where+ wouldWill | dryRun = "would"+ | otherwise = "will"++ showPkgAndReason (pkg', pr) = display (packageId pkg') +++ showFlagAssignment (nonDefaultFlags pkg') +++ showStanzas (stanzas pkg') ++ " " +++ case pr of+ NewPackage -> "(new package)"+ NewVersion _ -> "(new version)"+ Reinstall _ cs -> "(reinstall)" ++ case cs of+ [] -> ""+ diff -> " changes: " ++ intercalate ", " (map change diff)++ toFlagAssignment :: [Flag] -> FlagAssignment+ toFlagAssignment = map (\ f -> (flagName f, flagDefault f))++ nonDefaultFlags :: ConfiguredPackage -> FlagAssignment+ nonDefaultFlags (ConfiguredPackage spkg fa _ _) =+ let defaultAssignment =+ toFlagAssignment+ (genPackageFlags (Source.packageDescription spkg))+ in fa \\ defaultAssignment++ stanzas :: ConfiguredPackage -> [OptionalStanza]+ stanzas (ConfiguredPackage _ _ sts _) = sts++ showStanzas :: [OptionalStanza] -> String+ showStanzas = concatMap ((' ' :) . showStanza)+ showStanza TestStanzas = "*test"+ showStanza BenchStanzas = "*bench"++ -- FIXME: this should be a proper function in a proper place+ showFlagAssignment :: FlagAssignment -> String+ showFlagAssignment = concatMap ((' ' :) . showFlagValue)+ showFlagValue (f, True) = '+' : showFlagName f+ showFlagValue (f, False) = '-' : showFlagName f+ showFlagName (FlagName f) = f+ change (OnlyInLeft pkgid) = display pkgid ++ " removed" change (InBoth pkgid pkgid') = display pkgid ++ " -> " ++ display (packageVersion pkgid') change (OnlyInRight pkgid') = display pkgid' ++ " added"- changed (InBoth pkgid pkgid') = pkgid /= pkgid'- changed _ = True -- ------------------------------------------------------------ -- * Post installation stuff@@ -369,7 +539,7 @@ -> InstallPlan -> IO () postInstallActions verbosity- (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags)+ (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags, _) targets installPlan = do unless oneShot $@@ -458,8 +628,8 @@ "Updating documentation index " ++ indexFile --TODO: might be nice if the install plan gave us the new InstalledPackageInfo- installed <- getInstalledPackages verbosity comp packageDBs conf- Haddock.regenerateHaddockIndex verbosity installed conf indexFile+ installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+ Haddock.regenerateHaddockIndex verbosity installedPkgIndex conf indexFile | otherwise = return () where@@ -542,6 +712,8 @@ ++ " The exception was:\n " ++ show e BuildFailed e -> " failed during the building phase." ++ " The exception was:\n " ++ show e+ TestsFailed e -> " failed during the tests phase."+ ++ " The exception was:\n " ++ show e InstallFailed e -> " failed during the final install step." ++ " The exception was:\n " ++ show e @@ -557,21 +729,22 @@ performInstallations :: Verbosity -> InstallContext- -> PackageIndex InstalledPackage+ -> PackageIndex -> InstallPlan -> IO InstallPlan performInstallations verbosity (packageDBs, _, comp, conf,- globalFlags, configFlags, configExFlags, installFlags)- installed installPlan = do+ globalFlags, configFlags, configExFlags, installFlags, haddockFlags)+ installedPkgIndex installPlan = do executeInstallPlan installPlan $ \cpkg -> installConfiguredPackage platform compid configFlags cpkg $ \configFlags' src pkg ->- fetchAvailablePackage verbosity src $ \src' ->+ fetchSourcePackage verbosity src $ \src' -> installLocalPackage verbosity (packageId pkg) src' $ \mpath ->- installUnpackedPackage verbosity (setupScriptOptions installed)- miscOptions configFlags' installFlags+ installUnpackedPackage verbosity+ (setupScriptOptions installedPkgIndex)+ miscOptions configFlags' installFlags haddockFlags compid pkg mpath useLogFile where@@ -646,7 +819,7 @@ -- which kind of means it was not their fault. --- | Call an installer for an 'AvailablePackage' but override the configure+-- | Call an installer for an 'SourcePackage' but override the configure -- flags with the ones given by the 'ConfiguredPackage'. In particular the -- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly -- versioned package dependencies. So we ignore any previous partial flag@@ -658,24 +831,26 @@ -> PackageDescription -> a) -> a installConfiguredPackage platform comp configFlags- (ConfiguredPackage (AvailablePackage _ gpkg source) flags deps)+ (ConfiguredPackage (SourcePackage _ gpkg source) flags stanzas deps) installPkg = installPkg configFlags { configConfigurationsFlags = flags,- configConstraints = map thisPackageVersion deps+ configConstraints = map thisPackageVersion deps,+ configBenchmarks = toFlag False,+ configTests = toFlag (TestStanzas `elem` stanzas) } source pkg where pkg = case finalizePackageDescription flags (const True)- platform comp [] gpkg of+ platform comp [] (enableStanzas stanzas gpkg) of Left _ -> error "finalizePackageDescription ConfiguredPackage failed" Right (desc, _) -> desc -fetchAvailablePackage+fetchSourcePackage :: Verbosity -> PackageLocation (Maybe FilePath) -> (PackageLocation FilePath -> IO BuildResult) -> IO BuildResult-fetchAvailablePackage verbosity src installPkg = do+fetchSourcePackage verbosity src installPkg = do fetched <- checkFetched src case fetched of Just src' -> installPkg src'@@ -728,13 +903,14 @@ -> InstallMisc -> ConfigFlags -> InstallFlags+ -> HaddockFlags -> CompilerId -> PackageDescription -> Maybe FilePath -- ^ Directory to change to before starting the installation. -> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any) -> IO BuildResult installUnpackedPackage verbosity scriptOptions miscOptions- configFlags installConfigFlags+ configFlags installConfigFlags haddockFlags compid pkg workingDir useLogFile = -- Configure phase@@ -747,23 +923,28 @@ -- Doc generation phase docsResult <- if shouldHaddock- then (do setup haddockCommand haddockFlags+ then (do setup haddockCommand haddockFlags' return DocsOk) `catchIO` (\_ -> return DocsFailed) `catchExit` (\_ -> return DocsFailed) else return DocsNotTried -- Tests phase- testsResult <- return TestsNotTried --TODO: add optional tests+ onFailure TestsFailed $ do+ when (testsEnabled && PackageDescription.hasTests pkg) $+ setup Cabal.testCommand testFlags - -- Install phase- onFailure InstallFailed $- withWin32SelfUpgrade verbosity configFlags compid pkg $ do- case rootCmd miscOptions of- (Just cmd) -> reexec cmd- Nothing -> setup Cabal.installCommand installFlags- return (Right (BuildOk docsResult testsResult))+ let testsResult | testsEnabled = TestsOk+ | otherwise = TestsNotTried + -- Install phase+ onFailure InstallFailed $+ withWin32SelfUpgrade verbosity configFlags compid pkg $ do+ case rootCmd miscOptions of+ (Just cmd) -> reexec cmd+ Nothing -> setup Cabal.installCommand installFlags+ return (Right (BuildOk docsResult testsResult))+ where configureFlags = filterConfigureFlags configFlags { configVerbosity = toFlag verbosity'@@ -774,10 +955,11 @@ buildVerbosity = toFlag verbosity' } shouldHaddock = fromFlag (installDocumentation installConfigFlags)- haddockFlags _ = emptyHaddockFlags {- haddockDistPref = configDistPref configFlags,+ haddockFlags' _ = haddockFlags { haddockVerbosity = toFlag verbosity' }+ testsEnabled = fromFlag (configTests configFlags)+ testFlags _ = Cabal.emptyTestFlags installFlags _ = Cabal.emptyInstallFlags { Cabal.installDistPref = configDistPref configFlags, Cabal.installVerbosity = toFlag verbosity'
Distribution/Client/InstallPlan.hs view
@@ -45,9 +45,8 @@ ) where import Distribution.Client.Types- ( AvailablePackage(packageDescription), ConfiguredPackage(..)- , InstalledPackage- , BuildFailure, BuildSuccess )+ ( SourcePackage(packageDescription), ConfiguredPackage(..)+ , InstalledPackage, BuildFailure, BuildSuccess, enableStanzas ) import Distribution.Package ( PackageIdentifier(..), PackageName(..), Package(..), packageName , PackageFixedDeps(..), Dependency(..) )@@ -88,32 +87,32 @@ -- -- The Problem: ----- In general we start with a set of installed packages and a set of available+-- In general we start with a set of installed packages and a set of source -- packages. -- -- Installed packages have fixed dependencies. They have already been built and -- we know exactly what packages they were built against, including their exact--- versions. +-- versions. ----- Available package have somewhat flexible dependencies. They are specified as+-- Source package have somewhat flexible dependencies. They are specified as -- version ranges, though really they're predicates. To make matters worse they -- have conditional flexible dependencies. Configuration flags can affect which -- packages are required and can place additional constraints on their -- versions. -- -- These two sets of package can and usually do overlap. There can be installed--- packages that are also available which means they could be re-installed if--- required, though there will also be packages which are not available and--- cannot be re-installed. Very often there will be extra versions available--- than are installed. Sometimes we may like to prefer installed packages over--- available ones or perhaps always prefer the latest available version whether--- installed or not.+-- packages that are also available as source packages which means they could+-- be re-installed if required, though there will also be packages which are+-- not available as source and cannot be re-installed. Very often there will be+-- extra versions available than are installed. Sometimes we may like to prefer+-- installed packages over source ones or perhaps always prefer the latest+-- available version whether installed or not. -- -- The goal is to calculate an installation plan that is closed, acyclic and -- consistent and where every configured package is valid. -- -- An installation plan is a set of packages that are going to be used--- together. It will consist of a mixture of installed packages and available+-- together. It will consist of a mixture of installed packages and source -- packages along with their exact version dependencies. An installation plan -- is closed if for every package in the set, all of its dependencies are -- also in the set. It is consistent if for every package in the set, all@@ -472,7 +471,7 @@ configuredPackageProblems :: Platform -> CompilerId -> ConfiguredPackage -> [PackageProblem] configuredPackageProblems platform comp- (ConfiguredPackage pkg specifiedFlags specifiedDeps) =+ (ConfiguredPackage pkg specifiedFlags stanzas specifiedDeps) = [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ] ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ]@@ -506,6 +505,6 @@ (const True) platform comp []- (packageDescription pkg) of+ (enableStanzas stanzas $ packageDescription pkg) of Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg Left _ -> error "configuredPackageInvalidDeps internal error"
Distribution/Client/InstallSymlink.hs view
@@ -40,7 +40,7 @@ #else import Distribution.Client.Types- ( AvailablePackage(..), ConfiguredPackage(..) )+ ( SourcePackage(..), ConfiguredPackage(..), enableStanzas ) import Distribution.Client.Setup ( InstallFlags(installSymlinkBinDir) ) import qualified Distribution.Client.InstallPlan as InstallPlan@@ -132,10 +132,10 @@ , PackageDescription.buildable (PackageDescription.buildInfo exe) ] pkgDescription :: ConfiguredPackage -> PackageDescription- pkgDescription (ConfiguredPackage (AvailablePackage _ pkg _) flags _) =+ pkgDescription (ConfiguredPackage (SourcePackage _ pkg _) flags stanzas _) = case finalizePackageDescription flags (const True)- platform compilerId [] pkg of+ platform compilerId [] (enableStanzas stanzas pkg) of Left _ -> error "finalizePackageDescription ConfiguredPackage failed" Right (desc, _) -> desc
Distribution/Client/List.hs view
@@ -15,11 +15,11 @@ import Distribution.Package ( PackageName(..), Package(..), packageName, packageVersion- , Dependency(..), thisPackageVersion, depends, simplifyDependency )+ , Dependency(..), simplifyDependency ) import Distribution.ModuleName (ModuleName) import Distribution.License (License) import qualified Distribution.InstalledPackageInfo as Installed-import qualified Distribution.PackageDescription as Available+import qualified Distribution.PackageDescription as Source import Distribution.PackageDescription ( Flag(..), FlagName(..) ) import Distribution.PackageDescription.Configuration@@ -31,6 +31,7 @@ import Distribution.Simple.Utils ( equating, comparing, die, notice ) import Distribution.Simple.Setup (fromFlag)+import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Version ( Version(..), VersionRange, withinRange, anyVersion@@ -40,10 +41,9 @@ ( Text(disp), display ) import Distribution.Client.Types- ( AvailablePackage(..), Repo, AvailablePackageDb(..)- , InstalledPackage(..) )+ ( SourcePackage(..), Repo, SourcePackageDb(..) ) import Distribution.Client.Dependency.Types- ( PackageConstraint(..) )+ ( PackageConstraint(..), ExtDependency(..) ) import Distribution.Client.Targets ( UserTarget, resolveUserTargets, PackageSpecifier(..) ) import Distribution.Client.Setup@@ -51,7 +51,7 @@ import Distribution.Client.Utils ( mergeBy, MergeResult(..) ) import Distribution.Client.IndexUtils as IndexUtils- ( getAvailablePackages, getInstalledPackages )+ ( getSourcePackages, getInstalledPackages ) import Distribution.Client.FetchUtils ( isFetched ) @@ -65,7 +65,7 @@ ( MonadPlus(mplus), join ) import Control.Exception ( assert )-import Text.PrettyPrint.HughesPJ as Disp+import Text.PrettyPrint as Disp import System.Directory ( doesDirectoryExist ) @@ -81,29 +81,29 @@ -> IO () list verbosity packageDBs repos comp conf listFlags pats = do - installed <- getInstalledPackages verbosity comp packageDBs conf- availableDb <- getAvailablePackages verbosity repos- let available = packageIndex availableDb+ installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+ sourcePkgDb <- getSourcePackages verbosity repos+ let sourcePkgIndex = packageIndex sourcePkgDb prefs name = fromMaybe anyVersion- (Map.lookup name (packagePreferences availableDb))+ (Map.lookup name (packagePreferences sourcePkgDb)) - pkgsInfo :: [(PackageName, [InstalledPackage], [AvailablePackage])]+ pkgsInfo :: [(PackageName, [Installed.InstalledPackageInfo], [SourcePackage])] pkgsInfo -- gather info for all packages- | null pats = mergePackages (PackageIndex.allPackages installed)- (PackageIndex.allPackages available)+ | null pats = mergePackages (InstalledPackageIndex.allPackages installedPkgIndex)+ ( PackageIndex.allPackages sourcePkgIndex) -- gather info for packages matching search term- | otherwise = mergePackages (matchingPackages installed)- (matchingPackages available)+ | otherwise = mergePackages (matchingPackages InstalledPackageIndex.searchByNameSubstring installedPkgIndex)+ (matchingPackages (\ idx n -> concatMap snd (PackageIndex.searchByNameSubstring idx n)) sourcePkgIndex) matches :: [PackageDisplayInfo] matches = [ mergePackageInfo pref- installedPkgs availablePkgs selectedPkg False- | (pkgname, installedPkgs, availablePkgs) <- pkgsInfo+ installedPkgs sourcePkgs selectedPkg False+ | (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo , not onlyInstalled || not (null installedPkgs) , let pref = prefs pkgname- selectedPkg = latestWithPref pref availablePkgs ]+ selectedPkg = latestWithPref pref sourcePkgs ] if simpleOutput then putStr $ unlines@@ -112,10 +112,10 @@ , version <- if onlyInstalled then installedVersions pkg else nub . sort $ installedVersions pkg- ++ availableVersions pkg ]+ ++ sourceVersions pkg ] -- Note: this only works because for 'list', one cannot currently -- specify any version constraints, so listing all installed- -- and available ones works.+ -- and source ones works. else if null matches then notice verbosity "No matches found."@@ -124,11 +124,10 @@ onlyInstalled = fromFlag (listInstalled listFlags) simpleOutput = fromFlag (listSimpleOutput listFlags) - matchingPackages index =+ matchingPackages search index = [ pkg | pat <- pats- , (_, pkgs) <- PackageIndex.searchByNameSubstring index pat- , pkg <- pkgs ]+ , pkg <- search index pat ] info :: Verbosity -> PackageDBStack@@ -142,66 +141,73 @@ info verbosity packageDBs repos comp conf globalFlags _listFlags userTargets = do - installed <- getInstalledPackages verbosity comp packageDBs conf- availableDb <- getAvailablePackages verbosity repos- let available = packageIndex availableDb+ installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+ sourcePkgDb <- getSourcePackages verbosity repos+ let sourcePkgIndex = packageIndex sourcePkgDb prefs name = fromMaybe anyVersion- (Map.lookup name (packagePreferences availableDb))+ (Map.lookup name (packagePreferences sourcePkgDb)) -- Users may specify names of packages that are only installed, not -- just available source packages, so we must resolve targets using- -- the combination of installed and available packages.- let available' = PackageIndex.fromList- $ map packageId (PackageIndex.allPackages installed)- ++ map packageId (PackageIndex.allPackages available)+ -- the combination of installed and source packages.+ let sourcePkgs' = PackageIndex.fromList+ $ map packageId (InstalledPackageIndex.allPackages installedPkgIndex)+ ++ map packageId ( PackageIndex.allPackages sourcePkgIndex) pkgSpecifiers <- resolveUserTargets verbosity- globalFlags available' userTargets+ (fromFlag $ globalWorldFile globalFlags)+ sourcePkgs' userTargets pkgsinfo <- sequence [ do pkginfo <- either die return $ gatherPkgInfo prefs- installed available pkgSpecifier+ installedPkgIndex sourcePkgIndex+ pkgSpecifier updateFileSystemPackageDetails pkginfo | pkgSpecifier <- pkgSpecifiers ] putStr $ unlines (map showPackageDetailedInfo pkgsinfo) where- gatherPkgInfo prefs installed available (NamedPackage name constraints)- | null (selectedInstalledPkgs) && null (selectedAvailablePkgs)+ gatherPkgInfo :: (PackageName -> VersionRange) ->+ InstalledPackageIndex.PackageIndex ->+ PackageIndex.PackageIndex SourcePackage ->+ PackageSpecifier SourcePackage ->+ Either String PackageDisplayInfo+ gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (NamedPackage name constraints)+ | null (selectedInstalledPkgs) && null (selectedSourcePkgs) = Left $ "There is no available version of " ++ display name ++ " that satisfies " ++ display (simplifyVersionRange verConstraint) | otherwise = Right $ mergePackageInfo pref installedPkgs- availablePkgs selectedAvailablePkg+ sourcePkgs selectedSourcePkg' showPkgVersion where pref = prefs name- installedPkgs = PackageIndex.lookupPackageName installed name- availablePkgs = PackageIndex.lookupPackageName available name+ installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name)+ sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name - selectedInstalledPkgs = PackageIndex.lookupDependency installed+ selectedInstalledPkgs = InstalledPackageIndex.lookupDependency installedPkgIndex (Dependency name verConstraint)- selectedAvailablePkgs = PackageIndex.lookupDependency available+ selectedSourcePkgs = PackageIndex.lookupDependency sourcePkgIndex (Dependency name verConstraint)- selectedAvailablePkg = latestWithPref pref selectedAvailablePkgs+ selectedSourcePkg' = latestWithPref pref selectedSourcePkgs -- display a specific package version if the user -- supplied a non-trivial version constraint showPkgVersion = not (null verConstraints) verConstraint = foldr intersectVersionRanges anyVersion verConstraints- verConstraints = [ vr | PackageVersionConstraint _ vr <- constraints ]+ verConstraints = [ vr | PackageConstraintVersion _ vr <- constraints ] - gatherPkgInfo prefs installed available (SpecificSourcePackage pkg) =- Right $ mergePackageInfo pref installedPkgs availablePkgs+ gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (SpecificSourcePackage pkg) =+ Right $ mergePackageInfo pref installedPkgs sourcePkgs selectedPkg True where name = packageName pkg pref = prefs name- installedPkgs = PackageIndex.lookupPackageName installed name- availablePkgs = PackageIndex.lookupPackageName available name+ installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name)+ sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name selectedPkg = Just pkg @@ -211,9 +217,9 @@ data PackageDisplayInfo = PackageDisplayInfo { pkgName :: PackageName, selectedVersion :: Maybe Version,- selectedAvailable :: Maybe AvailablePackage,+ selectedSourcePkg :: Maybe SourcePackage, installedVersions :: [Version],- availableVersions :: [Version],+ sourceVersions :: [Version], preferredVersions :: VersionRange, homepage :: String, bugReports :: String,@@ -224,7 +230,7 @@ license :: License, author :: String, maintainer :: String,- dependencies :: [Dependency],+ dependencies :: [ExtDependency], flags :: [Flag], hasLib :: Bool, hasExe :: Bool,@@ -242,7 +248,7 @@ (nest 4 $ vcat [ maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs , text "Default available version:" <+>- case selectedAvailable pkginfo of+ case selectedSourcePkg pkginfo of Nothing -> text "[ Not available from any configured repository ]" Just pkg -> disp (packageVersion pkg) , text "Installed versions:" <+>@@ -269,7 +275,7 @@ $+$ (nest 4 $ vcat [ entry "Synopsis" synopsis hideIfNull reflowParagraphs- , entry "Versions available" availableVersions+ , entry "Versions available" sourceVersions (altText null "[ Not available from server ]") (dispTopVersions 9 (preferredVersions pkginfo)) , entry "Versions installed" installedVersions@@ -351,56 +357,55 @@ -- package name. -- mergePackageInfo :: VersionRange- -> [InstalledPackage]- -> [AvailablePackage]- -> Maybe AvailablePackage+ -> [Installed.InstalledPackageInfo]+ -> [SourcePackage]+ -> Maybe SourcePackage -> Bool -> PackageDisplayInfo-mergePackageInfo versionPref installedPkgs availablePkgs selectedPkg showVer =- assert (length installedPkgs + length availablePkgs > 0) $+mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer =+ assert (length installedPkgs + length sourcePkgs > 0) $ PackageDisplayInfo {- pkgName = combine packageName available+ pkgName = combine packageName source packageName installed, selectedVersion = if showVer then fmap packageVersion selectedPkg else Nothing,- selectedAvailable = availableSelected,+ selectedSourcePkg = sourceSelected, installedVersions = map packageVersion installedPkgs,- availableVersions = map packageVersion availablePkgs,+ sourceVersions = map packageVersion sourcePkgs, preferredVersions = versionPref, - license = combine Available.license available+ license = combine Source.license source Installed.license installed,- maintainer = combine Available.maintainer available+ maintainer = combine Source.maintainer source Installed.maintainer installed,- author = combine Available.author available+ author = combine Source.author source Installed.author installed,- homepage = combine Available.homepage available+ homepage = combine Source.homepage source Installed.homepage installed,- bugReports = maybe "" Available.bugReports available,+ bugReports = maybe "" Source.bugReports source, sourceRepo = fromMaybe "" . join- . fmap (uncons Nothing Available.repoLocation- . sortBy (comparing Available.repoKind)- . Available.sourceRepos)- $ available,+ . fmap (uncons Nothing Source.repoLocation+ . sortBy (comparing Source.repoKind)+ . Source.sourceRepos)+ $ source, --TODO: installed package info is missing synopsis- synopsis = maybe "" Available.synopsis available,- description = combine Available.description available+ synopsis = maybe "" Source.synopsis source,+ description = combine Source.description source Installed.description installed,- category = combine Available.category available+ category = combine Source.category source Installed.category installed,- flags = maybe [] Available.genPackageFlags availableGeneric,+ flags = maybe [] Source.genPackageFlags sourceGeneric, hasLib = isJust installed || fromMaybe False- (fmap (isJust . Available.condLibrary) availableGeneric),+ (fmap (isJust . Source.condLibrary) sourceGeneric), hasExe = fromMaybe False- (fmap (not . null . Available.condExecutables) availableGeneric),- executables = map fst (maybe [] Available.condExecutables availableGeneric),+ (fmap (not . null . Source.condExecutables) sourceGeneric),+ executables = map fst (maybe [] Source.condExecutables sourceGeneric), modules = combine Installed.exposedModules installed- (maybe [] Available.exposedModules- . Available.library) available,- dependencies = map simplifyDependency- $ combine Available.buildDepends available- (map thisPackageVersion . depends) installed',+ (maybe [] Source.exposedModules+ . Source.library) source,+ dependencies = combine (map (SourceDependency . simplifyDependency) . Source.buildDepends) source+ (map InstalledDependency . Installed.depends) installed, haddockHtml = fromMaybe "" . join . fmap (listToMaybe . Installed.haddockHTMLs) $ installed,@@ -408,14 +413,14 @@ } where combine f x g y = fromJust (fmap f x `mplus` fmap g y)- installed' = latestWithPref versionPref installedPkgs- installed = fmap (\(InstalledPackage p _) -> p) installed'+ installed :: Maybe Installed.InstalledPackageInfo+ installed = latestWithPref versionPref installedPkgs - availableSelected+ sourceSelected | isJust selectedPkg = selectedPkg- | otherwise = latestWithPref versionPref availablePkgs- availableGeneric = fmap packageDescription availableSelected- available = fmap flattenPackageDescription availableGeneric+ | otherwise = latestWithPref versionPref sourcePkgs+ sourceGeneric = fmap packageDescription sourceSelected+ source = fmap flattenPackageDescription sourceGeneric uncons :: b -> (a -> b) -> [a] -> b uncons z _ [] = z@@ -429,7 +434,7 @@ updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo updateFileSystemPackageDetails pkginfo = do fetched <- maybe (return False) (isFetched . packageSource)- (selectedAvailable pkginfo)+ (selectedSourcePkg pkginfo) docsExist <- doesDirectoryExist (haddockHtml pkginfo) return pkginfo { haveTarball = fetched,@@ -444,20 +449,20 @@ in (withinRange ver pref, ver) --- | Rearrange installed and available packages into groups referring to the+-- | Rearrange installed and source packages into groups referring to the -- same package by name. In the result pairs, the lists are guaranteed to not -- both be empty. ---mergePackages :: [InstalledPackage]- -> [AvailablePackage]+mergePackages :: [Installed.InstalledPackageInfo]+ -> [SourcePackage] -> [( PackageName- , [InstalledPackage]- , [AvailablePackage] )]-mergePackages installed available =+ , [Installed.InstalledPackageInfo]+ , [SourcePackage] )]+mergePackages installedPkgs sourcePkgs = map collect $ mergeBy (\i a -> fst i `compare` fst a)- (groupOn packageName installed)- (groupOn packageName available)+ (groupOn packageName installedPkgs)+ (groupOn packageName sourcePkgs) where collect (OnlyInLeft (name,is) ) = (name, is, []) collect ( InBoth (_,is) (name,as)) = (name, is, as)
Distribution/Client/PackageIndex.hs view
@@ -27,6 +27,8 @@ -- * Queries -- ** Precise lookups+ elemByPackageId,+ elemByPackageName, lookupPackageName, lookupPackageId, lookupDependency,@@ -61,7 +63,7 @@ import Data.Array ((!)) import Data.List (groupBy, sortBy, nub, isInfixOf) import Data.Monoid (Monoid(..))-import Data.Maybe (isNothing, fromMaybe)+import Data.Maybe (isJust, isNothing, fromMaybe) import Distribution.Package ( PackageName(..), PackageIdentifier(..)@@ -76,7 +78,7 @@ -- -- It can be searched effeciently by package name and version. ---newtype Package pkg => PackageIndex pkg = PackageIndex+newtype PackageIndex pkg = PackageIndex -- This index package names to all the package records matching that package -- name case-sensitively. It includes all versions. --@@ -235,6 +237,13 @@ -- -- * Lookups --++elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool+elemByPackageId index = isJust . lookupPackageId index++elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool+elemByPackageName index = not . null . lookupPackageName index+ -- | Does a lookup by package id (name & version). --
Distribution/Client/Setup.hs view
@@ -26,6 +26,7 @@ , reportCommand, ReportFlags(..) , unpackCommand, UnpackFlags(..) , initCommand, IT.InitFlags(..)+ , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) , parsePackageArgs --TODO: stop exporting these:@@ -37,20 +38,23 @@ ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) ) import Distribution.Client.BuildReports.Types ( ReportLevel(..) )+import Distribution.Client.Dependency.Types+ ( PreSolver(..) ) import qualified Distribution.Client.Init.Types as IT ( InitFlags(..), PackageType(..) )+import Distribution.Client.Targets+ ( UserConstraint, readUserConstraint ) import Distribution.Simple.Program ( defaultProgramConfiguration ) import Distribution.Simple.Command hiding (boolOpt)-import qualified Distribution.Simple.Command as Command import qualified Distribution.Simple.Setup as Cabal- ( configureCommand )+ ( configureCommand, sdistCommand, haddockCommand ) import Distribution.Simple.Setup- ( ConfigFlags(..) )+ ( ConfigFlags(..), SDistFlags(..), HaddockFlags(..) ) import Distribution.Simple.Setup- ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe- , optionVerbosity, trueArg, falseArg )+ ( Flag(..), toFlag, fromFlag, flagToMaybe, flagToList+ , optionVerbosity, boolOpt, trueArg, falseArg ) import Distribution.Simple.InstallDirs ( PathTemplate, toPathTemplate, fromPathTemplate ) import Distribution.Version@@ -60,9 +64,9 @@ import Distribution.Text ( Text(parse), display ) import Distribution.ReadE- ( readP_to_E, succeedReadE )+ ( ReadE(..), readP_to_E, succeedReadE ) import qualified Distribution.Compat.ReadP as Parse- ( ReadP, readP_to_S, char, munch1, pfail, (+++) )+ ( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, (+++) ) import Distribution.Verbosity ( Verbosity, normal ) import Distribution.Simple.Utils@@ -70,6 +74,8 @@ import Data.Char ( isSpace, isAlphaNum )+import Data.List+ ( intercalate ) import Data.Maybe ( listToMaybe, maybeToList, fromMaybe ) import Data.Monoid@@ -90,7 +96,7 @@ globalVersion :: Flag Bool, globalNumericVersion :: Flag Bool, globalConfigFile :: Flag FilePath,- globalRemoteRepos :: [RemoteRepo], -- ^Available Hackage servers.+ globalRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers. globalCacheDir :: Flag FilePath, globalLocalRepos :: [FilePath], globalLogsDir :: Flag FilePath,@@ -222,7 +228,6 @@ -- older Cabal does not grok the constraints flag: | otherwise = flags { configConstraints = [] } - -- ------------------------------------------------------------ -- * Config extra flags -- ------------------------------------------------------------@@ -231,17 +236,20 @@ -- data ConfigExFlags = ConfigExFlags { configCabalVersion :: Flag Version,- configPreferences :: [Dependency]+ configExConstraints:: [UserConstraint],+ configPreferences :: [Dependency],+ configSolver :: Flag PreSolver } defaultConfigExFlags :: ConfigExFlags-defaultConfigExFlags = mempty+defaultConfigExFlags = mempty { configSolver = Flag defaultSolver } configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) configureExCommand = configureCommand { commandDefaultFlags = (mempty, defaultConfigExFlags), commandOptions = \showOrParseArgs ->- liftOptions fst setFst (configureOptions showOrParseArgs)+ liftOptions fst setFst (filter ((/="constraint") . optionName) $+ configureOptions showOrParseArgs) ++ liftOptions snd setSnd (configureExOptions showOrParseArgs) } where@@ -257,23 +265,36 @@ (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++) (fmap toFlag parse)) (map display . flagToList))+ , option [] ["constraint"]+ "Specify constraints on a package (version, installed/source, flags)"+ configExConstraints (\v flags -> flags { configExConstraints = v })+ (reqArg "CONSTRAINT"+ (fmap (\x -> [x]) (ReadE readUserConstraint))+ (map display)) , option [] ["preference"] "Specify preferences (soft constraints) on the version of a package" configPreferences (\v flags -> flags { configPreferences = v })- (reqArg "DEPENDENCY"- (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))- (map (\x -> display x)))+ (reqArg "CONSTRAINT"+ (readP_to_E (const "dependency expected")+ (fmap (\x -> [x]) parse))+ (map display))++ , optionSolver configSolver (\v flags -> flags { configSolver = v }) ] instance Monoid ConfigExFlags where mempty = ConfigExFlags { configCabalVersion = mempty,- configPreferences = mempty+ configExConstraints= mempty,+ configPreferences = mempty,+ configSolver = mempty } mappend a b = ConfigExFlags { configCabalVersion = combine configCabalVersion,- configPreferences = combine configPreferences+ configExConstraints= combine configExConstraints,+ configPreferences = combine configPreferences,+ configSolver = combine configSolver } where combine field = field a `mappend` field b @@ -285,6 +306,11 @@ -- fetchOutput :: Flag FilePath, fetchDeps :: Flag Bool, fetchDryRun :: Flag Bool,+ fetchSolver :: Flag PreSolver,+ fetchMaxBackjumps :: Flag Int,+ fetchReorderGoals :: Flag Bool,+ fetchIndependentGoals :: Flag Bool,+ fetchShadowPkgs :: Flag Bool, fetchVerbosity :: Flag Verbosity } @@ -293,6 +319,11 @@ -- fetchOutput = mempty, fetchDeps = toFlag True, fetchDryRun = toFlag False,+ fetchSolver = Flag defaultSolver,+ fetchMaxBackjumps = Flag defaultMaxBackjumps,+ fetchReorderGoals = Flag False,+ fetchIndependentGoals = Flag False,+ fetchShadowPkgs = Flag False, fetchVerbosity = toFlag normal } @@ -303,7 +334,7 @@ commandDescription = Nothing, commandUsage = usagePackages "fetch", commandDefaultFlags = defaultFetchFlags,- commandOptions = \_ -> [+ commandOptions = \ showOrParseArgs -> [ optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v }) -- , option "o" ["output"]@@ -325,7 +356,16 @@ "Do not install anything, only print what would be installed." fetchDryRun (\v flags -> flags { fetchDryRun = v }) trueArg- ]++ ] ++++ optionSolver fetchSolver (\v flags -> flags { fetchSolver = v }) :+ optionSolverFlags showOrParseArgs+ fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v })+ fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v })+ fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })+ fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v })+ } -- ------------------------------------------------------------@@ -342,13 +382,13 @@ commandOptions = \_ -> [optionVerbosity id const] } -upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)+upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) upgradeCommand = configureCommand { commandName = "upgrade", commandSynopsis = "(command disabled, use install instead)", commandDescription = Nothing, commandUsage = usagePackages "upgrade",- commandDefaultFlags = (mempty, mempty, mempty),+ commandDefaultFlags = (mempty, mempty, mempty, mempty), commandOptions = commandOptions installCommand } @@ -557,41 +597,62 @@ -- | Install takes the same flags as configure along with a few extras. -- data InstallFlags = InstallFlags {- installDocumentation:: Flag Bool,- installHaddockIndex :: Flag PathTemplate,- installDryRun :: Flag Bool,- installReinstall :: Flag Bool,- installUpgradeDeps :: Flag Bool,- installOnly :: Flag Bool,- installOnlyDeps :: Flag Bool,- installRootCmd :: Flag String,- installSummaryFile :: [PathTemplate],- installLogFile :: Flag PathTemplate,- installBuildReports :: Flag ReportLevel,- installSymlinkBinDir:: Flag FilePath,- installOneShot :: Flag Bool+ installDocumentation :: Flag Bool,+ installHaddockIndex :: Flag PathTemplate,+ installDryRun :: Flag Bool,+ installMaxBackjumps :: Flag Int,+ installReorderGoals :: Flag Bool,+ installIndependentGoals :: Flag Bool,+ installShadowPkgs :: Flag Bool,+ installReinstall :: Flag Bool,+ installAvoidReinstalls :: Flag Bool,+ installOverrideReinstall :: Flag Bool,+ installUpgradeDeps :: Flag Bool,+ installOnly :: Flag Bool,+ installOnlyDeps :: Flag Bool,+ installRootCmd :: Flag String,+ installSummaryFile :: [PathTemplate],+ installLogFile :: Flag PathTemplate,+ installBuildReports :: Flag ReportLevel,+ installSymlinkBinDir :: Flag FilePath,+ installOneShot :: Flag Bool } defaultInstallFlags :: InstallFlags defaultInstallFlags = InstallFlags {- installDocumentation= Flag False,- installHaddockIndex = Flag docIndexFile,- installDryRun = Flag False,- installReinstall = Flag False,- installUpgradeDeps = Flag False,- installOnly = Flag False,- installOnlyDeps = Flag False,- installRootCmd = mempty,- installSummaryFile = mempty,- installLogFile = mempty,- installBuildReports = Flag NoReports,- installSymlinkBinDir= mempty,- installOneShot = Flag False+ installDocumentation = Flag False,+ installHaddockIndex = Flag docIndexFile,+ installDryRun = Flag False,+ installMaxBackjumps = Flag defaultMaxBackjumps,+ installReorderGoals = Flag False,+ installIndependentGoals= Flag False,+ installShadowPkgs = Flag False,+ installReinstall = Flag False,+ installAvoidReinstalls = Flag False,+ installOverrideReinstall = Flag False,+ installUpgradeDeps = Flag False,+ installOnly = Flag False,+ installOnlyDeps = Flag False,+ installRootCmd = mempty,+ installSummaryFile = mempty,+ installLogFile = mempty,+ installBuildReports = Flag NoReports,+ installSymlinkBinDir = mempty,+ installOneShot = Flag False } where docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html") -installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)+defaultMaxBackjumps :: Int+defaultMaxBackjumps = 200++defaultSolver :: PreSolver+defaultSolver = Choose++allSolvers :: String+allSolvers = intercalate ", " (map display ([minBound .. maxBound] :: [PreSolver]))++installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) installCommand = CommandUI { commandName = "install", commandSynopsis = "Installs a list of packages.",@@ -610,17 +671,38 @@ ++ " Specific version of a package\n" ++ " " ++ pname ++ " install 'foo < 2' " ++ " Constrained package version\n",- commandDefaultFlags = (mempty, mempty, mempty),+ commandDefaultFlags = (mempty, mempty, mempty, mempty), commandOptions = \showOrParseArgs ->- liftOptions get1 set1 (configureOptions showOrParseArgs)+ liftOptions get1 set1 (filter ((/="constraint") . optionName) $+ configureOptions showOrParseArgs) ++ liftOptions get2 set2 (configureExOptions showOrParseArgs) ++ liftOptions get3 set3 (installOptions showOrParseArgs)+ ++ liftOptions get4 set4 (haddockOptions showOrParseArgs) } where- get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)- get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)- get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c)+ get1 (a,_,_,_) = a; set1 a (_,b,c,d) = (a,b,c,d)+ get2 (_,b,_,_) = b; set2 b (a,_,c,d) = (a,b,c,d)+ get3 (_,_,c,_) = c; set3 c (a,b,_,d) = (a,b,c,d)+ get4 (_,_,_,d) = d; set4 d (a,b,c,_) = (a,b,c,d) + haddockOptions showOrParseArgs+ = [ opt { optionName = "haddock-" ++ name,+ optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr+ | descr <- optionDescr opt] }+ | opt <- commandOptions Cabal.haddockCommand showOrParseArgs+ , let name = optionName opt+ , name `elem` ["hoogle", "html", "html-location",+ "executables", "internal", "css",+ "hyperlink-source", "hscolour-css",+ "contents-location"]+ ]++ 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+ fmapOptFlags modify (ChoiceOpt xs) = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs]+ fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w+ installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] installOptions showOrParseArgs = [ option "" ["documentation"]@@ -638,23 +720,38 @@ "Do not install anything, only print what would be installed." installDryRun (\v flags -> flags { installDryRun = v }) trueArg+ ] ++ - , option [] ["reinstall"]+ optionSolverFlags showOrParseArgs+ installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v })+ installReorderGoals (\v flags -> flags { installReorderGoals = v })+ installIndependentGoals (\v flags -> flags { installIndependentGoals = v })+ installShadowPkgs (\v flags -> flags { installShadowPkgs = v }) ++++ [ option [] ["reinstall"] "Install even if it means installing the same version again." installReinstall (\v flags -> flags { installReinstall = v })- trueArg+ (yesNoOpt showOrParseArgs) + , option [] ["avoid-reinstalls"]+ "Do not select versions that would destructively overwrite installed packages."+ installAvoidReinstalls (\v flags -> flags { installAvoidReinstalls = v })+ (yesNoOpt showOrParseArgs)++ , option [] ["force-reinstalls"]+ "Reinstall packages even if they will most likely break other installed packages."+ installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v })+ (yesNoOpt showOrParseArgs)+ , option [] ["upgrade-dependencies"] "Pick the latest version for all dependencies, rather than trying to pick an installed version." installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v })- trueArg-+ (yesNoOpt showOrParseArgs) , option [] ["only-dependencies"] "Install only the dependencies necessary to build the given packages" installOnlyDeps (\v flags -> flags { installOnlyDeps = v })- trueArg-+ (yesNoOpt showOrParseArgs) , option [] ["root-cmd"] "Command used to gain root privileges, when installing with --global."@@ -688,7 +785,7 @@ , option [] ["one-shot"] "Do not record the packages in the world file." installOneShot (\v flags -> flags { installOneShot = v })- trueArg+ (yesNoOpt showOrParseArgs) ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" avoids ParseArgs -> option [] ["only"]@@ -700,34 +797,46 @@ instance Monoid InstallFlags where mempty = InstallFlags {- installDocumentation= mempty,- installHaddockIndex = mempty,- installDryRun = mempty,- installReinstall = mempty,- installUpgradeDeps = mempty,- installOnly = mempty,- installOnlyDeps = mempty,- installRootCmd = mempty,- installSummaryFile = mempty,- installLogFile = mempty,- installBuildReports = mempty,- installSymlinkBinDir= mempty,- installOneShot = mempty+ installDocumentation = mempty,+ installHaddockIndex = mempty,+ installDryRun = mempty,+ installReinstall = mempty,+ installAvoidReinstalls = mempty,+ installOverrideReinstall = mempty,+ installMaxBackjumps = mempty,+ installUpgradeDeps = mempty,+ installReorderGoals = mempty,+ installIndependentGoals= mempty,+ installShadowPkgs = mempty,+ installOnly = mempty,+ installOnlyDeps = mempty,+ installRootCmd = mempty,+ installSummaryFile = mempty,+ installLogFile = mempty,+ installBuildReports = mempty,+ installSymlinkBinDir = mempty,+ installOneShot = mempty } mappend a b = InstallFlags {- installDocumentation= combine installDocumentation,- installHaddockIndex = combine installHaddockIndex,- installDryRun = combine installDryRun,- installReinstall = combine installReinstall,- installUpgradeDeps = combine installUpgradeDeps,- installOnly = combine installOnly,- installOnlyDeps = combine installOnlyDeps,- installRootCmd = combine installRootCmd,- installSummaryFile = combine installSummaryFile,- installLogFile = combine installLogFile,- installBuildReports = combine installBuildReports,- installSymlinkBinDir= combine installSymlinkBinDir,- installOneShot = combine installOneShot+ installDocumentation = combine installDocumentation,+ installHaddockIndex = combine installHaddockIndex,+ installDryRun = combine installDryRun,+ installReinstall = combine installReinstall,+ installAvoidReinstalls = combine installAvoidReinstalls,+ installOverrideReinstall = combine installOverrideReinstall,+ installMaxBackjumps = combine installMaxBackjumps,+ installUpgradeDeps = combine installUpgradeDeps,+ installReorderGoals = combine installReorderGoals,+ installIndependentGoals= combine installIndependentGoals,+ installShadowPkgs = combine installShadowPkgs,+ installOnly = combine installOnly,+ installOnlyDeps = combine installOnlyDeps,+ installRootCmd = combine installRootCmd,+ installSummaryFile = combine installSummaryFile,+ installLogFile = combine installLogFile,+ installBuildReports = combine installBuildReports,+ installSymlinkBinDir = combine installSymlinkBinDir,+ installOneShot = combine installOneShot } where combine field = field a `mappend` field b @@ -805,7 +914,7 @@ emptyInitFlags = mempty defaultInitFlags :: IT.InitFlags-defaultInitFlags = emptyInitFlags+defaultInitFlags = emptyInitFlags { IT.initVerbosity = toFlag normal } initCommand :: CommandUI IT.InitFlags initCommand = CommandUI {@@ -939,6 +1048,8 @@ IT.buildTools (\v flags -> flags { IT.buildTools = v }) (reqArg' "TOOL" (Just . (:[])) (fromMaybe []))++ , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v }) ] } where readMaybe s = case reads s of@@ -946,19 +1057,113 @@ _ -> Nothing -- --------------------------------------------------------------- * GetOpt Utils+-- * SDist flags -- ------------------------------------------------------------ -boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a-boolOpt = Command.boolOpt flagToMaybe Flag+-- | Extra flags to @sdist@ beyond runghc Setup sdist+--+data SDistExFlags = SDistExFlags {+ sDistFormat :: Flag ArchiveFormat+ }+ deriving Show -reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->- (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b+data ArchiveFormat = TargzFormat | ZipFormat -- | ...+ deriving (Show, Eq)++defaultSDistExFlags :: SDistExFlags+defaultSDistExFlags = SDistExFlags {+ sDistFormat = Flag TargzFormat+ }++sdistCommand :: CommandUI (SDistFlags, SDistExFlags)+sdistCommand = Cabal.sdistCommand {+ commandDefaultFlags = (commandDefaultFlags Cabal.sdistCommand, defaultSDistExFlags),+ commandOptions = \showOrParseArgs ->+ liftOptions fst setFst (commandOptions Cabal.sdistCommand showOrParseArgs)+ ++ liftOptions snd setSnd sdistExOptions+ }+ where+ setFst a (_,b) = (a,b)+ setSnd b (a,_) = (a,b)++ sdistExOptions =+ [option [] ["archive-format"] "archive-format"+ sDistFormat (\v flags -> flags { sDistFormat = v })+ (choiceOpt+ [ (Flag TargzFormat, ([], ["targz"]),+ "Produce a '.tar.gz' format archive (default and required for uploading to hackage)")+ , (Flag ZipFormat, ([], ["zip"]),+ "Produce a '.zip' format archive")+ ])+ ]++instance Monoid SDistExFlags where+ mempty = SDistExFlags {+ sDistFormat = mempty+ }+ mappend a b = SDistExFlags {+ sDistFormat = combine sDistFormat+ }+ where+ combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * GetOpt Utils+-- ------------------------------------------------------------++reqArgFlag :: ArgPlaceHolder ->+ MkOptDescr (b -> Flag String) (Flag String -> b -> b) b reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList liftOptions :: (b -> a) -> (a -> b -> b) -> [OptionField a] -> [OptionField b] liftOptions get set = map (liftOption get set)++yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> (b -> b)) b+yesNoOpt ShowArgs sf lf = trueArg sf lf+yesNoOpt _ sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf++optionSolver :: (flags -> Flag PreSolver)+ -> (Flag PreSolver -> flags -> flags)+ -> OptionField flags+optionSolver get set =+ option [] ["solver"]+ ("Select dependency solver to use (default: " ++ display defaultSolver ++ "). Choices: " ++ allSolvers ++ ", where 'choose' chooses between 'topdown' and 'modular' based on compiler version.")+ get set+ (reqArg "SOLVER" (readP_to_E (const $ "solver must be one of: " ++ allSolvers)+ (toFlag `fmap` parse))+ (flagToList . fmap display))++optionSolverFlags :: ShowOrParseArgs+ -> (flags -> Flag Int ) -> (Flag Int -> flags -> flags)+ -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags)+ -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags)+ -> (flags -> Flag Bool ) -> (Flag Bool -> flags -> flags)+ -> [OptionField flags]+optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg _getig _setig getsip setsip =+ [ 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+ (reqArg "NUM" (readP_to_E ("Cannot parse number: "++)+ (fmap toFlag (Parse.readS_to_P reads)))+ (map show . flagToList))+ , option [] ["reorder-goals"]+ "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages."+ getrg setrg+ (yesNoOpt showOrParseArgs)+ -- TODO: Disabled for now because it does not work as advertised (yet).+{-+ , option [] ["independent-goals"]+ "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen."+ getig setig+ (yesNoOpt showOrParseArgs)+-}+ , option [] ["shadow-installed-packages"]+ "If multiple package instances of the same version are installed, treat all but one as shadowed."+ getsip setsip+ trueArg+ ]+ usagePackages :: String -> String -> String usagePackages name pname =
Distribution/Client/SetupWrapper.hs view
@@ -34,7 +34,8 @@ , packageVersion, Dependency(..) ) import Distribution.PackageDescription ( GenericPackageDescription(packageDescription)- , PackageDescription(..), specVersion, BuildType(..) )+ , PackageDescription(..), specVersion+ , BuildType(..), knownBuildTypes ) import Distribution.PackageDescription.Parse ( readPackageDescription ) import Distribution.Simple.Configure@@ -50,13 +51,13 @@ ( CommandUI(..), commandShowOptions ) import Distribution.Simple.GHC ( ghcVerbosityOptions )-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (PackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Client.IndexUtils ( getInstalledPackages ) import Distribution.Simple.Utils ( die, debug, info, cabalVersion, findPackageDesc, comparing- , createDirectoryIfMissingVerbose, rewriteFile )+ , createDirectoryIfMissingVerbose, rewriteFile, intercalate ) import Distribution.Client.Utils ( moreRecentFile, inDir ) import Distribution.Text@@ -78,7 +79,7 @@ useCabalVersion :: VersionRange, useCompiler :: Maybe Compiler, usePackageDB :: PackageDBStack,- usePackageIndex :: Maybe (PackageIndex InstalledPackage),+ usePackageIndex :: Maybe PackageIndex, useProgramConfig :: ProgramConfiguration, useDistPref :: FilePath, useLoggingHandle :: Maybe Handle,@@ -116,12 +117,18 @@ mkArgs cabalLibVersion = commandName cmd : commandShowOptions cmd (flags cabalLibVersion) ++ extraArgs+ checkBuildType buildType' setupMethod verbosity options' (packageId pkg) buildType' mkArgs where getPkg = findPackageDesc (fromMaybe "." (useWorkingDir options)) >>= readPackageDescription verbosity >>= return . packageDescription + checkBuildType (UnknownBuildType name) =+ die $ "The build-type '" ++ name ++ "' is not known. Use one of: "+ ++ intercalate ", " (map display knownBuildTypes) ++ "."+ checkBuildType _ = return ()+ -- | Decide if we're going to be able to do a direct internal call to the -- entry point in the Cabal library or if we're going to have to compile -- and execute an external Setup.hs script.@@ -215,7 +222,7 @@ [] -> die $ "The package requires Cabal library version " ++ display (useCabalVersion options) ++ " but no suitable version is installed."- pkgs -> return $ bestVersion (map packageVersion pkgs)+ pkgs -> return $ bestVersion (map fst pkgs) where bestVersion = maximumBy (comparing preference) preference version = (sameVersion, sameMajorVersion
Distribution/Client/SrcDist.hs view
@@ -4,42 +4,55 @@ module Distribution.Client.SrcDist ( sdist ) where++ import Distribution.Simple.SrcDist- ( printPackageProblems, prepareTree- , prepareSnapshotTree, snapshotPackage )+ ( printPackageProblems, prepareTree, snapshotPackage ) import Distribution.Client.Tar (createTarGzFile) import Distribution.Package- ( Package(..) )+ ( Package(..), packageVersion ) import Distribution.PackageDescription ( PackageDescription ) import Distribution.PackageDescription.Parse ( readPackageDescription ) import Distribution.Simple.Utils- ( defaultPackageDesc, warn, notice, setupMessage- , createDirectoryIfMissingVerbose, withTempDirectory )-import Distribution.Simple.Setup (SDistFlags(..), fromFlag)+ ( defaultPackageDesc, die, warn, notice, setupMessage+ , createDirectoryIfMissingVerbose, withTempDirectory+ , withUTF8FileContents, writeUTF8File )+import Distribution.Client.Setup+ ( SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) )+import Distribution.Simple.Setup+ ( fromFlag, flagToMaybe ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.PreProcess (knownSuffixHandlers) import Distribution.Simple.BuildPaths ( srcPref) import Distribution.Simple.Configure(maybeGetPersistBuildConfig) import Distribution.PackageDescription.Configuration ( flattenPackageDescription )+import Distribution.Simple.Program (requireProgram, simpleProgram, programPath)+import Distribution.Simple.Program.Db (emptyProgramDb) import Distribution.Text ( display )+import Distribution.Version+ ( Version ) import System.Time (getClockTime, toCalendarTime) import System.FilePath ((</>), (<.>))-import Control.Monad (when)+import Control.Monad (when, unless) import Data.Maybe (isNothing)+import Data.Char (toLower)+import Data.List (isPrefixOf)+import System.Directory (doesFileExist, removeFile, canonicalizePath)+import System.Process (runProcess, waitForProcess)+import System.Exit (ExitCode(..)) -- |Create a source distribution.-sdist :: SDistFlags -> IO ()-sdist flags = do+sdist :: SDistFlags -> SDistExFlags -> IO ()+sdist flags exflags = do pkg <- return . flattenPackageDescription =<< readPackageDescription verbosity =<< defaultPackageDesc verbosity mb_lbi <- maybeGetPersistBuildConfig distPref- let tmpTargetDir = srcPref distPref -- do some QA printPackageProblems verbosity pkg@@ -47,34 +60,101 @@ when (isNothing mb_lbi) $ warn verbosity "Cannot run preprocessors. Run 'configure' command first." - createDirectoryIfMissingVerbose verbosity True tmpTargetDir- withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do+ date <- toCalendarTime =<< getClockTime+ let pkg' | snapshot = snapshotPackage date pkg+ | otherwise = pkg - date <- toCalendarTime =<< getClockTime- let pkg' | snapshot = snapshotPackage date pkg- | otherwise = pkg- setupMessage verbosity "Building source dist for" (packageId pkg')+ case flagToMaybe (sDistDirectory flags) of+ Just targetDir -> do+ generateSourceDir targetDir pkg' mb_lbi+ notice verbosity $ "Source directory created: " ++ targetDir - _ <- if snapshot- then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps- else prepareTree verbosity pkg' mb_lbi distPref tmpDir pps- targzFile <- createArchive verbosity pkg' tmpDir distPref- notice verbosity $ "Source tarball created: " ++ targzFile+ Nothing -> do+ createDirectoryIfMissingVerbose verbosity True tmpTargetDir+ withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do+ let targetDir = tmpDir </> tarBallName pkg'+ generateSourceDir targetDir pkg' mb_lbi+ targzFile <- createArchive verbosity format pkg' tmpDir targetPref+ notice verbosity $ "Source tarball created: " ++ targzFile where+ generateSourceDir targetDir pkg' mb_lbi = do++ setupMessage verbosity "Building source dist for" (packageId pkg')+ prepareTree verbosity pkg' mb_lbi distPref targetDir pps+ when snapshot $+ overwriteSnapshotPackageDesc verbosity pkg' targetDir+ verbosity = fromFlag (sDistVerbosity flags) snapshot = fromFlag (sDistSnapshot flags)- distPref = fromFlag (sDistDistPref flags)+ format = fromFlag (sDistFormat exflags) pps = knownSuffixHandlers+ distPref = fromFlag $ sDistDistPref flags+ targetPref = distPref+ tmpTargetDir = srcPref distPref --- |Create an archive from a tree of source files, and clean up the tree.+tarBallName :: PackageDescription -> String+tarBallName = display . packageId++overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity+ -> PackageDescription -- ^info from the cabal file+ -> FilePath -- ^source tree+ -> IO ()+overwriteSnapshotPackageDesc verbosity pkg targetDir = do+ -- We could just writePackageDescription targetDescFile pkg_descr,+ -- but that would lose comments and formatting.+ descFile <- defaultPackageDesc verbosity+ withUTF8FileContents descFile $+ writeUTF8File (targetDir </> descFile)+ . unlines . map (replaceVersion (packageVersion pkg)) . lines++ where+ replaceVersion :: Version -> String -> String+ replaceVersion version line+ | "version:" `isPrefixOf` map toLower line+ = "version: " ++ display version+ | otherwise = line++-- | Create an archive from a tree of source files.+-- createArchive :: Verbosity+ -> ArchiveFormat -> PackageDescription -> FilePath -> FilePath -> IO FilePath-createArchive _verbosity pkg tmpDir targetPref = do- let tarBallName = display (packageId pkg)- tarBallFilePath = targetPref </> tarBallName <.> "tar.gz"- createTarGzFile tarBallFilePath tmpDir tarBallName- return tarBallFilePath+createArchive _verbosity TargzFormat pkg tmpDir targetPref = do+ createTarGzFile tarBallFilePath tmpDir (tarBallName pkg)+ return tarBallFilePath+ where+ tarBallFilePath = targetPref </> tarBallName pkg <.> "tar.gz"++createArchive verbosity ZipFormat pkg tmpDir targetPref = do+ createZipFile verbosity zipFilePath tmpDir (tarBallName pkg)+ return zipFilePath+ where+ zipFilePath = targetPref </> tarBallName pkg <.> "zip"++createZipFile :: Verbosity -> FilePath -> FilePath -> FilePath -> IO ()+createZipFile verbosity zipfile base dir = do+ (zipProg, _) <- requireProgram verbosity zipProgram emptyProgramDb++ -- zip has an annoying habbit of updating the target rather than creating+ -- it from scratch. While that might sound like an optimisation, it doesn't+ -- remove files already in the archive that are no longer present in the+ -- uncompressed tree.+ alreadyExists <- doesFileExist zipfile+ when alreadyExists $ removeFile zipfile++ -- we call zip with a different CWD, so have to make the path absolute+ zipfileAbs <- canonicalizePath zipfile++ --TODO: use runProgramInvocation, but has to be able to set CWD+ hnd <- runProcess (programPath zipProg) ["-q", "-r", zipfileAbs, dir] (Just base)+ Nothing Nothing Nothing Nothing+ exitCode <- waitForProcess hnd+ unless (exitCode == ExitSuccess) $+ die $ "Generating the zip file failed "+ ++ "(zip returned exit code " ++ show exitCode ++ ")"+ where+ zipProgram = simpleProgram "zip"
Distribution/Client/Tar.hs view
@@ -743,7 +743,7 @@ putString n s = take n s ++ fill (n - length s) '\NUL' --TODO: check integer widths, eg for large file sizes-putOct :: Integral a => FieldWidth -> a -> String+putOct :: (Show a, Integral a) => FieldWidth -> a -> String putOct n x = let octStr = take (n-1) $ showOct x "" in fill (n - length octStr - 1) '0'
Distribution/Client/Targets.hs view
@@ -37,6 +37,11 @@ disambiguatePackageTargets, disambiguatePackageName, + -- * User constraints+ UserConstraint(..),+ readUserConstraint,+ userToPackageConstraint+ ) where import Distribution.Package@@ -44,7 +49,7 @@ , PackageIdentifier(..), packageName, packageVersion , Dependency(Dependency) ) import Distribution.Client.Types- ( AvailablePackage(..), PackageLocation(..) )+ ( SourcePackage(..), PackageLocation(..), OptionalStanza(..) ) import Distribution.Client.Dependency.Types ( PackageConstraint(..) ) @@ -55,17 +60,14 @@ import Distribution.Client.FetchUtils import Distribution.PackageDescription- ( GenericPackageDescription )+ ( GenericPackageDescription, FlagName(..), FlagAssignment ) import Distribution.PackageDescription.Parse ( readPackageDescription, parsePackageDescription, ParseResult(..) )-import Distribution.Simple.Setup- ( fromFlag )-import Distribution.Client.Setup- ( GlobalFlags(..) ) import Distribution.Version- ( Version(Version), thisVersion, anyVersion, isAnyVersion )+ ( Version(Version), thisVersion, anyVersion, isAnyVersion+ , VersionRange ) import Distribution.Text- ( Text(parse), display )+ ( Text(..), display ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils ( die, warn, intercalate, findPackageDesc, fromUTF8, lowercase )@@ -84,9 +86,13 @@ import qualified Distribution.Client.GZipUtils as GZipUtils import Control.Monad (liftM) import qualified Distribution.Compat.ReadP as Parse- ( ReadP, readP_to_S, (+++) )+import Distribution.Compat.ReadP+ ( (+++), (<++) )+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint+ ( (<>), (<+>) ) import Data.Char- ( isSpace )+ ( isSpace, isAlphaNum ) import System.FilePath ( takeExtension, dropExtension, takeDirectory, splitPath ) import System.Directory@@ -180,7 +186,7 @@ => PackageSpecifier pkg -> [PackageConstraint] pkgSpecifierConstraints (NamedPackage _ constraints) = constraints pkgSpecifierConstraints (SpecificSourcePackage pkg) =- [PackageVersionConstraint (packageName pkg)+ [PackageConstraintVersion (packageName pkg) (thisVersion (packageVersion pkg))] @@ -269,16 +275,17 @@ && takeExtension (dropExtension f) == ".tar" parseDependencyOrPackageId :: Parse.ReadP r Dependency- parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse+ parseDependencyOrPackageId = parse+ +++ liftM pkgidToDependency parse where pkgidToDependency :: PackageIdentifier -> Dependency pkgidToDependency p = case packageVersion p of Version [] _ -> Dependency (packageName p) anyVersion version -> Dependency (packageName p) (thisVersion version) - readPToMaybe :: Parse.ReadP a a -> String -> Maybe a- readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str- , all isSpace s ]+readPToMaybe :: Parse.ReadP a a -> String -> Maybe a+readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str+ , all isSpace s ] reportUserTargetProblems :: [UserTargetProblem] -> IO ()@@ -341,17 +348,17 @@ -- resolveUserTargets :: Package pkg => Verbosity- -> GlobalFlags+ -> FilePath -> PackageIndex pkg -> [UserTarget]- -> IO [PackageSpecifier AvailablePackage]-resolveUserTargets verbosity globalFlags available userTargets = do+ -> IO [PackageSpecifier SourcePackage]+resolveUserTargets verbosity worldFile available userTargets = do -- given the user targets, get a list of fully or partially resolved -- package references packageTargets <- mapM (readPackageTarget verbosity) =<< mapM (fetchPackageTarget verbosity) . concat- =<< mapM (expandUserTarget globalFlags) userTargets+ =<< mapM (expandUserTarget worldFile) userTargets -- users are allowed to give package names case-insensitively, so we must -- disambiguate named package references@@ -391,13 +398,13 @@ -- | Given a user-specified target, expand it to a bunch of package targets -- (each of which refers to only one package). ---expandUserTarget :: GlobalFlags+expandUserTarget :: FilePath -> UserTarget -> IO [PackageTarget (PackageLocation ())]-expandUserTarget globalFlags userTarget = case userTarget of+expandUserTarget worldFile userTarget = case userTarget of UserTargetNamed (Dependency name vrange) ->- let constraints = [ PackageVersionConstraint name vrange+ let constraints = [ PackageConstraintVersion name vrange | not (isAnyVersion vrange) ] in return [PackageTargetNamedFuzzy name constraints userTarget] @@ -406,9 +413,9 @@ --TODO: should we warn if there are no world targets? return [ PackageTargetNamed name constraints userTarget | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs- , let constraints = [ PackageVersionConstraint name vrange+ , let constraints = [ PackageConstraintVersion name vrange | not (isAnyVersion vrange) ]- ++ [ PackageFlagsConstraint name flags+ ++ [ PackageConstraintFlags name flags | not (null flags) ] ] UserTargetLocalDir dir ->@@ -424,8 +431,6 @@ UserTargetRemoteTarball tarballURL -> return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ]- where- worldFile = fromFlag $ globalWorldFile globalFlags -- ------------------------------------------------------------@@ -452,7 +457,7 @@ -- readPackageTarget :: Verbosity -> PackageTarget (PackageLocation FilePath)- -> IO (PackageTarget AvailablePackage)+ -> IO (PackageTarget SourcePackage) readPackageTarget verbosity target = case target of PackageTargetNamed pkgname constraints userTarget ->@@ -466,7 +471,7 @@ LocalUnpackedPackage dir -> do pkg <- readPackageDescription verbosity =<< findPackageDesc dir return $ PackageTargetLocation $- AvailablePackage {+ SourcePackage { packageInfoId = packageId pkg, packageDescription = pkg, packageSource = fmap Just location@@ -491,7 +496,7 @@ ++ filename ++ " in " ++ tarballFile Just pkg -> return $ PackageTargetLocation $- AvailablePackage {+ SourcePackage { packageInfoId = packageId pkg, packageDescription = pkg, packageSource = fmap Just location@@ -552,14 +557,14 @@ -> [PackageTarget pkg] -> ( [PackageTargetProblem] , [PackageSpecifier pkg] )-disambiguatePackageTargets available availableExtra targets =+disambiguatePackageTargets availablePkgIndex availableExtra targets = partitionEithers (map disambiguatePackageTarget targets) where disambiguatePackageTarget packageTarget = case packageTarget of PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) PackageTargetNamed pkgname constraints userTarget- | null (PackageIndex.lookupPackageName available pkgname)+ | null (PackageIndex.lookupPackageName availablePkgIndex pkgname) -> Left (PackageNameUnknown pkgname userTarget) | otherwise -> Right (NamedPackage pkgname constraints) @@ -569,11 +574,13 @@ pkgname userTarget) Ambiguous pkgnames -> Left (PackageNameAmbigious pkgname pkgnames userTarget)- Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints)+ Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints')+ where+ constraints' = map (renamePackageConstraint pkgname') constraints -- use any extra specific available packages to help us disambiguate packageNameEnv :: PackageNameEnv- packageNameEnv = mappend (indexPackageNameEnv available)+ packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex) (extraPackageNameEnv availableExtra) @@ -605,7 +612,7 @@ "The following 'world' packages will be ignored because " ++ "they refer to packages that cannot be found: " ++ intercalate ", " (map display pkgs) ++ "\n"- ++ "You can surpress this warning by correcting the world file."+ ++ "You can suppress this warning by correcting the world file." where isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False @@ -642,10 +649,10 @@ PackageNameEnv (\name -> lookupA name ++ lookupB name) indexPackageNameEnv :: Package pkg => PackageIndex pkg -> PackageNameEnv-indexPackageNameEnv index = PackageNameEnv pkgNameLookup+indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup where pkgNameLookup (PackageName name) =- map fst (PackageIndex.searchByName index name)+ map fst (PackageIndex.searchByName pkgIndex name) extraPackageNameEnv :: [PackageName] -> PackageNameEnv extraPackageNameEnv names = PackageNameEnv pkgNameLookup@@ -655,3 +662,99 @@ | let lname = lowercase name , PackageName name' <- names , lowercase name' == lname ]+++-- ------------------------------------------------------------+-- * Package constraints+-- ------------------------------------------------------------++data UserConstraint =+ UserConstraintVersion PackageName VersionRange+ | UserConstraintInstalled PackageName+ | UserConstraintSource PackageName+ | UserConstraintFlags PackageName FlagAssignment+ | UserConstraintStanzas PackageName [OptionalStanza]+ deriving (Show,Eq)+++userToPackageConstraint :: UserConstraint -> PackageConstraint+-- At the moment, the types happen to be directly equivalent+userToPackageConstraint uc = case uc of+ UserConstraintVersion name ver -> PackageConstraintVersion name ver+ UserConstraintInstalled name -> PackageConstraintInstalled name+ UserConstraintSource name -> PackageConstraintSource name+ UserConstraintFlags name flags -> PackageConstraintFlags name flags+ UserConstraintStanzas name stanzas -> PackageConstraintStanzas name stanzas++renamePackageConstraint :: PackageName -> PackageConstraint -> PackageConstraint+renamePackageConstraint name pc = case pc of+ PackageConstraintVersion _ ver -> PackageConstraintVersion name ver+ PackageConstraintInstalled _ -> PackageConstraintInstalled name+ PackageConstraintSource _ -> PackageConstraintSource name+ PackageConstraintFlags _ flags -> PackageConstraintFlags name flags+ PackageConstraintStanzas _ stanzas -> PackageConstraintStanzas name stanzas++readUserConstraint :: String -> Either String UserConstraint+readUserConstraint str =+ case readPToMaybe parse str of+ Nothing -> Left msgCannotParse+ Just c -> Right c+ where+ msgCannotParse =+ "expected a package name followed by a constraint, which is "+ ++ "either a version range, 'installed', 'source' or flags"++--FIXME: use Text instance for FlagName and FlagAssignment+instance Text UserConstraint where+ disp (UserConstraintVersion pkgname verrange) = disp pkgname <+> disp verrange+ disp (UserConstraintInstalled pkgname) = disp pkgname <+> Disp.text "installed"+ disp (UserConstraintSource pkgname) = disp pkgname <+> Disp.text "source"+ disp (UserConstraintFlags pkgname flags) = disp pkgname <+> dispFlagAssignment flags+ where+ dispFlagAssignment = Disp.hsep . map dispFlagValue+ dispFlagValue (f, True) = Disp.char '+' <> dispFlagName f+ dispFlagValue (f, False) = Disp.char '-' <> dispFlagName f+ dispFlagName (FlagName f) = Disp.text f++ disp (UserConstraintStanzas pkgname stanzas) = disp pkgname <+> dispStanzas stanzas+ where+ dispStanzas = Disp.hsep . map dispStanza+ dispStanza TestStanzas = Disp.text "test"+ dispStanza BenchStanzas = Disp.text "bench"++ parse = parse >>= parseConstraint+ where+ spaces = Parse.satisfy isSpace >> Parse.skipSpaces++ parseConstraint pkgname =+ (parse >>= return . UserConstraintVersion pkgname)+ +++ (do spaces+ _ <- Parse.string "installed"+ return (UserConstraintInstalled pkgname))+ +++ (do spaces+ _ <- Parse.string "source"+ return (UserConstraintSource pkgname))+ +++ (do spaces+ _ <- Parse.string "test"+ return (UserConstraintStanzas pkgname [TestStanzas]))+ +++ (do spaces+ _ <- Parse.string "bench"+ return (UserConstraintStanzas pkgname [BenchStanzas]))+ <++ (parseFlagAssignment >>= (return . UserConstraintFlags pkgname))++ parseFlagAssignment = Parse.many1 (spaces >> parseFlagValue)+ parseFlagValue =+ (do Parse.optional (Parse.char '+')+ f <- parseFlagName+ return (f, True))+ +++ (do _ <- Parse.char '-'+ f <- parseFlagName+ return (f, False))+ parseFlagName = liftM FlagName ident++ ident :: Parse.ReadP r String+ ident = Parse.munch1 identChar >>= \s -> check s >> return s+ where+ identChar c = isAlphaNum c || c == '_' || c == '-'+ check ('-':_) = Parse.pfail+ check _ = return ()
Distribution/Client/Types.hs view
@@ -18,7 +18,10 @@ import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import Distribution.PackageDescription- ( GenericPackageDescription, FlagAssignment )+ ( Benchmark(..), GenericPackageDescription(..), FlagAssignment+ , TestSuite(..) )+import Distribution.PackageDescription.Configuration+ ( mapTreeData ) import Distribution.Client.PackageIndex ( PackageIndex ) import Distribution.Version@@ -34,8 +37,8 @@ -- | This is the information we get from a @00-index.tar.gz@ hackage index. ---data AvailablePackageDb = AvailablePackageDb {- packageIndex :: PackageIndex AvailablePackage,+data SourcePackageDb = SourcePackageDb {+ packageIndex :: PackageIndex SourcePackage, packagePreferences :: Map PackageName VersionRange } @@ -72,32 +75,52 @@ -- final configure process will be independent of the environment. -- data ConfiguredPackage = ConfiguredPackage- AvailablePackage -- package info, including repo+ SourcePackage -- package info, including repo FlagAssignment -- complete flag assignment for the package+ [OptionalStanza] -- list of enabled optional stanzas for the package [PackageId] -- set of exact dependencies. These must be -- consistent with the 'buildDepends' in the- -- 'PackageDescrption' that you'd get by applying- -- the flag assignment.+ -- 'PackageDescription' that you'd get by applying+ -- the flag assignment and optional stanzas. deriving Show instance Package ConfiguredPackage where- packageId (ConfiguredPackage pkg _ _) = packageId pkg+ packageId (ConfiguredPackage pkg _ _ _) = packageId pkg instance PackageFixedDeps ConfiguredPackage where- depends (ConfiguredPackage _ _ deps) = deps+ depends (ConfiguredPackage _ _ _ deps) = deps --- | We re-use @GenericPackageDescription@ and use the @package-url@--- field to store the tarball URI.-data AvailablePackage = AvailablePackage {+-- | A package description along with the location of the package sources.+--+data SourcePackage = SourcePackage { packageInfoId :: PackageId, packageDescription :: GenericPackageDescription, packageSource :: PackageLocation (Maybe FilePath) } deriving Show -instance Package AvailablePackage where packageId = packageInfoId+instance Package SourcePackage where packageId = packageInfoId +data OptionalStanza+ = TestStanzas+ | BenchStanzas+ deriving (Eq, Ord, Show)++enableStanzas+ :: [OptionalStanza]+ -> GenericPackageDescription+ -> GenericPackageDescription+enableStanzas stanzas gpkg = gpkg+ { condBenchmarks = flagBenchmarks $ condBenchmarks gpkg+ , condTestSuites = flagTests $ condTestSuites gpkg+ }+ where+ enableTest t = t { testEnabled = TestStanzas `elem` stanzas }+ enableBenchmark bm = bm { benchmarkEnabled = BenchStanzas `elem` stanzas }+ flagBenchmarks = map (\(n, bm) -> (n, mapTreeData enableBenchmark bm))+ flagTests = map (\(n, t) -> (n, mapTreeData enableTest t))+ -- ------------------------------------------------------------ -- * Package locations and repositories -- ------------------------------------------------------------@@ -156,8 +179,9 @@ | UnpackFailed SomeException | ConfigureFailed SomeException | BuildFailed SomeException+ | TestsFailed SomeException | InstallFailed SomeException data BuildSuccess = BuildOk DocsResult TestsResult data DocsResult = DocsNotTried | DocsFailed | DocsOk-data TestsResult = TestsNotTried | TestsFailed | TestsOk+data TestsResult = TestsNotTried | TestsOk
Distribution/Client/Unpack.hs view
@@ -21,7 +21,7 @@ import Distribution.Package ( PackageId, packageId ) import Distribution.Simple.Setup- ( fromFlagOrDefault )+ ( fromFlag, fromFlagOrDefault ) import Distribution.Simple.Utils ( notice, die ) import Distribution.Verbosity@@ -36,7 +36,7 @@ import Distribution.Client.FetchUtils import qualified Distribution.Client.Tar as Tar (extractTarGzFile) import Distribution.Client.IndexUtils as IndexUtils- ( getAvailablePackages )+ ( getSourcePackages ) import System.Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )@@ -60,14 +60,16 @@ unpack verbosity repos globalFlags unpackFlags userTargets = do mapM_ checkTarget userTargets - availableDb <- getAvailablePackages verbosity repos+ sourcePkgDb <- getSourcePackages verbosity repos pkgSpecifiers <- resolveUserTargets verbosity- globalFlags (packageIndex availableDb) userTargets+ (fromFlag $ globalWorldFile globalFlags)+ (packageIndex sourcePkgDb)+ userTargets pkgs <- either (die . unlines . map show) return $ resolveWithoutDependencies- (resolverParams availableDb pkgSpecifiers)+ (resolverParams sourcePkgDb pkgSpecifiers) unless (null prefix) $ createDirectoryIfMissing True prefix@@ -89,10 +91,10 @@ error "Distribution.Client.Unpack.unpack: the impossible happened." where- resolverParams availableDb pkgSpecifiers =+ resolverParams sourcePkgDb pkgSpecifiers = --TODO: add commandline constraint and preference args for unpack - standardInstallPolicy mempty availableDb pkgSpecifiers+ standardInstallPolicy mempty sourcePkgDb pkgSpecifiers prefix = fromFlagOrDefault "" (unpackDestDir unpackFlags)
Distribution/Client/Update.hs view
@@ -15,12 +15,12 @@ ) where import Distribution.Client.Types- ( Repo(..), RemoteRepo(..), LocalRepo(..), AvailablePackageDb(..) )+ ( Repo(..), RemoteRepo(..), LocalRepo(..), SourcePackageDb(..) ) import Distribution.Client.FetchUtils ( downloadIndex ) import qualified Distribution.Client.PackageIndex as PackageIndex import Distribution.Client.IndexUtils- ( getAvailablePackages )+ ( getSourcePackages, updateRepoIndexCache ) import qualified Paths_cabal_install_bundle ( version ) @@ -60,17 +60,18 @@ writeFileAtomic (dropExtension indexPath) . BS.Char8.unpack . maybeDecompress =<< BS.readFile indexPath+ updateRepoIndexCache verbosity repo checkForSelfUpgrade :: Verbosity -> [Repo] -> IO () checkForSelfUpgrade verbosity repos = do- AvailablePackageDb available prefs <- getAvailablePackages verbosity repos+ SourcePackageDb sourcePkgIndex prefs <- getSourcePackages verbosity repos let self = PackageName "cabal-install" preferredVersionRange = fromMaybe anyVersion (Map.lookup self prefs) currentVersion = Paths_cabal_install_bundle.version laterPreferredVersions = [ packageVersion pkg- | pkg <- PackageIndex.lookupPackageName available self+ | pkg <- PackageIndex.lookupPackageName sourcePkgIndex self , let version = packageVersion pkg , version > currentVersion , version `withinRange` preferredVersionRange ]@@ -79,3 +80,4 @@ notice verbosity $ "Note: there is a new version of cabal-install available.\n" ++ "To upgrade, run: cabal install cabal-install"+
Distribution/Client/Upload.hs view
@@ -4,7 +4,7 @@ module Distribution.Client.Upload (check, upload, report) where import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..))-import Distribution.Client.HttpUtils (proxy, isOldHackageURI)+import Distribution.Client.HttpUtils (isOldHackageURI, cabalBrowse) import Distribution.Simple.Utils (debug, notice, warn, info) import Distribution.Verbosity (Verbosity)@@ -15,9 +15,8 @@ import qualified Distribution.Client.BuildReports.Upload as BuildReport import Network.Browser- ( BrowserAction, browse, request- , Authority(..), addAuthority, setAuthorityGen- , setOutHandler, setErrHandler, setProxy )+ ( BrowserAction, request+ , Authority(..), addAuthority ) import Network.HTTP ( Header(..), HeaderName(..), findHeader , Request(..), RequestMethod(..), Response(..) )@@ -33,7 +32,7 @@ import System.FilePath ((</>), takeExtension, takeFileName) import qualified System.FilePath.Posix as FilePath.Posix (combine) import System.Directory-import Control.Monad (forM_)+import Control.Monad (forM_, when) --FIXME: how do we find this path for an arbitrary hackage server?@@ -98,16 +97,19 @@ Left remoteRepo -> do dotCabal <- defaultCabalDir let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo- contents <- getDirectoryContents srcDir- forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile ->- do inp <- readFile (srcDir </> logFile)- let (reportStr, buildLog) = read inp :: (String,String)- case BuildReport.parse reportStr of- Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME- Right report' ->- do info verbosity $ "Uploading report for " ++ display (BuildReport.package report')- browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] auth- return ()+ -- We don't want to bomb out just because we haven't built any packages from this repo yet+ srcExists <- doesDirectoryExist srcDir+ when srcExists $ do+ contents <- getDirectoryContents srcDir+ forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile ->+ do inp <- readFile (srcDir </> logFile)+ let (reportStr, buildLog) = read inp :: (String,String)+ case BuildReport.parse reportStr of+ Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME+ Right report' ->+ do info verbosity $ "Uploading report for " ++ display (BuildReport.package report')+ cabalBrowse verbosity auth $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)]+ return () Right{} -> return () where targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given@@ -122,15 +124,8 @@ -> FilePath -> IO () handlePackage verbosity uri auth path = do req <- mkRequest uri path- p <- proxy verbosity debug verbosity $ "\n" ++ show req- (_,resp) <- browse $ do- setProxy p- setErrHandler (warn verbosity . ("http error: "++))- setOutHandler (debug verbosity)- auth- setAuthorityGen (\_ _ -> return Nothing)- request req+ (_,resp) <- cabalBrowse verbosity auth $ request req debug verbosity $ show resp case rspCode resp of (2,0,0) -> do notice verbosity "Ok"
Main.hs view
@@ -16,7 +16,7 @@ import Distribution.Client.Setup ( GlobalFlags(..), globalCommand, globalRepos , ConfigFlags(..)- , ConfigExFlags(..), configureExCommand+ , ConfigExFlags(..), defaultConfigExFlags, configureExCommand , InstallFlags(..), defaultInstallFlags , installCommand, upgradeCommand , FetchFlags(..), fetchCommand@@ -26,7 +26,8 @@ , InfoFlags(..), infoCommand , UploadFlags(..), uploadCommand , ReportFlags(..), reportCommand- , InitFlags, initCommand+ , InitFlags(initVerbosity), initCommand+ , SDistFlags(..), SDistExFlags(..), sdistCommand , reportCommand , unpackCommand, UnpackFlags(..) ) import Distribution.Simple.Setup@@ -36,8 +37,8 @@ , CopyFlags(..), copyCommand , RegisterFlags(..), registerCommand , CleanFlags(..), cleanCommand- , SDistFlags(..), sdistCommand , TestFlags(..), testCommand+ , BenchmarkFlags(..), benchmarkCommand , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) import Distribution.Client.SetupWrapper@@ -150,6 +151,8 @@ regVerbosity regDistPref ,wrapperAction testCommand testVerbosity testDistPref+ ,wrapperAction benchmarkCommand+ benchmarkVerbosity benchmarkDistPref ,upgradeCommand `commandAddAction` upgradeAction ] @@ -184,29 +187,30 @@ (configPackageDB' configFlags') (globalRepos globalFlags') comp conf configFlags' configExFlags' extraArgs -installAction :: (ConfigFlags, ConfigExFlags, InstallFlags)+installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO ()-installAction (configFlags, _, installFlags) _ _globalFlags+installAction (configFlags, _, installFlags, _) _ _globalFlags | fromFlagOrDefault False (installOnly installFlags) = let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) in setupWrapper verbosity defaultSetupScriptOptions Nothing installCommand (const mempty) [] -installAction (configFlags, configExFlags, installFlags)+installAction (configFlags, configExFlags, installFlags, haddockFlags) extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) targets <- readUserTargets verbosity extraArgs config <- loadConfig verbosity (globalConfigFile globalFlags) (configUserInstall configFlags) let configFlags' = savedConfigureFlags config `mappend` configFlags- configExFlags' = savedConfigureExFlags config `mappend` configExFlags+ configExFlags' = defaultConfigExFlags `mappend`+ savedConfigureExFlags config `mappend` configExFlags installFlags' = defaultInstallFlags `mappend` savedInstallFlags config `mappend` installFlags globalFlags' = savedGlobalFlags config `mappend` globalFlags (comp, conf) <- configCompilerAux' configFlags' install verbosity (configPackageDB' configFlags') (globalRepos globalFlags')- comp conf globalFlags' configFlags' configExFlags' installFlags'+ comp conf globalFlags' configFlags' configExFlags' installFlags' haddockFlags targets listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()@@ -250,9 +254,9 @@ let globalFlags' = savedGlobalFlags config `mappend` globalFlags update verbosity (globalRepos globalFlags') -upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags)+upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags) -> [String] -> GlobalFlags -> IO ()-upgradeAction (configFlags, configExFlags, installFlags)+upgradeAction (configFlags, configExFlags, installFlags, haddockFlags) extraArgs globalFlags = do let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) targets <- readUserTargets verbosity extraArgs@@ -266,7 +270,7 @@ (comp, conf) <- configCompilerAux' configFlags' upgrade verbosity (configPackageDB' configFlags') (globalRepos globalFlags')- comp conf globalFlags' configFlags' configExFlags' installFlags'+ comp conf globalFlags' configFlags' configExFlags' installFlags' haddockFlags targets fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO ()@@ -322,11 +326,11 @@ unless allOk exitFailure -sdistAction :: SDistFlags -> [String] -> GlobalFlags -> IO ()-sdistAction sflags extraArgs _globalFlags = do+sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> GlobalFlags -> IO ()+sdistAction (sdistFlags, sdistExFlags) extraArgs _globalFlags = do unless (null extraArgs) $ do die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs- sdist sflags+ sdist sdistFlags sdistExFlags reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO () reportAction reportFlags extraArgs globalFlags = do@@ -355,8 +359,16 @@ targets initAction :: InitFlags -> [String] -> GlobalFlags -> IO ()-initAction flags _extraArgs _globalFlags = do- initCabal flags+initAction initFlags _extraArgs globalFlags = do+ let verbosity = fromFlag (initVerbosity initFlags)+ config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+ let configFlags = savedConfigureFlags config+ (comp, conf) <- configCompilerAux' configFlags+ initCabal verbosity+ (configPackageDB' configFlags)+ comp+ conf+ initFlags -- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. --
cabal-install-bundle.cabal view
@@ -1,5 +1,5 @@ Name: cabal-install-bundle-Version: 0.10.2.1+Version: 0.14.0 Synopsis: The (bundled) command-line interface for Cabal and Hackage. Description: This is cabal-install with bundled dependencies. Easier to bootstrap. License: BSD3@@ -196,7 +196,7 @@ Distribution.Compat.FilePerms Paths_cabal_install_bundle - build-depends: base >= 2 && < 99, Cabal >= 1.10, filepath, time, process, directory, pretty, containers, array, old-time, bytestring, unix+ build-depends: base >= 2 && < 99, Cabal >= 1.14, filepath, time, process, directory, pretty, containers, array, old-time, bytestring, unix extensions: CPP, DeriveDataTypeable, ForeignFunctionInterface, TypeSynonymInstances, ExistentialQuantification, PolymorphicComponents, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, DeriveDataTypeable, FunctionalDependencies