diff --git a/Distribution/Client/BuildReports/Anonymous.hs b/Distribution/Client/BuildReports/Anonymous.hs --- a/Distribution/Client/BuildReports/Anonymous.hs +++ b/Distribution/Client/BuildReports/Anonymous.hs @@ -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 diff --git a/Distribution/Client/BuildReports/Storage.hs b/Distribution/Client/BuildReports/Storage.hs --- a/Distribution/Client/BuildReports/Storage.hs +++ b/Distribution/Client/BuildReports/Storage.hs @@ -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 diff --git a/Distribution/Client/BuildReports/Types.hs b/Distribution/Client/BuildReports/Types.hs --- a/Distribution/Client/BuildReports/Types.hs +++ b/Distribution/Client/BuildReports/Types.hs @@ -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 diff --git a/Distribution/Client/BuildReports/Upload.hs b/Distribution/Client/BuildReports/Upload.hs --- a/Distribution/Client/BuildReports/Upload.hs +++ b/Distribution/Client/BuildReports/Upload.hs @@ -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 diff --git a/Distribution/Client/Config.hs b/Distribution/Client/Config.hs --- a/Distribution/Client/Config.hs +++ b/Distribution/Client/Config.hs @@ -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 = diff --git a/Distribution/Client/Configure.hs b/Distribution/Client/Configure.hs --- a/Distribution/Client/Configure.hs +++ b/Distribution/Client/Configure.hs @@ -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 diff --git a/Distribution/Client/Dependency.hs b/Distribution/Client/Dependency.hs --- a/Distribution/Client/Dependency.hs +++ b/Distribution/Client/Dependency.hs @@ -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 diff --git a/Distribution/Client/Dependency/Modular.hs b/Distribution/Client/Dependency/Modular.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular.hs @@ -0,0 +1,58 @@ +module Distribution.Client.Dependency.Modular + ( modularResolver, SolverConfig(..)) where + +-- Here, we try to map between the external cabal-install solver +-- interface and the internal interface that the solver actually +-- expects. There are a number of type conversions to perform: we +-- have to convert the package indices to the uniform index used +-- by the solver; we also have to convert the initial constraints; +-- and finally, we have to convert back the resulting install +-- plan. + +import Data.Map as M + ( fromListWith ) +import Distribution.Client.Dependency.Modular.Assignment + ( Assignment, toCPs ) +import Distribution.Client.Dependency.Modular.Dependency + ( RevDepMap ) +import Distribution.Client.Dependency.Modular.ConfiguredConversion + ( convCP ) +import Distribution.Client.Dependency.Modular.IndexConversion + ( convPIs ) +import Distribution.Client.Dependency.Modular.Log + ( logToProgress ) +import Distribution.Client.Dependency.Modular.Package + ( PN ) +import Distribution.Client.Dependency.Modular.Solver + ( SolverConfig(..), solve ) +import Distribution.Client.Dependency.Types + ( DependencyResolver, PackageConstraint(..) ) +import Distribution.Client.InstallPlan + ( PlanPackage ) +import Distribution.System + ( Platform(..) ) + +-- | Ties the two worlds together: classic cabal-install vs. the modular +-- solver. Performs the necessary translations before and after. +modularResolver :: SolverConfig -> DependencyResolver +modularResolver sc (Platform arch os) cid iidx sidx pprefs pcs pns = + fmap (uncurry postprocess) $ -- convert install plan + logToProgress (maxBackjumps sc) $ -- convert log format into progress format + solve sc idx pprefs gcs pns + where + -- Indices have to be converted into solver-specific uniform index. + idx = convPIs os arch cid (shadowPkgs sc) iidx sidx + -- Constraints have to be converted into a finite map indexed by PN. + gcs = M.fromListWith (++) (map (\ pc -> (pcName pc, [pc])) pcs) + + -- Results have to be converted into an install plan. + postprocess :: Assignment -> RevDepMap -> [PlanPackage] + postprocess a rdm = map (convCP iidx sidx) (toCPs a rdm) + + -- Helper function to extract the PN from a constraint. + pcName :: PackageConstraint -> PN + pcName (PackageConstraintVersion pn _) = pn + pcName (PackageConstraintInstalled pn ) = pn + pcName (PackageConstraintSource pn ) = pn + pcName (PackageConstraintFlags pn _) = pn + pcName (PackageConstraintStanzas pn _) = pn diff --git a/Distribution/Client/Dependency/Modular/Assignment.hs b/Distribution/Client/Dependency/Modular/Assignment.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Assignment.hs @@ -0,0 +1,146 @@ +module Distribution.Client.Dependency.Modular.Assignment where + +import Control.Applicative +import Control.Monad +import Data.Array as A +import Data.List as L +import Data.Map as M +import Data.Maybe +import Data.Graph +import Prelude hiding (pi) + +import Distribution.PackageDescription (FlagAssignment) -- from Cabal +import Distribution.Client.Types (OptionalStanza) + +import Distribution.Client.Dependency.Modular.Configured +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Index +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Version + +-- | A (partial) package assignment. Qualified package names +-- are associated with instances. +type PAssignment = Map QPN I + +-- | A (partial) package preassignment. Qualified package names +-- are associated with constrained instances. Constrained instances +-- record constraints about the instances that can still be chosen, +-- and in the extreme case fix a concrete instance. +type PPreAssignment = Map QPN (CI QPN) +type FAssignment = Map QFN Bool +type SAssignment = Map QSN Bool + +-- | A (partial) assignment of variables. +data Assignment = A PAssignment FAssignment SAssignment + deriving (Show, Eq) + +-- | A preassignment comprises knowledge about variables, but not +-- necessarily fixed values. +data PreAssignment = PA PPreAssignment FAssignment SAssignment + +-- | Extend a package preassignment. +-- +-- Either returns a witness of the conflict that would arise during the merge, +-- or the successfully extended assignment. +extend :: Var QPN -> PPreAssignment -> [Dep QPN] -> Either (ConflictSet QPN, [Dep QPN]) PPreAssignment +extend var pa qa = foldM (\ a (Dep qpn ci) -> + let ci' = M.findWithDefault (Constrained []) qpn a + in case (\ x -> M.insert qpn x a) <$> merge ci' ci of + Left (c, (d, d')) -> Left (c, L.map (Dep qpn) (simplify (P qpn) d d')) + Right x -> Right x) + pa qa + where + -- We're trying to remove trivial elements of the conflict. If we're just + -- making a choice pkg == instance, and pkg => pkg == instance is a part + -- of the conflict, then this info is clear from the context and does not + -- have to be repeated. + simplify v (Fixed _ (Goal var' _)) c | v == var && var' == var = [c] + simplify v c (Fixed _ (Goal var' _)) | v == var && var' == var = [c] + simplify _ c d = [c, d] + +-- | Delivers an ordered list of fully configured packages. +-- +-- TODO: This function is (sort of) ok. However, there's an open bug +-- w.r.t. unqualification. There might be several different instances +-- of one package version chosen by the solver, which will lead to +-- clashes. +toCPs :: Assignment -> RevDepMap -> [CP QPN] +toCPs (A pa fa sa) rdm = + let + -- get hold of the graph + g :: Graph + vm :: Vertex -> ((), QPN, [QPN]) + cvm :: QPN -> Maybe Vertex + -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub. + (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs)) + (M.toList rdm)) + tg :: Graph + tg = transposeG g + -- Topsort the dependency graph, yielding a list of pkgs in the right order. + -- The graph will still contain all the installed packages, and it might + -- contain duplicates, because several variables might actually resolve to + -- the same package in the presence of qualified package names. + ps :: [PI QPN] + ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $ + topSort g + -- Determine the flags per package, by walking over and regrouping the + -- complete flag assignment by package. + fapp :: Map QPN FlagAssignment + fapp = M.fromListWith (++) $ + L.map (\ ((FN (PI qpn _) fn), b) -> (qpn, [(fn, b)])) $ + M.toList $ + fa + -- Stanzas per package. + sapp :: Map QPN [OptionalStanza] + sapp = M.fromListWith (++) $ + L.map (\ ((SN (PI qpn _) sn), b) -> (qpn, if b then [sn] else [])) $ + M.toList $ + sa + -- Dependencies per package. + depp :: QPN -> [PI QPN] + depp qpn = let v :: Vertex + v = fromJust (cvm qpn) + dvs :: [Vertex] + dvs = tg A.! v + in L.map (\ dv -> case vm dv of (_, x, _) -> PI x (pa M.! x)) dvs + in + L.map (\ pi@(PI qpn _) -> CP pi + (M.findWithDefault [] qpn fapp) + (M.findWithDefault [] qpn sapp) + (depp qpn)) + ps + +-- | Finalize an assignment and a reverse dependency map. +-- +-- This is preliminary, and geared towards output right now. +finalize :: Index -> Assignment -> RevDepMap -> IO () +finalize idx (A pa fa _) rdm = + let + -- get hold of the graph + g :: Graph + vm :: Vertex -> ((), QPN, [QPN]) + (g, vm) = graphFromEdges' (L.map (\ (x, xs) -> ((), x, xs)) (M.toList rdm)) + -- topsort the dependency graph, yielding a list of pkgs in the right order + f :: [PI QPN] + f = L.filter (not . instPI) (L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) (topSort g)) + fapp :: Map QPN [(QFN, Bool)] -- flags per package + fapp = M.fromListWith (++) $ + L.map (\ (qfn@(FN (PI qpn _) _), b) -> (qpn, [(qfn, b)])) $ M.toList $ fa + -- print one instance + ppi pi@(PI qpn _) = showPI pi ++ status pi ++ " " ++ pflags (M.findWithDefault [] qpn fapp) + -- print install status + status :: PI QPN -> String + status (PI (Q _ pn) _) = + case insts of + [] -> " (new)" + vs -> " (" ++ intercalate ", " (L.map showVer vs) ++ ")" + where insts = L.map (\ (I v _) -> v) $ L.filter isInstalled $ + M.keys (M.findWithDefault M.empty pn idx) + isInstalled (I _ (Inst _ )) = True + isInstalled _ = False + -- print flag assignment + pflags = unwords . L.map (uncurry showFBool) + in + -- show packages with associated flag assignments + putStr (unlines (L.map ppi f)) diff --git a/Distribution/Client/Dependency/Modular/Builder.hs b/Distribution/Client/Dependency/Modular/Builder.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Builder.hs @@ -0,0 +1,143 @@ +module Distribution.Client.Dependency.Modular.Builder where + +-- Building the search tree. +-- +-- In this phase, we build a search tree that is too large, i.e, it contains +-- invalid solutions. We keep track of the open goals at each point. We +-- nondeterministically pick an open goal (via a goal choice node), create +-- subtrees according to the index and the available solutions, and extend the +-- set of open goals by superficially looking at the dependencies recorded in +-- the index. +-- +-- For each goal, we keep track of all the *reasons* why it is being +-- introduced. These are for debugging and error messages, mainly. A little bit +-- of care has to be taken due to the way we treat flags. If a package has +-- flag-guarded dependencies, we cannot introduce them immediately. Instead, we +-- store the entire dependency. + +import Control.Monad.Reader hiding (sequence, mapM) +import Data.List as L +import Data.Map as M +import Prelude hiding (sequence, mapM) + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Index +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.PSQ as P +import Distribution.Client.Dependency.Modular.Tree + +-- | The state needed during the build phase of the search tree. +data BuildState = BS { + index :: Index, -- ^ information about packages and their dependencies + scope :: Scope, -- ^ information about encapsulations + rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies + open :: PSQ OpenGoal (), -- ^ set of still open goals (flag and package goals) + next :: BuildType -- ^ kind of node to generate next +} + +-- | Extend the set of open goals with the new goals listed. +-- +-- We also adjust the map of overall goals, and keep track of the +-- reverse dependencies of each of the goals. +extendOpen :: QPN -> [OpenGoal] -> BuildState -> BuildState +extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs + where + go g o [] = s { rdeps = g, open = o } + go g o (ng@(OpenGoal (Flagged _ _ _ _) _gr) : ngs) = go g (cons ng () o) ngs + go g o (ng@(OpenGoal (Stanza _ _ ) _gr) : ngs) = go g (cons ng () o) ngs + go g o (ng@(OpenGoal (Simple (Dep qpn _)) _gr) : ngs) + | qpn == qpn' = go g o ngs + -- we ignore self-dependencies at this point; TODO: more care may be needed + | qpn `M.member` g = go (M.adjust (qpn':) qpn g) o ngs + | otherwise = go (M.insert qpn [qpn'] g) (cons ng () o) ngs + -- code above is correct; insert/adjust have different arg order + +-- | Update the current scope by taking into account the encapsulations that +-- are defined for the current package. +establishScope :: QPN -> Encaps -> BuildState -> BuildState +establishScope (Q pp pn) ecs s = + s { scope = L.foldl (\ m e -> M.insert e pp' m) (scope s) ecs } + where + pp' = pn : pp -- new path + +-- | Given the current scope, qualify all the package names in the given set of +-- dependencies and then extend the set of open goals accordingly. +scopedExtendOpen :: QPN -> I -> QGoalReasons -> FlaggedDeps PN -> FlagDefaults -> + BuildState -> BuildState +scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s + where + sc = scope s + qfdeps = L.map (fmap (qualify sc)) fdeps -- qualify all the package names + qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs + gs = L.map (flip OpenGoal gr) (qfdeps ++ qfdefs) + +data BuildType = Goals | OneGoal OpenGoal | Instance QPN I PInfo QGoalReasons + +build :: BuildState -> Tree (QGoalReasons, Scope) +build = ana go + where + go :: BuildState -> TreeF (QGoalReasons, Scope) BuildState + + -- If we have a choice between many goals, we just record the choice in + -- the tree. We select each open goal in turn, and before we descend, remove + -- it from the queue of open goals. + go bs@(BS { rdeps = rds, open = gs, next = Goals }) + | P.null gs = DoneF rds + | otherwise = GoalChoiceF (P.mapWithKey (\ g (_sc, gs') -> bs { next = OneGoal g, open = gs' }) + (P.splits gs)) + + -- If we have already picked a goal, then the choice depends on the kind + -- of goal. + -- + -- For a package, we look up the instances available in the global info, + -- and then handle each instance in turn. + go bs@(BS { index = idx, scope = sc, next = OneGoal (OpenGoal (Simple (Dep qpn@(Q _ pn) _)) gr) }) = + case M.lookup pn idx of + Nothing -> FailF (toConflictSet (Goal (P qpn) gr)) (BuildFailureNotInIndex pn) + Just pis -> PChoiceF qpn (gr, sc) (P.fromList (L.map (\ (i, info) -> + (i, bs { next = Instance qpn i info gr })) + (M.toList pis))) + -- TODO: data structure conversion is rather ugly here + + -- For a flag, we create only two subtrees, and we create them in the order + -- that is indicated by the flag default. + -- + -- TODO: Should we include the flag default in the tree? + go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Flagged qfn@(FN (PI qpn _) _) b t f) gr) }) = + FChoiceF qfn (gr, sc) trivial (P.fromList (reorder b + [(True, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn True : gr)) t) bs) { next = Goals }), + (False, (extendOpen qpn (L.map (flip OpenGoal (FDependency qfn False : gr)) f) bs) { next = Goals })])) + where + reorder True = id + reorder False = reverse + trivial = L.null t && L.null f + + go bs@(BS { scope = sc, next = OneGoal (OpenGoal (Stanza qsn@(SN (PI qpn _) _) t) gr) }) = + SChoiceF qsn (gr, sc) trivial (P.fromList + [(False, bs { next = Goals }), + (True, (extendOpen qpn (L.map (flip OpenGoal (SDependency qsn : gr)) t) bs) { next = Goals })]) + where + trivial = L.null t + + -- For a particular instance, we change the state: we update the scope, + -- and furthermore we update the set of goals. + -- + -- TODO: We could inline this above. + go bs@(BS { next = Instance qpn i (PInfo fdeps fdefs ecs _) gr }) = + go ((establishScope qpn ecs + (scopedExtendOpen qpn i (PDependency (PI qpn i) : gr) fdeps fdefs bs)) + { next = Goals }) + +-- | Interface to the tree builder. Just takes an index and a list of package names, +-- and computes the initial state and then the tree from there. +buildTree :: Index -> Bool -> [PN] -> Tree (QGoalReasons, Scope) +buildTree idx ind igs = + build (BS idx sc + (M.fromList (L.map (\ qpn -> (qpn, [])) qpns)) + (P.fromList (L.map (\ qpn -> (OpenGoal (Simple (Dep qpn (Constrained []))) [UserGoal], ())) qpns)) + Goals) + where + sc | ind = makeIndependent igs + | otherwise = emptyScope + qpns = L.map (qualify sc) igs diff --git a/Distribution/Client/Dependency/Modular/Configured.hs b/Distribution/Client/Dependency/Modular/Configured.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Configured.hs @@ -0,0 +1,10 @@ +module Distribution.Client.Dependency.Modular.Configured where + +import Distribution.PackageDescription (FlagAssignment) -- from Cabal +import Distribution.Client.Types (OptionalStanza) + +import Distribution.Client.Dependency.Modular.Package + +-- | A configured package is a package instance together with +-- a flag assignment and complete dependencies. +data CP qpn = CP (PI qpn) FlagAssignment [OptionalStanza] [PI qpn] diff --git a/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs b/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs @@ -0,0 +1,40 @@ +module Distribution.Client.Dependency.Modular.ConfiguredConversion where + +import Data.Maybe +import Prelude hiding (pi) + +import Distribution.Client.InstallPlan +import Distribution.Client.Types +import Distribution.Compiler +import qualified Distribution.Client.PackageIndex as CI +import qualified Distribution.Simple.PackageIndex as SI +import Distribution.System + +import Distribution.Client.Dependency.Modular.Configured +import Distribution.Client.Dependency.Modular.Package + +mkPlan :: Platform -> CompilerId -> + SI.PackageIndex -> CI.PackageIndex SourcePackage -> + [CP QPN] -> Either [PlanProblem] InstallPlan +mkPlan plat comp iidx sidx cps = + new plat comp (CI.fromList (map (convCP iidx sidx) cps)) + +convCP :: SI.PackageIndex -> CI.PackageIndex SourcePackage -> + CP QPN -> PlanPackage +convCP iidx sidx (CP qpi fa es ds) = + case convPI qpi of + Left pi -> PreExisting $ InstalledPackage + (fromJust $ SI.lookupInstalledPackageId iidx pi) + (map convPI' ds) + Right pi -> Configured $ ConfiguredPackage + (fromJust $ CI.lookupPackageId sidx pi) + fa + es + (map convPI' ds) + +convPI :: PI QPN -> Either InstalledPackageId PackageId +convPI (PI _ (I _ (Inst pi))) = Left pi +convPI qpi = Right $ convPI' qpi + +convPI' :: PI QPN -> PackageId +convPI' (PI (Q _ pn) (I v _)) = PackageIdentifier pn v diff --git a/Distribution/Client/Dependency/Modular/Dependency.hs b/Distribution/Client/Dependency/Modular/Dependency.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Dependency.hs @@ -0,0 +1,194 @@ +module Distribution.Client.Dependency.Modular.Dependency where + +import Prelude hiding (pi) + +import Data.List as L +import Data.Map as M +import Data.Set as S + +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Version + +-- | The type of variables that play a role in the solver. +-- Note that the tree currently does not use this type directly, +-- and rather has separate tree nodes for the different types of +-- variables. This fits better with the fact that in most cases, +-- these have to be treated differently. +-- +-- TODO: This isn't the ideal location to declare the type, +-- but we need them for constrained instances. +data Var qpn = P qpn | F (FN qpn) | S (SN qpn) + deriving (Eq, Ord, Show) + +showVar :: Var QPN -> String +showVar (P qpn) = showQPN qpn +showVar (F qfn) = showQFN qfn +showVar (S qsn) = showQSN qsn + +instance Functor Var where + fmap f (P n) = P (f n) + fmap f (F fn) = F (fmap f fn) + fmap f (S sn) = S (fmap f sn) + +type ConflictSet qpn = Set (Var qpn) + +showCS :: ConflictSet QPN -> String +showCS = intercalate ", " . L.map showVar . S.toList + +-- | Constrained instance. If the choice has already been made, this is +-- a fixed instance, and we record the package name for which the choice +-- is for convenience. Otherwise, it is a list of version ranges paired with +-- the goals / variables that introduced them. +data CI qpn = Fixed I (Goal qpn) | Constrained [VROrigin qpn] + deriving (Eq, Show) + +instance Functor CI where + fmap f (Fixed i g) = Fixed i (fmap f g) + fmap f (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, fmap f y)) vrs) + +instance ResetGoal CI where + resetGoal g (Fixed i _) = Fixed i g + resetGoal g (Constrained vrs) = Constrained (L.map (\ (x, y) -> (x, resetGoal g y)) vrs) + +type VROrigin qpn = (VR, Goal qpn) + +-- | Helper function to collapse a list of version ranges with origins into +-- a single, simplified, version range. +collapse :: [VROrigin qpn] -> VR +collapse = simplifyVR . L.foldr (.&&.) anyVR . L.map fst + +showCI :: CI QPN -> String +showCI (Fixed i _) = "==" ++ showI i +showCI (Constrained vr) = showVR (collapse vr) + +-- | Merge constrained instances. We currently adopt a lazy strategy for +-- merging, i.e., we only perform actual checking if one of the two choices +-- is fixed. If the merge fails, we return a conflict set indicating the +-- variables responsible for the failure, as well as the two conflicting +-- fragments. +-- +-- Note that while there may be more than one conflicting pair of version +-- ranges, we only return the first we find. +-- +-- TODO: Different pairs might have different conflict sets. We're +-- obviously interested to return a conflict that has a "better" conflict +-- set in the sense the it contains variables that allow us to backjump +-- further. We might apply some heuristics here, such as to change the +-- order in which we check the constraints. +merge :: Ord qpn => CI qpn -> CI qpn -> Either (ConflictSet qpn, (CI qpn, CI qpn)) (CI qpn) +merge c@(Fixed i g1) d@(Fixed j g2) + | i == j = Right c + | otherwise = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, d)) +merge c@(Fixed (I v _) g1) (Constrained rs) = go rs -- I tried "reverse rs" here, but it seems to slow things down ... + where + go [] = Right c + go (d@(vr, g2) : vrs) + | checkVR vr v = go vrs + | otherwise = Left (S.union (toConflictSet g1) (toConflictSet g2), (c, Constrained [d])) +merge c@(Constrained _) d@(Fixed _ _) = merge d c +merge (Constrained rs) (Constrained ss) = Right (Constrained (rs ++ ss)) + + +type FlaggedDeps qpn = [FlaggedDep qpn] + +-- | Flagged dependencies can either be plain dependency constraints, +-- or flag-dependent dependency trees. +data FlaggedDep qpn = + Flagged (FN qpn) FDefault (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) + | Stanza (SN qpn) (TrueFlaggedDeps qpn) + | Simple (Dep qpn) + deriving (Eq, Show) + +instance Functor FlaggedDep where + fmap f (Flagged x y tt ff) = Flagged (fmap f x) y + (fmap (fmap f) tt) (fmap (fmap f) ff) + fmap f (Stanza x tt) = Stanza (fmap f x) (fmap (fmap f) tt) + fmap f (Simple d) = Simple (fmap f d) + +type TrueFlaggedDeps qpn = FlaggedDeps qpn +type FalseFlaggedDeps qpn = FlaggedDeps qpn + +-- | A dependency (constraint) associates a package name with a +-- constrained instance. +data Dep qpn = Dep qpn (CI qpn) + deriving (Eq, Show) + +showDep :: Dep QPN -> String +showDep (Dep qpn (Fixed i (Goal v _)) ) = + (if P qpn /= v then showVar v ++ " => " else "") ++ + showQPN qpn ++ "==" ++ showI i +showDep (Dep qpn (Constrained [(vr, Goal v _)])) = + showVar v ++ " => " ++ showQPN qpn ++ showVR vr +showDep (Dep qpn ci ) = + showQPN qpn ++ showCI ci + +instance Functor Dep where + fmap f (Dep x y) = Dep (f x) (fmap f y) + +instance ResetGoal Dep where + resetGoal g (Dep qpn ci) = Dep qpn (resetGoal g ci) + +-- | A map containing reverse dependencies between qualified +-- package names. +type RevDepMap = Map QPN [QPN] + +-- | Goals are solver variables paired with information about +-- why they have been introduced. +data Goal qpn = Goal (Var qpn) (GoalReasons qpn) + deriving (Eq, Show) + +instance Functor Goal where + fmap f (Goal v gr) = Goal (fmap f v) (fmap (fmap f) gr) + +class ResetGoal f where + resetGoal :: Goal qpn -> f qpn -> f qpn + +instance ResetGoal Goal where + resetGoal = const + +-- | For open goals as they occur during the build phase, we need to store +-- additional information about flags. +data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasons + deriving (Eq, Show) + +-- | Reasons why a goal can be added to a goal set. +data GoalReason qpn = + UserGoal + | PDependency (PI qpn) + | FDependency (FN qpn) Bool + | SDependency (SN qpn) + deriving (Eq, Show) + +instance Functor GoalReason where + fmap _ UserGoal = UserGoal + fmap f (PDependency pi) = PDependency (fmap f pi) + fmap f (FDependency fn b) = FDependency (fmap f fn) b + fmap f (SDependency sn) = SDependency (fmap f sn) + +-- | The first element is the immediate reason. The rest are the reasons +-- for the reasons ... +type GoalReasons qpn = [GoalReason qpn] + +type QGoalReasons = GoalReasons QPN + +goalReasonToVars :: GoalReason qpn -> ConflictSet qpn +goalReasonToVars UserGoal = S.empty +goalReasonToVars (PDependency (PI qpn _)) = S.singleton (P qpn) +goalReasonToVars (FDependency qfn _) = S.singleton (F qfn) +goalReasonToVars (SDependency qsn) = S.singleton (S qsn) + +goalReasonsToVars :: Ord qpn => GoalReasons qpn -> ConflictSet qpn +goalReasonsToVars = S.unions . L.map goalReasonToVars + +-- | Closes a goal, i.e., removes all the extraneous information that we +-- need only during the build phase. +close :: OpenGoal -> Goal QPN +close (OpenGoal (Simple (Dep qpn _)) gr) = Goal (P qpn) gr +close (OpenGoal (Flagged qfn _ _ _ ) gr) = Goal (F qfn) gr +close (OpenGoal (Stanza qsn _) gr) = Goal (S qsn) gr + +-- | Compute a conflic set from a goal. The conflict set contains the +-- closure of goal reasons as well as the variable of the goal itself. +toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn +toConflictSet (Goal g gr) = S.insert g (goalReasonsToVars gr) diff --git a/Distribution/Client/Dependency/Modular/Explore.hs b/Distribution/Client/Dependency/Modular/Explore.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Explore.hs @@ -0,0 +1,148 @@ +module Distribution.Client.Dependency.Modular.Explore where + +import Control.Applicative as A +import Data.Foldable +import Data.List as L +import Data.Map as M +import Data.Set as S + +import Distribution.Client.Dependency.Modular.Assignment +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Log +import Distribution.Client.Dependency.Modular.Message +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.PSQ as P +import Distribution.Client.Dependency.Modular.Tree + +-- | Backjumping. +-- +-- A tree traversal that tries to propagate conflict sets +-- up the tree from the leaves, and thereby cut branches. +-- All the tricky things are done in the function 'combine'. +backjump :: Tree a -> Tree (Maybe (ConflictSet QPN)) +backjump = snd . cata go + where + go (FailF c fr) = (Just c, Fail c fr) + go (DoneF rdm ) = (Nothing, Done rdm) + go (PChoiceF qpn _ ts) = (c, PChoice qpn c (P.fromList ts')) + where + ~(c, ts') = combine (P qpn) (P.toList ts) S.empty + go (FChoiceF qfn _ b ts) = (c, FChoice qfn c b (P.fromList ts')) + where + ~(c, ts') = combine (F qfn) (P.toList ts) S.empty + go (SChoiceF qsn _ b ts) = (c, SChoice qsn c b (P.fromList ts')) + where + ~(c, ts') = combine (S qsn) (P.toList ts) S.empty + go (GoalChoiceF ts) = (c, GoalChoice (P.fromList ts')) + where + ~(cs, ts') = unzip $ L.map (\ (k, (x, v)) -> (x, (k, v))) $ P.toList ts + c = case cs of [] -> Nothing + d : _ -> d + +-- | The 'combine' function is at the heart of backjumping. It takes +-- the variable we're currently considering, and a list of children +-- annotated with their respective conflict sets, and an accumulator +-- for the result conflict set. It returns a combined conflict set +-- for the parent node, and a (potentially shortened) list of children +-- with the annotations removed. +-- +-- It is *essential* that we produce the results as early as possible. +-- In particular, we have to produce the list of children prior to +-- traversing the entire list -- otherwise we lose the desired behaviour +-- of being able to traverse the tree from left to right incrementally. +-- +-- We can shorten the list of children if we find an individual conflict +-- set that does not contain the current variable. In this case, we can +-- just lift the conflict set to the current level, because the current +-- level cannot possibly have contributed to this conflict, so no other +-- choice at the current level would avoid the conflict. +-- +-- If any of the children might contain a successful solution +-- (indicated by Nothing), then Nothing will be the combined +-- conflict set. If all children contain conflict sets, we can +-- take the union as the combined conflict set. +combine :: Var QPN -> [(a, (Maybe (ConflictSet QPN), b))] -> + ConflictSet QPN -> (Maybe (ConflictSet QPN), [(a, b)]) +combine _ [] c = (Just c, []) +combine var ((k, ( d, v)) : xs) c = (\ ~(e, ys) -> (e, (k, v) : ys)) $ + case d of + Just e | not (var `S.member` e) -> (Just e, []) + | otherwise -> combine var xs (e `S.union` c) + Nothing -> (Nothing, snd $ combine var xs S.empty) + +-- | Naive backtracking exploration of the search tree. This will yield correct +-- assignments only once the tree itself is validated. +explore :: Alternative m => Tree a -> (Assignment -> m (Assignment, RevDepMap)) +explore = cata go + where + go (FailF _ _) _ = A.empty + go (DoneF rdm) a = pure (a, rdm) + go (PChoiceF qpn _ ts) (A pa fa sa) = + asum $ -- try children in order, + P.mapWithKey -- when descending ... + (\ k r -> r (A (M.insert qpn k pa) fa sa)) $ -- record the pkg choice + ts + go (FChoiceF qfn _ _ ts) (A pa fa sa) = + asum $ -- try children in order, + P.mapWithKey -- when descending ... + (\ k r -> r (A pa (M.insert qfn k fa) sa)) $ -- record the flag choice + ts + go (SChoiceF qsn _ _ ts) (A pa fa sa) = + asum $ -- try children in order, + P.mapWithKey -- when descending ... + (\ k r -> r (A pa fa (M.insert qsn k sa))) $ -- record the flag choice + ts + go (GoalChoiceF ts) a = + casePSQ ts A.empty -- empty goal choice is an internal error + (\ _k v _xs -> v a) -- commit to the first goal choice + +-- | Version of 'explore' that returns a 'Log'. +exploreLog :: Tree (Maybe (ConflictSet QPN)) -> (Assignment -> Log Message (Assignment, RevDepMap)) +exploreLog = cata go + where + go (FailF c fr) _ = failWith (Failure c fr) + go (DoneF rdm) a = succeedWith Success (a, rdm) + go (PChoiceF qpn c ts) (A pa fa sa) = + backjumpInfo c $ + asum $ -- try children in order, + P.mapWithKey -- when descending ... + (\ k r -> tryWith (TryP (PI qpn k)) $ -- log and ... + r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice + ts + go (FChoiceF qfn c _ ts) (A pa fa sa) = + backjumpInfo c $ + asum $ -- try children in order, + P.mapWithKey -- when descending ... + (\ k r -> tryWith (TryF qfn k) $ -- log and ... + r (A pa (M.insert qfn k fa) sa)) -- record the pkg choice + ts + go (SChoiceF qsn c _ ts) (A pa fa sa) = + backjumpInfo c $ + asum $ -- try children in order, + P.mapWithKey -- when descending ... + (\ k r -> tryWith (TryS qsn k) $ -- log and ... + r (A pa fa (M.insert qsn k sa))) -- record the pkg choice + ts + go (GoalChoiceF ts) a = + casePSQ ts + (failWith (Failure S.empty EmptyGoalChoice)) -- empty goal choice is an internal error + (\ k v _xs -> continueWith (Next (close k)) (v a)) -- commit to the first goal choice + +-- | Add in information about pruned trees. +-- +-- TODO: This isn't quite optimal, because we do not merely report the shape of the +-- tree, but rather make assumptions about where that shape originated from. It'd be +-- better if the pruning itself would leave information that we could pick up at this +-- point. +backjumpInfo :: Maybe (ConflictSet QPN) -> Log Message a -> Log Message a +backjumpInfo c m = m <|> case c of -- important to produce 'm' before matching on 'c'! + Nothing -> A.empty + Just cs -> failWith (Failure cs Backjump) + +-- | Interface. +exploreTree :: Alternative m => Tree a -> m (Assignment, RevDepMap) +exploreTree t = explore t (A M.empty M.empty M.empty) + +-- | Interface. +exploreTreeLog :: Tree (Maybe (ConflictSet QPN)) -> Log Message (Assignment, RevDepMap) +exploreTreeLog t = exploreLog t (A M.empty M.empty M.empty) diff --git a/Distribution/Client/Dependency/Modular/Flag.hs b/Distribution/Client/Dependency/Modular/Flag.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Flag.hs @@ -0,0 +1,69 @@ +module Distribution.Client.Dependency.Modular.Flag where + +import Data.Map as M +import Prelude hiding (pi) + +import Distribution.PackageDescription hiding (Flag) -- from Cabal + +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Types (OptionalStanza(..)) + +-- | Flag name. Consists of a package instance and the flag identifier itself. +data FN qpn = FN (PI qpn) Flag + deriving (Eq, Ord, Show) + +-- | Extract the package name from a flag name. +getPN :: FN qpn -> qpn +getPN (FN (PI qpn _) _) = qpn + +instance Functor FN where + fmap f (FN x y) = FN (fmap f x) y + +-- | Flag identifier. Just a string. +type Flag = FlagName + +unFlag :: Flag -> String +unFlag (FlagName fn) = fn + +-- | Flag default. Just a bool. +type FDefault = Bool + +-- | Flag defaults. +type FlagDefaults = Map Flag FDefault + +-- | Qualified flag name. +type QFN = FN QPN + +-- | Stanza name. Paired with a package name, much like a flag. +data SN qpn = SN (PI qpn) OptionalStanza + deriving (Eq, Ord, Show) + +instance Functor SN where + fmap f (SN x y) = SN (fmap f x) y + +-- | Qualified stanza name. +type QSN = SN QPN + +unStanza :: OptionalStanza -> String +unStanza TestStanzas = "test" +unStanza BenchStanzas = "bench" + +showQFNBool :: QFN -> Bool -> String +showQFNBool qfn@(FN pi _f) b = showPI pi ++ ":" ++ showFBool qfn b + +showQSNBool :: QSN -> Bool -> String +showQSNBool qsn@(SN pi _f) b = showPI pi ++ ":" ++ showSBool qsn b + +showFBool :: FN qpn -> Bool -> String +showFBool (FN _ f) True = "+" ++ unFlag f +showFBool (FN _ f) False = "-" ++ unFlag f + +showSBool :: SN qpn -> Bool -> String +showSBool (SN _ s) True = "*" ++ unStanza s +showSBool (SN _ s) False = "!" ++ unStanza s + +showQFN :: QFN -> String +showQFN (FN pi f) = showPI pi ++ ":" ++ unFlag f + +showQSN :: QSN -> String +showQSN (SN pi f) = showPI pi ++ ":" ++ unStanza f diff --git a/Distribution/Client/Dependency/Modular/Index.hs b/Distribution/Client/Dependency/Modular/Index.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Index.hs @@ -0,0 +1,33 @@ +module Distribution.Client.Dependency.Modular.Index where + +import Data.List as L +import Data.Map as M +import Prelude hiding (pi) + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Tree + +-- | An index contains information about package instances. This is a nested +-- dictionary. Package names are mapped to instances, which in turn is mapped +-- to info. +type Index = Map PN (Map I PInfo) + +-- | Info associated with a package instance. +-- Currently, dependencies, flags, encapsulations and failure reasons. +-- Packages that have a failure reason recorded for them are disabled +-- globally, for reasons external to the solver. We currently use this +-- for shadowing which essentially is a GHC limitation, and for +-- installed packages that are broken. +data PInfo = PInfo (FlaggedDeps PN) FlagDefaults Encaps (Maybe FailReason) + deriving (Show) + +-- | Encapsulations. A list of package names. +type Encaps = [PN] + +mkIndex :: [(PN, I, PInfo)] -> Index +mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) + +groupMap :: Ord a => [(a, b)] -> Map a [b] +groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs) diff --git a/Distribution/Client/Dependency/Modular/IndexConversion.hs b/Distribution/Client/Dependency/Modular/IndexConversion.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/IndexConversion.hs @@ -0,0 +1,185 @@ +module Distribution.Client.Dependency.Modular.IndexConversion where + +import Data.List as L +import Data.Map as M +import Data.Maybe +import Prelude hiding (pi) + +import qualified Distribution.Client.PackageIndex as CI +import Distribution.Client.Types +import Distribution.Compiler +import Distribution.InstalledPackageInfo as IPI +import Distribution.Package -- from Cabal +import Distribution.PackageDescription as PD -- from Cabal +import qualified Distribution.Simple.PackageIndex as SI +import Distribution.Simple.Utils (equating) +import Distribution.System + +import Distribution.Client.Dependency.Modular.Dependency as D +import Distribution.Client.Dependency.Modular.Flag as F +import Distribution.Client.Dependency.Modular.Index +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Tree +import Distribution.Client.Dependency.Modular.Version + +-- | Convert both the installed package index and the source package +-- index into one uniform solver index. +-- +-- We use 'allPackagesByName' for the installed package index because +-- that returns us several instances of the same package and version +-- in order of preference. This allows us in principle to "shadow" +-- packages if there are several installed packages of the same version. +-- There are currently some shortcomings in both GHC and Cabal in +-- resolving these situations. However, the right thing to do is to +-- fix the problem there, so for now, shadowing is only activated if +-- explicitly requested. +convPIs :: OS -> Arch -> CompilerId -> Bool -> + SI.PackageIndex -> CI.PackageIndex SourcePackage -> Index +convPIs os arch cid sip iidx sidx = + mkIndex (convIPI' sip iidx ++ convSPI' os arch cid sidx) + +-- | Convert a Cabal installed package index to the simpler, +-- more uniform index format of the solver. +convIPI' :: Bool -> SI.PackageIndex -> [(PN, I, PInfo)] +convIPI' sip idx = combine (convIP idx) . versioned . SI.allPackagesByName $ idx + where + -- group installed packages by version + versioned = L.map (groupBy (equating packageVersion)) + -- apply shadowing whenever there are multple installed packages with + -- the same version + combine f pkgs = [ g (f p) | pbn <- pkgs, pbv <- pbn, + (g, p) <- zip (id : repeat shadow) pbv ] + -- shadowing is recorded in the package info + shadow (pn, i, PInfo fdeps fds encs _) | sip = (pn, i, PInfo fdeps fds encs (Just Shadowed)) + shadow x = x + +convIPI :: Bool -> SI.PackageIndex -> Index +convIPI sip = mkIndex . convIPI' sip + +-- | Convert a single installed package into the solver-specific format. +convIP :: SI.PackageIndex -> InstalledPackageInfo -> (PN, I, PInfo) +convIP idx ipi = + let ipid = installedPackageId ipi + i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid) + pn = pkgName (sourcePackageId ipi) + in case mapM (convIPId pn idx) (IPI.depends ipi) of + Nothing -> (pn, i, PInfo [] M.empty [] (Just Broken)) + Just fds -> (pn, i, PInfo fds M.empty [] Nothing) +-- TODO: Installed packages should also store their encapsulations! + +-- | Convert dependencies specified by an installed package id into +-- flagged dependencies of the solver. +-- +-- May return Nothing if the package can't be found in the index. That +-- indicates that the original package having this dependency is broken +-- and should be ignored. +convIPId :: PN -> SI.PackageIndex -> InstalledPackageId -> Maybe (FlaggedDep PN) +convIPId pn' idx ipid = + case SI.lookupInstalledPackageId idx ipid of + Nothing -> Nothing + Just ipi -> let i = I (pkgVersion (sourcePackageId ipi)) (Inst ipid) + pn = pkgName (sourcePackageId ipi) + in Just (D.Simple (Dep pn (Fixed i (Goal (P pn') [])))) + +-- | Convert a cabal-install source package index to the simpler, +-- more uniform index format of the solver. +convSPI' :: OS -> Arch -> CompilerId -> + CI.PackageIndex SourcePackage -> [(PN, I, PInfo)] +convSPI' os arch cid = L.map (convSP os arch cid) . CI.allPackages + +convSPI :: OS -> Arch -> CompilerId -> + CI.PackageIndex SourcePackage -> Index +convSPI os arch cid = mkIndex . convSPI' os arch cid + +-- | Convert a single source package into the solver-specific format. +convSP :: OS -> Arch -> CompilerId -> SourcePackage -> (PN, I, PInfo) +convSP os arch cid (SourcePackage (PackageIdentifier pn pv) gpd _pl) = + let i = I pv InRepo + in (pn, i, convGPD os arch cid (PI pn i) gpd) + +-- We do not use 'flattenPackageDescription' or 'finalizePackageDescription' +-- from 'Distribution.PackageDescription.Configuration' here, because we +-- want to keep the condition tree, but simplify much of the test. + +-- | Convert a generic package description to a solver-specific 'PInfo'. +-- +-- TODO: We currently just take all dependencies from all specified library, +-- executable and test components. This does not quite seem fair. +convGPD :: OS -> Arch -> CompilerId -> + PI PN -> GenericPackageDescription -> PInfo +convGPD os arch cid pi + (GenericPackageDescription _ flags libs exes tests benchs) = + let + fds = flagDefaults flags + in + PInfo + (maybe [] (convCondTree os arch cid pi fds (const True) ) libs ++ + concatMap (convCondTree os arch cid pi fds (const True) . snd) exes ++ + (prefix (Stanza (SN pi TestStanzas)) + (concatMap (convCondTree os arch cid pi fds (const True) . snd) tests)) ++ + (prefix (Stanza (SN pi BenchStanzas)) + (concatMap (convCondTree os arch cid pi fds (const True) . snd) benchs))) + fds + [] -- TODO: add encaps + Nothing + +prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> FlaggedDeps qpn -> FlaggedDeps qpn +prefix _ [] = [] +prefix f fds = [f fds] + +-- | Convert flag information. +flagDefaults :: [PD.Flag] -> FlagDefaults +flagDefaults = M.fromList . L.map (\ (MkFlag fn _ b _) -> (fn, b)) + +-- | Convert condition trees to flagged dependencies. +convCondTree :: OS -> Arch -> CompilerId -> PI PN -> FlagDefaults -> + (a -> Bool) -> -- how to detect if a branch is active + CondTree ConfVar [Dependency] a -> FlaggedDeps PN +convCondTree os arch cid pi@(PI pn _) fds p (CondNode info ds branches) + | p info = L.map (D.Simple . convDep pn) ds -- unconditional dependencies + ++ concatMap (convBranch os arch cid pi fds p) branches + | otherwise = [] + +-- | Branch interpreter. +-- +-- Here, we try to simplify one of Cabal's condition tree branches into the +-- solver's flagged dependency format, which is weaker. Condition trees can +-- contain complex logical expression composed from flag choices and special +-- flags (such as architecture, or compiler flavour). We try to evaluate the +-- special flags and subsequently simplify to a tree that only depends on +-- simple flag choices. +convBranch :: OS -> Arch -> CompilerId -> + PI PN -> FlagDefaults -> + (a -> Bool) -> -- how to detect if a branch is active + (Condition ConfVar, + CondTree ConfVar [Dependency] a, + Maybe (CondTree ConfVar [Dependency] a)) -> FlaggedDeps PN +convBranch os arch cid@(CompilerId cf cv) pi fds p (c', t', mf') = + go c' ( convCondTree os arch cid pi fds p t') + (maybe [] (convCondTree os arch cid pi fds p) mf') + where + go :: Condition ConfVar -> + FlaggedDeps PN -> FlaggedDeps PN -> FlaggedDeps PN + go (Lit True) t _ = t + go (Lit False) _ f = f + go (CNot c) t f = go c f t + go (CAnd c d) t f = go c (go d t f) f + go (COr c d) t f = go c t (go d t f) + go (Var (Flag fn)) t f = [Flagged (FN pi fn) (fds ! fn) t f] + go (Var (OS os')) t f + | os == os' = t + | otherwise = f + go (Var (Arch arch')) t f + | arch == arch' = t + | otherwise = f + go (Var (Impl cf' cvr')) t f + | cf == cf' && checkVR cvr' cv = t + | otherwise = f + +-- | Convert a Cabal dependency to a solver-specific dependency. +convDep :: PN -> Dependency -> Dep PN +convDep pn' (Dependency pn vr) = Dep pn (Constrained [(vr, Goal (P pn') [])]) + +-- | Convert a Cabal package identifier to a solver-specific dependency. +convPI :: PN -> PackageIdentifier -> Dep PN +convPI pn' (PackageIdentifier pn v) = Dep pn (Constrained [(eqVR v, Goal (P pn') [])]) diff --git a/Distribution/Client/Dependency/Modular/Log.hs b/Distribution/Client/Dependency/Modular/Log.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Log.hs @@ -0,0 +1,96 @@ +module Distribution.Client.Dependency.Modular.Log where + +import Control.Applicative +import Data.List as L +import Data.Set as S + +import Distribution.Client.Dependency.Types -- from Cabal + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Message +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Tree (FailReason(..)) + +-- | The 'Log' datatype. +-- +-- Represents the progress of a computation lazily. +-- +-- Parameterized over the type of actual messages and the final result. +type Log m a = Progress m () a + +runLog :: Log m a -> ([m], Maybe a) +runLog (Done x) = ([], Just x) +runLog (Fail _) = ([], Nothing) +runLog (Step m p) = let + (ms, r) = runLog p + in + (m : ms, r) + +-- | Postprocesses a log file. Takes as an argument a limit on allowed backjumps. +-- If the limit is 'Nothing', then infinitely many backjumps are allowed. If the +-- limit is 'Just 0', backtracking is completely disabled. +logToProgress :: Maybe Int -> Log Message a -> Progress String String a +logToProgress mbj l = let + (ms, s) = runLog l + (es, e) = proc 0 ms -- catch first error (always) + (ns, t) = case mbj of + Nothing -> (ms, Nothing) + Just n -> proc n ms + -- prefer first error over later error + r = case t of + Nothing -> case s of + Nothing -> e + Just _ -> Nothing + Just _ -> e + in go es -- trace for first error + (showMessages (const True) True ns) -- shortened run + r s + where + proc :: Int -> [Message] -> ([Message], Maybe (ConflictSet QPN)) + proc _ [] = ([], Nothing) + proc n ( Failure cs Backjump : xs@(Leave : Failure cs' Backjump : _)) + | cs == cs' = proc n xs -- repeated backjumps count as one + proc 0 ( Failure cs Backjump : _ ) = ([], Just cs) + proc n (x@(Failure _ Backjump) : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc (n - 1) xs) + proc n (x : xs) = (\ ~(ys, r) -> (x : ys, r)) (proc n xs) + + -- The order of arguments is important! In particular 's' must not be evaluated + -- unless absolutely necessary. It contains the final result, and if we shortcut + -- with an error due to backjumping, evaluating 's' would still require traversing + -- the entire tree. + go ms (x : xs) r s = Step x (go ms xs r s) + go ms [] (Just cs) _ = Fail ("Could not resolve dependencies:\n" ++ + unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms)) + go _ [] _ (Just s) = Done s + go _ [] _ _ = Fail ("Could not resolve dependencies.") -- should not happen + +logToProgress' :: Log Message a -> Progress String String a +logToProgress' l = let + (ms, r) = runLog l + xs = showMessages (const True) True ms + in go xs r + where + go [x] Nothing = Fail x + go [] Nothing = Fail "" + go [] (Just r) = Done r + go (x:xs) r = Step x (go xs r) + + +runLogIO :: Log Message a -> IO (Maybe a) +runLogIO x = + do + let (ms, r) = runLog x + putStr (unlines $ showMessages (const True) True ms) + return r + +failWith :: m -> Log m a +failWith m = Step m (Fail ()) + +succeedWith :: m -> a -> Log m a +succeedWith m x = Step m (Done x) + +continueWith :: m -> Log m a -> Log m a +continueWith = Step + +tryWith :: Message -> Log Message a -> Log Message a +tryWith m x = Step m (Step Enter x) <|> failWith Leave diff --git a/Distribution/Client/Dependency/Modular/Message.hs b/Distribution/Client/Dependency/Modular/Message.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Message.hs @@ -0,0 +1,97 @@ +module Distribution.Client.Dependency.Modular.Message where + +import qualified Data.List as L +import Prelude hiding (pi) + +import Distribution.Text -- from Cabal + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.Tree + +data Message = + Enter -- ^ increase indentation level + | Leave -- ^ decrease indentation level + | TryP (PI QPN) + | TryF QFN Bool + | TryS QSN Bool + | Next (Goal QPN) + | Success + | Failure (ConflictSet QPN) FailReason + +-- | Transforms the structured message type to actual messages (strings). +-- +-- Takes an additional relevance predicate. The predicate gets a stack of goal +-- variables and can decide whether messages regarding these goals are relevant. +-- You can plug in 'const True' if you're interested in a full trace. If you +-- want a slice of the trace concerning a particular conflict set, then plug in +-- a predicate returning 'True' on the empty stack and if the head is in the +-- conflict set. +-- +-- The second argument indicates if the level numbers should be shown. This is +-- recommended for any trace that involves backtracking, because only the level +-- numbers will allow to keep track of backjumps. +showMessages :: ([Var QPN] -> Bool) -> Bool -> [Message] -> [String] +showMessages p sl = go [] 0 + where + go :: [Var QPN] -> Int -> [Message] -> [String] + go _ _ [] = [] + -- complex patterns + go v l (TryP (PI qpn i) : Enter : Failure c fr : Leave : ms) = goPReject v l qpn [i] c fr ms + go v l (TryF qfn b : Enter : Failure c fr : Leave : ms) = (atLevel (F qfn : v) l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go v l ms) + go v l (TryS qsn b : Enter : Failure c fr : Leave : ms) = (atLevel (S qsn : v) l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go v l ms) + go v l (Next (Goal (P qpn) gr) : TryP pi : ms@(Enter : Next _ : _)) = (atLevel (P qpn : v) l $ "trying: " ++ showPI pi ++ showGRs gr) (go (P qpn : v) l ms) + go v l (Failure c Backjump : ms@(Leave : Failure c' Backjump : _)) | c == c' = go v l ms + -- standard display + go v l (Enter : ms) = go v (l+1) ms + go v l (Leave : ms) = go (drop 1 v) (l-1) ms + go v l (TryP pi@(PI qpn _) : ms) = (atLevel (P qpn : v) l $ "trying: " ++ showPI pi) (go (P qpn : v) l ms) + go v l (TryF qfn b : ms) = (atLevel (F qfn : v) l $ "trying: " ++ showQFNBool qfn b) (go (F qfn : v) l ms) + go v l (TryS qsn b : ms) = (atLevel (S qsn : v) l $ "trying: " ++ showQSNBool qsn b) (go (S qsn : v) l ms) + go v l (Next (Goal (P qpn) gr) : ms) = (atLevel (P qpn : v) l $ "next goal: " ++ showQPN qpn ++ showGRs gr) (go v l ms) + go v l (Next _ : ms) = go v l ms -- ignore flag goals in the log + go v l (Success : ms) = (atLevel v l $ "done") (go v l ms) + go v l (Failure c fr : ms) = (atLevel v l $ "fail" ++ showFR c fr) (go v l ms) + + -- special handler for many subsequent package rejections + goPReject :: [Var QPN] -> Int -> QPN -> [I] -> ConflictSet QPN -> FailReason -> [Message] -> [String] + goPReject v l qpn is c fr (TryP (PI qpn' i) : Enter : Failure _ fr' : Leave : ms) | qpn == qpn' && fr == fr' = goPReject v l qpn (i : is) c fr ms + goPReject v l qpn is c fr ms = (atLevel (P qpn : v) l $ "rejecting: " ++ showQPN qpn ++ "-" ++ L.intercalate ", " (map showI (reverse is)) ++ showFR c fr) (go v l ms) + + -- write a message, but only if it's relevant; we can also enable or disable the display of the current level + atLevel v l x xs + | sl && p v = let s = show l + in ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) : xs + | p v = x : xs + | otherwise = xs + +showGRs :: QGoalReasons -> String +showGRs (gr : _) = showGR gr +showGRs [] = "" + +showGR :: GoalReason QPN -> String +showGR UserGoal = " (user goal)" +showGR (PDependency pi) = " (dependency of " ++ showPI pi ++ ")" +showGR (FDependency qfn b) = " (dependency of " ++ showQFNBool qfn b ++ ")" +showGR (SDependency qsn) = " (dependency of " ++ showQSNBool qsn True ++ ")" + +showFR :: ConflictSet QPN -> FailReason -> String +showFR _ InconsistentInitialConstraints = " (inconsistent initial constraints)" +showFR _ (Conflicting ds) = " (conflict: " ++ L.intercalate ", " (map showDep ds) ++ ")" +showFR _ CannotInstall = " (only already installed instances can be used)" +showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)" +showFR _ Shadowed = " (shadowed by another installed package with same version)" +showFR _ Broken = " (package is broken)" +showFR _ (GlobalConstraintVersion vr) = " (global constraint requires " ++ display vr ++ ")" +showFR _ GlobalConstraintInstalled = " (global constraint requires installed instance)" +showFR _ GlobalConstraintSource = " (global constraint requires source instance)" +showFR _ GlobalConstraintFlag = " (global constraint requires opposite flag selection)" +showFR _ (BuildFailureNotInIndex pn) = " (unknown package: " ++ display pn ++ ")" +showFR c Backjump = " (backjumping, conflict set: " ++ showCS c ++ ")" +-- The following are internal failures. They should not occur. In the +-- interest of not crashing unnecessarily, we still just print an error +-- message though. +showFR _ (MalformedFlagChoice qfn) = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")" +showFR _ (MalformedStanzaChoice qsn) = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")" +showFR _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" diff --git a/Distribution/Client/Dependency/Modular/PSQ.hs b/Distribution/Client/Dependency/Modular/PSQ.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/PSQ.hs @@ -0,0 +1,102 @@ +module Distribution.Client.Dependency.Modular.PSQ where + +-- Priority search queues. +-- +-- I am not yet sure what exactly is needed. But we need a datastructure with +-- key-based lookup that can be sorted. We're using a sequence right now with +-- (inefficiently implemented) lookup, because I think that queue-based +-- opertions and sorting turn out to be more efficiency-critical in practice. + +import Control.Applicative +import Data.Foldable +import Data.Function +import Data.List as S hiding (foldr) +import Data.Traversable +import Prelude hiding (foldr) + +newtype PSQ k v = PSQ [(k, v)] + deriving (Eq, Show) + +instance Functor (PSQ k) where + fmap f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f v)) xs) + +instance Foldable (PSQ k) where + foldr op e (PSQ xs) = foldr op e (fmap snd xs) + +instance Traversable (PSQ k) where + traverse f (PSQ xs) = PSQ <$> traverse (\ (k, v) -> (\ x -> (k, x)) <$> f v) xs + +keys :: PSQ k v -> [k] +keys (PSQ xs) = fmap fst xs + +lookup :: Eq k => k -> PSQ k v -> Maybe v +lookup k (PSQ xs) = S.lookup k xs + +map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2 +map f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f v)) xs) + +mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v +mapKeys f (PSQ xs) = PSQ (fmap (\ (k, v) -> (f k, v)) xs) + +mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b +mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs) + +mapWithKeyState :: (s -> k -> a -> (b, s)) -> PSQ k a -> s -> PSQ k b +mapWithKeyState p (PSQ xs) s0 = + PSQ (foldr (\ (k, v) r s -> case p s k v of + (w, n) -> (k, w) : (r n)) + (const []) xs s0) + +delete :: Eq k => k -> PSQ k a -> PSQ k a +delete k (PSQ xs) = PSQ (snd (partition ((== k) . fst) xs)) + +fromList :: [(k, a)] -> PSQ k a +fromList = PSQ + +cons :: k -> a -> PSQ k a -> PSQ k a +cons k x (PSQ xs) = PSQ ((k, x) : xs) + +snoc :: PSQ k a -> k -> a -> PSQ k a +snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)]) + +casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r +casePSQ (PSQ xs) n c = + case xs of + [] -> n + (k, v) : ys -> c k v (PSQ ys) + +splits :: PSQ k a -> PSQ k (a, PSQ k a) +splits xs = + casePSQ xs + (PSQ []) + (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits ys))) + +sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a +sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs) + +sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a +sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs) + +filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a +filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs) + +filter :: (a -> Bool) -> PSQ k a -> PSQ k a +filter p (PSQ xs) = PSQ (S.filter (p . snd) xs) + +length :: PSQ k a -> Int +length (PSQ xs) = S.length xs + +-- | "Lazy length". +-- +-- Only approximates the length, but doesn't force the list. +llength :: PSQ k a -> Int +llength (PSQ []) = 0 +llength (PSQ (_:[])) = 1 +llength (PSQ (_:_:[])) = 2 +llength (PSQ _) = 3 + +null :: PSQ k a -> Bool +null (PSQ xs) = S.null xs + +toList :: PSQ k a -> [(k, a)] +toList (PSQ xs) = xs diff --git a/Distribution/Client/Dependency/Modular/Package.hs b/Distribution/Client/Dependency/Modular/Package.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Package.hs @@ -0,0 +1,113 @@ +module Distribution.Client.Dependency.Modular.Package + (module Distribution.Client.Dependency.Modular.Package, + module Distribution.Package) where + +import Data.List as L +import Data.Map as M + +import Distribution.Package -- from Cabal +import Distribution.Text -- from Cabal + +import Distribution.Client.Dependency.Modular.Version + +-- | A package name. +type PN = PackageName + +-- | Unpacking a package name. +unPN :: PN -> String +unPN (PackageName pn) = pn + +-- | Package version. A package name plus a version number. +type PV = PackageId + +-- | Qualified package version. +type QPV = Q PV + +-- | Package id. Currently just a black-box string. +type PId = InstalledPackageId + +-- | Location. Info about whether a package is installed or not, and where +-- exactly it is located. For installed packages, uniquely identifies the +-- package instance via its 'PId'. +-- +-- TODO: More information is needed about the repo. +data Loc = Inst PId | InRepo + deriving (Eq, Ord, Show) + +-- | Instance. A version number and a location. +data I = I Ver Loc + deriving (Eq, Ord, Show) + +-- | String representation of an instance. +showI :: I -> String +showI (I v InRepo) = showVer v +showI (I v (Inst (InstalledPackageId i))) = showVer v ++ "/installed" ++ shortId i + where + -- A hack to extract the beginning of the package ABI hash + shortId = snip (splitAt 4) (++ "...") . + snip ((\ (x, y) -> (reverse x, y)) . break (=='-') . reverse) ('-':) + snip p f xs = case p xs of + (ys, zs) -> (if L.null zs then id else f) ys + +-- | Package instance. A package name and an instance. +data PI qpn = PI qpn I + deriving (Eq, Ord, Show) + +-- | String representation of a package instance. +showPI :: PI QPN -> String +showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i + +-- | Checks if a package instance corresponds to an installed package. +instPI :: PI qpn -> Bool +instPI (PI _ (I _ (Inst _))) = True +instPI _ = False + +instI :: I -> Bool +instI (I _ (Inst _)) = True +instI _ = False + +instance Functor PI where + fmap f (PI x y) = PI (f x) y + +-- | Package path. (Stored in "reverse" order.) +type PP = [PN] + +-- | String representation of a package path. +showPP :: PP -> String +showPP = intercalate "." . L.map display . reverse + + +-- | A qualified entity. Pairs a package path with the entity. +data Q a = Q PP a + deriving (Eq, Ord, Show) + +-- | Standard string representation of a qualified entity. +showQ :: (a -> String) -> (Q a -> String) +showQ showa (Q [] x) = showa x +showQ showa (Q pp x) = showPP pp ++ "." ++ showa x + +-- | Qualified package name. +type QPN = Q PN + +-- | String representation of a qualified package path. +showQPN :: QPN -> String +showQPN = showQ display + +-- | The scope associates every package with a path. The convention is that packages +-- not in the data structure have an empty path associated with them. +type Scope = Map PN PP + +-- | An empty scope structure, for initialization. +emptyScope :: Scope +emptyScope = M.empty + +-- | Create artificial parents for each of the package names, making +-- them all independent. +makeIndependent :: [PN] -> Scope +makeIndependent ps = L.foldl (\ sc (n, p) -> M.insert p [PackageName (show n)] sc) emptyScope (zip ([0..] :: [Int]) ps) + +qualify :: Scope -> PN -> QPN +qualify sc pn = Q (findWithDefault [] pn sc) pn + +unQualify :: Q a -> a +unQualify (Q _ x) = x diff --git a/Distribution/Client/Dependency/Modular/Preference.hs b/Distribution/Client/Dependency/Modular/Preference.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Preference.hs @@ -0,0 +1,258 @@ +module Distribution.Client.Dependency.Modular.Preference where + +-- Reordering or pruning the tree in order to prefer or make certain choices. + +import qualified Data.List as L +import qualified Data.Map as M +import Data.Monoid +import Data.Ord + +import Distribution.Client.Dependency.Types + ( PackageConstraint(..), PackagePreferences(..), InstalledPreference(..) ) +import Distribution.Client.Types + ( OptionalStanza(..) ) + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.PSQ as P +import Distribution.Client.Dependency.Modular.Tree +import Distribution.Client.Dependency.Modular.Version + +-- | Generic abstraction for strategies that just rearrange the package order. +-- Only packages that match the given predicate are reordered. +packageOrderFor :: (PN -> Bool) -> (PN -> I -> I -> Ordering) -> Tree a -> Tree a +packageOrderFor p cmp = trav go + where + go (PChoiceF v@(Q _ pn) r cs) + | p pn = PChoiceF v r (P.sortByKeys (flip (cmp pn)) cs) + | otherwise = PChoiceF v r cs + go x = x + +-- | Ordering that treats preferred versions as greater than non-preferred +-- versions. +preferredVersionsOrdering :: VR -> Ver -> Ver -> Ordering +preferredVersionsOrdering vr v1 v2 = + compare (checkVR vr v1) (checkVR vr v2) + +-- | Traversal that tries to establish package preferences (not constraints). +-- Works by reordering choice nodes. +preferPackagePreferences :: (PN -> PackagePreferences) -> Tree a -> Tree a +preferPackagePreferences pcs = packageOrderFor (const True) preference + where + preference pn i1@(I v1 _) i2@(I v2 _) = + let PackagePreferences vr ipref = pcs pn + in preferredVersionsOrdering vr v1 v2 `mappend` -- combines lexically + locationsOrdering ipref i1 i2 + + -- Note that we always rank installed before uninstalled, and later + -- versions before earlier, but we can change the priority of the + -- two orderings. + locationsOrdering PreferInstalled v1 v2 = + preferInstalledOrdering v1 v2 `mappend` preferLatestOrdering v1 v2 + locationsOrdering PreferLatest v1 v2 = + preferLatestOrdering v1 v2 `mappend` preferInstalledOrdering v1 v2 + +-- | Ordering that treats installed instances as greater than uninstalled ones. +preferInstalledOrdering :: I -> I -> Ordering +preferInstalledOrdering (I _ (Inst _)) (I _ (Inst _)) = EQ +preferInstalledOrdering (I _ (Inst _)) _ = GT +preferInstalledOrdering _ (I _ (Inst _)) = LT +preferInstalledOrdering _ _ = EQ + +-- | Compare instances by their version numbers. +preferLatestOrdering :: I -> I -> Ordering +preferLatestOrdering (I v1 _) (I v2 _) = compare v1 v2 + +-- | Helper function that tries to enforce a single package constraint on a +-- given instance for a P-node. Translates the constraint into a +-- tree-transformer that either leaves the subtree untouched, or replaces it +-- with an appropriate failure node. +processPackageConstraintP :: ConflictSet QPN -> I -> PackageConstraint -> Tree a -> Tree a +processPackageConstraintP c (I v _) (PackageConstraintVersion _ vr) r + | checkVR vr v = r + | otherwise = Fail c (GlobalConstraintVersion vr) +processPackageConstraintP c i (PackageConstraintInstalled _) r + | instI i = r + | otherwise = Fail c GlobalConstraintInstalled +processPackageConstraintP c i (PackageConstraintSource _) r + | not (instI i) = r + | otherwise = Fail c GlobalConstraintSource +processPackageConstraintP _ _ _ r = r + +-- | Helper function that tries to enforce a single package constraint on a +-- given flag setting for an F-node. Translates the constraint into a +-- tree-transformer that either leaves the subtree untouched, or replaces it +-- with an appropriate failure node. +processPackageConstraintF :: Flag -> ConflictSet QPN -> Bool -> PackageConstraint -> Tree a -> Tree a +processPackageConstraintF f c b' (PackageConstraintFlags _ fa) r = + case L.lookup f fa of + Nothing -> r + Just b | b == b' -> r + | otherwise -> Fail c GlobalConstraintFlag +processPackageConstraintF _ _ _ _ r = r + +-- | Helper function that tries to enforce a single package constraint on a +-- given flag setting for an F-node. Translates the constraint into a +-- tree-transformer that either leaves the subtree untouched, or replaces it +-- with an appropriate failure node. +processPackageConstraintS :: OptionalStanza -> ConflictSet QPN -> Bool -> PackageConstraint -> Tree a -> Tree a +processPackageConstraintS s c b' (PackageConstraintStanzas _ ss) r = + if not b' && s `elem` ss then Fail c GlobalConstraintFlag + else r +processPackageConstraintS _ _ _ _ r = r + +-- | Traversal that tries to establish various kinds of user constraints. Works +-- by selectively disabling choices that have been ruled out by global user +-- constraints. +enforcePackageConstraints :: M.Map PN [PackageConstraint] -> Tree QGoalReasons -> Tree QGoalReasons +enforcePackageConstraints pcs = trav go + where + go (PChoiceF qpn@(Q _ pn) gr ts) = + let c = toConflictSet (Goal (P qpn) gr) + -- compose the transformation functions for each of the relevant constraint + g = \ i -> foldl (\ h pc -> h . processPackageConstraintP c i pc) id + (M.findWithDefault [] pn pcs) + in PChoiceF qpn gr (P.mapWithKey g ts) + go (FChoiceF qfn@(FN (PI (Q _ pn) _) f) gr tr ts) = + let c = toConflictSet (Goal (F qfn) gr) + -- compose the transformation functions for each of the relevant constraint + g = \ b -> foldl (\ h pc -> h . processPackageConstraintF f c b pc) id + (M.findWithDefault [] pn pcs) + in FChoiceF qfn gr tr (P.mapWithKey g ts) + go (SChoiceF qsn@(SN (PI (Q _ pn) _) f) gr tr ts) = + let c = toConflictSet (Goal (S qsn) gr) + -- compose the transformation functions for each of the relevant constraint + g = \ b -> foldl (\ h pc -> h . processPackageConstraintS f c b pc) id + (M.findWithDefault [] pn pcs) + in SChoiceF qsn gr tr (P.mapWithKey g ts) + go x = x + +-- | Prefer installed packages over non-installed packages, generally. +-- All installed packages or non-installed packages are treated as +-- equivalent. +preferInstalled :: Tree a -> Tree a +preferInstalled = packageOrderFor (const True) (const preferInstalledOrdering) + +-- | Prefer packages with higher version numbers over packages with +-- lower version numbers, for certain packages. +preferLatestFor :: (PN -> Bool) -> Tree a -> Tree a +preferLatestFor p = packageOrderFor p (const preferLatestOrdering) + +-- | Prefer packages with higher version numbers over packages with +-- lower version numbers, for all packages. +preferLatest :: Tree a -> Tree a +preferLatest = preferLatestFor (const True) + +-- | Require installed packages. +requireInstalled :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a) +requireInstalled p = trav go + where + go (PChoiceF v@(Q _ pn) i@(gr, _) cs) + | p pn = PChoiceF v i (P.mapWithKey installed cs) + | otherwise = PChoiceF v i cs + where + installed (I _ (Inst _)) x = x + installed _ _ = Fail (toConflictSet (Goal (P v) gr)) CannotInstall + go x = x + +-- | Avoid reinstalls. +-- +-- This is a tricky strategy. If a package version is installed already and the +-- same version is available from a repo, the repo version will never be chosen. +-- This would result in a reinstall (either destructively, or potentially, +-- shadowing). The old instance won't be visible or even present anymore, but +-- other packages might have depended on it. +-- +-- TODO: It would be better to actually check the reverse dependencies of installed +-- packages. If they're not depended on, then reinstalling should be fine. Even if +-- they are, perhaps this should just result in trying to reinstall those other +-- packages as well. However, doing this all neatly in one pass would require to +-- change the builder, or at least to change the goal set after building. +avoidReinstalls :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a) +avoidReinstalls p = trav go + where + go (PChoiceF qpn@(Q _ pn) i@(gr, _) cs) + | p pn = PChoiceF qpn i disableReinstalls + | otherwise = PChoiceF qpn i cs + where + disableReinstalls = + let installed = [ v | (I v (Inst _), _) <- toList cs ] + in P.mapWithKey (notReinstall installed) cs + + notReinstall vs (I v InRepo) _ + | v `elem` vs = Fail (toConflictSet (Goal (P qpn) gr)) CannotReinstall + notReinstall _ _ x = x + go x = x + +-- | Always choose the first goal in the list next, abandoning all +-- other choices. +-- +-- This is unnecessary for the default search strategy, because +-- it descends only into the first goal choice anyway, +-- but may still make sense to just reduce the tree size a bit. +firstGoal :: Tree a -> Tree a +firstGoal = trav go + where + go (GoalChoiceF xs) = casePSQ xs (GoalChoiceF xs) (\ _ t _ -> out t) + go x = x + -- Note that we keep empty choice nodes, because they mean success. + +-- | Transformation that tries to make a decision on base as early as +-- possible. In nearly all cases, there's a single choice for the base +-- package. Also, fixing base early should lead to better error messages. +preferBaseGoalChoice :: Tree a -> Tree a +preferBaseGoalChoice = trav go + where + go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys preferBase xs) + go x = x + + preferBase :: OpenGoal -> OpenGoal -> Ordering + preferBase (OpenGoal (Simple (Dep (Q [] pn) _)) _) _ | unPN pn == "base" = LT + preferBase _ (OpenGoal (Simple (Dep (Q [] pn) _)) _) | unPN pn == "base" = GT + preferBase _ _ = EQ + +-- | Transformation that sorts choice nodes so that +-- child nodes with a small branching degree are preferred. As a +-- special case, choices with 0 branches will be preferred (as they +-- are immediately considered inconsistent), and choices with 1 +-- branch will also be preferred (as they don't involve choice). +preferEasyGoalChoices :: Tree a -> Tree a +preferEasyGoalChoices = trav go + where + go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing choices) xs) + go x = x + +-- | Transformation that tries to avoid making inconsequential +-- flag choices early. +deferDefaultFlagChoices :: Tree a -> Tree a +deferDefaultFlagChoices = trav go + where + go (GoalChoiceF xs) = GoalChoiceF (P.sortBy defer xs) + go x = x + + defer :: Tree a -> Tree a -> Ordering + defer (FChoice _ _ True _) _ = GT + defer _ (FChoice _ _ True _) = LT + defer _ _ = EQ + +-- | Variant of 'preferEasyGoalChoices'. +-- +-- Only approximates the number of choices in the branches. Less accurate, +-- more efficient. +lpreferEasyGoalChoices :: Tree a -> Tree a +lpreferEasyGoalChoices = trav go + where + go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing lchoices) xs) + go x = x + +-- | Variant of 'preferEasyGoalChoices'. +-- +-- I first thought that using a paramorphism might be faster here, +-- but it doesn't seem to make any difference. +preferEasyGoalChoices' :: Tree a -> Tree a +preferEasyGoalChoices' = para (inn . go) + where + go (GoalChoiceF xs) = GoalChoiceF (P.map fst (P.sortBy (comparing (choices . snd)) xs)) + go x = fmap fst x + diff --git a/Distribution/Client/Dependency/Modular/Solver.hs b/Distribution/Client/Dependency/Modular/Solver.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Solver.hs @@ -0,0 +1,52 @@ +module Distribution.Client.Dependency.Modular.Solver where + +import Data.Map as M + +import Distribution.Client.Dependency.Types + +import Distribution.Client.Dependency.Modular.Assignment +import Distribution.Client.Dependency.Modular.Builder +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Explore +import Distribution.Client.Dependency.Modular.Index +import Distribution.Client.Dependency.Modular.Log +import Distribution.Client.Dependency.Modular.Message +import Distribution.Client.Dependency.Modular.Package +import qualified Distribution.Client.Dependency.Modular.Preference as P +import Distribution.Client.Dependency.Modular.Validate + +-- | Various options for the modular solver. +data SolverConfig = SolverConfig { + preferEasyGoalChoices :: Bool, + independentGoals :: Bool, + avoidReinstalls :: Bool, + shadowPkgs :: Bool, + maxBackjumps :: Maybe Int +} + +solve :: SolverConfig -> -- solver parameters + Index -> -- all available packages as an index + (PN -> PackagePreferences) -> -- preferences + Map PN [PackageConstraint] -> -- global constraints + [PN] -> -- global goals + Log Message (Assignment, RevDepMap) +solve sc idx userPrefs userConstraints userGoals = + explorePhase $ + heuristicsPhase $ + preferencesPhase $ + validationPhase $ + prunePhase $ + buildPhase + where + explorePhase = exploreTreeLog . backjump + heuristicsPhase = if preferEasyGoalChoices sc + then P.preferBaseGoalChoice . P.deferDefaultFlagChoices . P.lpreferEasyGoalChoices + else P.preferBaseGoalChoice + preferencesPhase = P.preferPackagePreferences userPrefs + validationPhase = P.enforcePackageConstraints userConstraints . + validateTree idx + prunePhase = (if avoidReinstalls sc then P.avoidReinstalls (const True) else id) . + -- packages that can never be "upgraded": + P.requireInstalled (`elem` [PackageName "base", + PackageName "ghc-prim"]) + buildPhase = buildTree idx (independentGoals sc) userGoals diff --git a/Distribution/Client/Dependency/Modular/Tree.hs b/Distribution/Client/Dependency/Modular/Tree.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Tree.hs @@ -0,0 +1,146 @@ +module Distribution.Client.Dependency.Modular.Tree where + +import Control.Applicative +import Control.Monad hiding (mapM) +import Data.Foldable +import Data.Traversable +import Prelude hiding (foldr, mapM) + +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.PSQ as P +import Distribution.Client.Dependency.Modular.Version + +-- | Type of the search tree. Inlining the choice nodes for now. +data Tree a = + PChoice QPN a (PSQ I (Tree a)) + | FChoice QFN a Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial + | SChoice QSN a Bool (PSQ Bool (Tree a)) -- Bool indicates whether it's trivial + | GoalChoice (PSQ OpenGoal (Tree a)) -- PSQ should never be empty + | Done RevDepMap + | Fail (ConflictSet QPN) FailReason + deriving (Eq, Show) + -- Above, a choice is called trivial if it clearly does not matter. The + -- special case of triviality we actually consider is if there are no new + -- dependencies introduced by this node. + +instance Functor Tree where + fmap f (PChoice qpn i xs) = PChoice qpn (f i) (fmap (fmap f) xs) + fmap f (FChoice qfn i b xs) = FChoice qfn (f i) b (fmap (fmap f) xs) + fmap f (SChoice qsn i b xs) = SChoice qsn (f i) b (fmap (fmap f) xs) + fmap f (GoalChoice xs) = GoalChoice (fmap (fmap f) xs) + fmap _f (Done rdm ) = Done rdm + fmap _f (Fail cs fr ) = Fail cs fr + +data FailReason = InconsistentInitialConstraints + | Conflicting [Dep QPN] + | CannotInstall + | CannotReinstall + | Shadowed + | Broken + | GlobalConstraintVersion VR + | GlobalConstraintInstalled + | GlobalConstraintSource + | GlobalConstraintFlag + | BuildFailureNotInIndex PN + | MalformedFlagChoice QFN + | MalformedStanzaChoice QSN + | EmptyGoalChoice + | Backjump + deriving (Eq, Show) + +-- | Functor for the tree type. +data TreeF a b = + PChoiceF QPN a (PSQ I b) + | FChoiceF QFN a Bool (PSQ Bool b) + | SChoiceF QSN a Bool (PSQ Bool b) + | GoalChoiceF (PSQ OpenGoal b) + | DoneF RevDepMap + | FailF (ConflictSet QPN) FailReason + +out :: Tree a -> TreeF a (Tree a) +out (PChoice p i ts) = PChoiceF p i ts +out (FChoice p i b ts) = FChoiceF p i b ts +out (SChoice p i b ts) = SChoiceF p i b ts +out (GoalChoice ts) = GoalChoiceF ts +out (Done x ) = DoneF x +out (Fail c x ) = FailF c x + +inn :: TreeF a (Tree a) -> Tree a +inn (PChoiceF p i ts) = PChoice p i ts +inn (FChoiceF p i b ts) = FChoice p i b ts +inn (SChoiceF p i b ts) = SChoice p i b ts +inn (GoalChoiceF ts) = GoalChoice ts +inn (DoneF x ) = Done x +inn (FailF c x ) = Fail c x + +instance Functor (TreeF a) where + fmap f (PChoiceF p i ts) = PChoiceF p i (fmap f ts) + fmap f (FChoiceF p i b ts) = FChoiceF p i b (fmap f ts) + fmap f (SChoiceF p i b ts) = SChoiceF p i b (fmap f ts) + fmap f (GoalChoiceF ts) = GoalChoiceF (fmap f ts) + fmap _ (DoneF x ) = DoneF x + fmap _ (FailF c x ) = FailF c x + +instance Foldable (TreeF a) where + foldr op e (PChoiceF _ _ ts) = foldr op e ts + foldr op e (FChoiceF _ _ _ ts) = foldr op e ts + foldr op e (SChoiceF _ _ _ ts) = foldr op e ts + foldr op e (GoalChoiceF ts) = foldr op e ts + foldr _ e (DoneF _ ) = e + foldr _ e (FailF _ _ ) = e + +instance Traversable (TreeF a) where + traverse f (PChoiceF p i ts) = PChoiceF <$> pure p <*> pure i <*> traverse f ts + traverse f (FChoiceF p i b ts) = FChoiceF <$> pure p <*> pure i <*> pure b <*> traverse f ts + traverse f (SChoiceF p i b ts) = SChoiceF <$> pure p <*> pure i <*> pure b <*> traverse f ts + traverse f (GoalChoiceF ts) = GoalChoiceF <$> traverse f ts + traverse _ (DoneF x ) = DoneF <$> pure x + traverse _ (FailF c x ) = FailF <$> pure c <*> pure x + +-- | Determines whether a tree is active, i.e., isn't a failure node. +active :: Tree a -> Bool +active (Fail _ _) = False +active _ = True + +-- | Determines how many active choices are available in a node. Note that we +-- count goal choices as having one choice, always. +choices :: Tree a -> Int +choices (PChoice _ _ ts) = P.length (P.filter active ts) +choices (FChoice _ _ _ ts) = P.length (P.filter active ts) +choices (SChoice _ _ _ ts) = P.length (P.filter active ts) +choices (GoalChoice _ ) = 1 +choices (Done _ ) = 1 +choices (Fail _ _ ) = 0 + +-- | Variant of 'choices' that only approximates the number of choices, +-- using 'llength'. +lchoices :: Tree a -> Int +lchoices (PChoice _ _ ts) = P.llength (P.filter active ts) +lchoices (FChoice _ _ _ ts) = P.llength (P.filter active ts) +lchoices (SChoice _ _ _ ts) = P.llength (P.filter active ts) +lchoices (GoalChoice _ ) = 1 +lchoices (Done _ ) = 1 +lchoices (Fail _ _ ) = 0 + +-- | Catamorphism on trees. +cata :: (TreeF a b -> b) -> Tree a -> b +cata phi x = (phi . fmap (cata phi) . out) x + +trav :: (TreeF a (Tree b) -> TreeF b (Tree b)) -> Tree a -> Tree b +trav psi x = cata (inn . psi) x + +-- | Paramorphism on trees. +para :: (TreeF a (b, Tree a) -> b) -> Tree a -> b +para phi = phi . fmap (\ x -> (para phi x, x)) . out + +cataM :: Monad m => (TreeF a b -> m b) -> Tree a -> m b +cataM phi = phi <=< mapM (cataM phi) <=< return . out + +-- | Anamorphism on trees. +ana :: (b -> TreeF a b) -> b -> Tree a +ana psi = inn . fmap (ana psi) . psi + +anaM :: Monad m => (b -> m (TreeF a b)) -> b -> m (Tree a) +anaM psi = return . inn <=< mapM (anaM psi) <=< psi diff --git a/Distribution/Client/Dependency/Modular/Validate.hs b/Distribution/Client/Dependency/Modular/Validate.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Validate.hs @@ -0,0 +1,232 @@ +module Distribution.Client.Dependency.Modular.Validate where + +-- Validation of the tree. +-- +-- The task here is to make sure all constraints hold. After validation, any +-- assignment returned by exploration of the tree should be a complete valid +-- assignment, i.e., actually constitute a solution. + +import Control.Applicative +import Control.Monad.Reader hiding (sequence) +import Data.List as L +import Data.Map as M +import Data.Traversable +import Prelude hiding (sequence) + +import Distribution.Client.Dependency.Modular.Assignment +import Distribution.Client.Dependency.Modular.Dependency +import Distribution.Client.Dependency.Modular.Flag +import Distribution.Client.Dependency.Modular.Index +import Distribution.Client.Dependency.Modular.Package +import Distribution.Client.Dependency.Modular.PSQ as P +import Distribution.Client.Dependency.Modular.Tree + +-- In practice, most constraints are implication constraints (IF we have made +-- a number of choices, THEN we also have to ensure that). We call constraints +-- that for which the precondiditions are fulfilled ACTIVE. We maintain a set +-- of currently active constraints that we pass down the node. +-- +-- We aim at detecting inconsistent states as early as possible. +-- +-- Whenever we make a choice, there are two things that need to happen: +-- +-- (1) We must check that the choice is consistent with the currently +-- active constraints. +-- +-- (2) The choice increases the set of active constraints. For the new +-- active constraints, we must check that they are consistent with +-- the current state. +-- +-- We can actually merge (1) and (2) by saying the the current choice is +-- a new active constraint, fixing the choice. +-- +-- If a test fails, we have detected an inconsistent state. We can +-- disable the current subtree and do not have to traverse it any further. +-- +-- We need a good way to represent the current state, i.e., the current +-- set of active constraints. Since the main situation where we have to +-- search in it is (1), it seems best to store the state by package: for +-- every package, we store which versions are still allowed. If for any +-- package, we have inconsistent active constraints, we can also stop. +-- This is a particular way to read task (2): +-- +-- (2, weak) We only check if the new constraints are consistent with +-- the choices we've already made, and add them to the active set. +-- +-- (2, strong) We check if the new constraints are consistent with the +-- choices we've already made, and the constraints we already have. +-- +-- It currently seems as if we're implementing the weak variant. However, +-- when used together with 'preferEasyGoalChoices', we will find an +-- inconsistent state in the very next step. +-- +-- What do we do about flags? +-- +-- Like for packages, we store the flag choices we have already made. +-- Now, regarding (1), we only have to test whether we've decided the +-- current flag before. Regarding (2), the interesting bit is in discovering +-- the new active constraints. To this end, we look up the constraints for +-- the package the flag belongs to, and traverse its flagged dependencies. +-- Wherever we find the flag in question, we start recording dependencies +-- underneath as new active dependencies. If we encounter other flags, we +-- check if we've chosen them already and either proceed or stop. + +-- | The state needed during validation. +data ValidateState = VS { + index :: Index, + saved :: Map QPN (FlaggedDeps QPN), -- saved, scoped, dependencies + pa :: PreAssignment +} + +type Validate = Reader ValidateState + +validate :: Tree (QGoalReasons, Scope) -> Validate (Tree QGoalReasons) +validate = cata go + where + go :: TreeF (QGoalReasons, Scope) (Validate (Tree QGoalReasons)) -> Validate (Tree QGoalReasons) + + go (PChoiceF qpn (gr, sc) ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts) + go (FChoiceF qfn (gr, _sc) b ts) = + do + -- Flag choices may occur repeatedly (because they can introduce new constraints + -- in various places). However, subsequent choices must be consistent. We thereby + -- collapse repeated flag choice nodes. + PA _ pfa _ <- asks pa -- obtain current flag-preassignment + case M.lookup qfn pfa of + Just rb -> -- flag has already been assigned; collapse choice to the correct branch + case P.lookup rb ts of + Just t -> goF qfn gr rb t + Nothing -> return $ Fail (toConflictSet (Goal (F qfn) gr)) (MalformedFlagChoice qfn) + Nothing -> -- flag choice is new, follow both branches + FChoice qfn gr b <$> sequence (P.mapWithKey (goF qfn gr) ts) + go (SChoiceF qsn (gr, _sc) b ts) = + do + -- Optional stanza choices are very similar to flag choices. + PA _ _ psa <- asks pa -- obtain current stanza-preassignment + case M.lookup qsn psa of + Just rb -> -- stanza choice has already been made; collapse choice to the correct branch + case P.lookup rb ts of + Just t -> goS qsn gr rb t + Nothing -> return $ Fail (toConflictSet (Goal (S qsn) gr)) (MalformedStanzaChoice qsn) + Nothing -> -- stanza choice is new, follow both branches + SChoice qsn gr b <$> sequence (P.mapWithKey (goS qsn gr) ts) + + -- We don't need to do anything for goal choices or failure nodes. + go (GoalChoiceF ts) = GoalChoice <$> sequence ts + go (DoneF rdm ) = pure (Done rdm) + go (FailF c fr ) = pure (Fail c fr) + + -- What to do for package nodes ... + goP :: QPN -> QGoalReasons -> Scope -> I -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons) + goP qpn@(Q _pp pn) gr sc i r = do + PA ppa pfa psa <- asks pa -- obtain current preassignment + idx <- asks index -- obtain the index + svd <- asks saved -- obtain saved dependencies + let (PInfo deps _ _ mfr) = idx ! pn ! i -- obtain dependencies and index-dictated exclusions introduced by the choice + let qdeps = L.map (fmap (qualify sc)) deps -- qualify the deps in the current scope + -- the new active constraints are given by the instance we have chosen, + -- plus the dependency information we have for that instance + let goal = Goal (P qpn) gr + let newactives = Dep qpn (Fixed i goal) : L.map (resetGoal goal) (extractDeps pfa psa qdeps) + -- We now try to extend the partial assignment with the new active constraints. + let mnppa = extend (P qpn) ppa newactives + -- In case we continue, we save the scoped dependencies + let nsvd = M.insert qpn qdeps svd + case mfr of + Just fr -> -- The index marks this as an invalid choice. We can stop. + return (Fail (toConflictSet goal) fr) + _ -> case mnppa of + Left (c, d) -> -- We have an inconsistency. We can stop. + return (Fail c (Conflicting d)) + Right nppa -> -- We have an updated partial assignment for the recursive validation. + local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r + + -- What to do for flag nodes ... + goF :: QFN -> QGoalReasons -> Bool -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons) + goF qfn@(FN (PI qpn _i) _f) gr b r = do + PA ppa pfa psa <- asks pa -- obtain current preassignment + svd <- asks saved -- obtain saved dependencies + -- Note that there should be saved dependencies for the package in question, + -- because while building, we do not choose flags before we see the packages + -- that define them. + let qdeps = svd ! qpn + -- We take the *saved* dependencies, because these have been qualified in the + -- correct scope. + -- + -- Extend the flag assignment + let npfa = M.insert qfn b pfa + -- We now try to get the new active dependencies we might learn about because + -- we have chosen a new flag. + let newactives = extractNewDeps (F qfn) gr b npfa psa qdeps + -- As in the package case, we try to extend the partial assignment. + case extend (F qfn) ppa newactives of + Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found + Right nppa -> local (\ s -> s { pa = PA nppa npfa psa }) r + + -- What to do for stanza nodes (similar to flag nodes) ... + goS :: QSN -> QGoalReasons -> Bool -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons) + goS qsn@(SN (PI qpn _i) _f) gr b r = do + PA ppa pfa psa <- asks pa -- obtain current preassignment + svd <- asks saved -- obtain saved dependencies + -- Note that there should be saved dependencies for the package in question, + -- because while building, we do not choose flags before we see the packages + -- that define them. + let qdeps = svd ! qpn + -- We take the *saved* dependencies, because these have been qualified in the + -- correct scope. + -- + -- Extend the flag assignment + let npsa = M.insert qsn b psa + -- We now try to get the new active dependencies we might learn about because + -- we have chosen a new flag. + let newactives = extractNewDeps (S qsn) gr b pfa npsa qdeps + -- As in the package case, we try to extend the partial assignment. + case extend (S qsn) ppa newactives of + Left (c, d) -> return (Fail c (Conflicting d)) -- inconsistency found + Right nppa -> local (\ s -> s { pa = PA nppa pfa npsa }) r + +-- | We try to extract as many concrete dependencies from the given flagged +-- dependencies as possible. We make use of all the flag knowledge we have +-- already acquired. +extractDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN] +extractDeps fa sa deps = do + d <- deps + case d of + Simple sd -> return sd + Flagged qfn _ td fd -> case M.lookup qfn fa of + Nothing -> mzero + Just True -> extractDeps fa sa td + Just False -> extractDeps fa sa fd + Stanza qsn td -> case M.lookup qsn sa of + Nothing -> mzero + Just True -> extractDeps fa sa td + Just False -> [] + +-- | We try to find new dependencies that become available due to the given +-- flag or stanza choice. We therefore look for the choice in question, and then call +-- 'extractDeps' for everything underneath. +extractNewDeps :: Var QPN -> QGoalReasons -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN] +extractNewDeps v gr b fa sa = go + where + go deps = do + d <- deps + case d of + Simple _ -> mzero + Flagged qfn' _ td fd + | v == F qfn' -> L.map (resetGoal (Goal v gr)) $ + if b then extractDeps fa sa td else extractDeps fa sa fd + | otherwise -> case M.lookup qfn' fa of + Nothing -> mzero + Just True -> go td + Just False -> go fd + Stanza qsn' td + | v == S qsn' -> L.map (resetGoal (Goal v gr)) $ + if b then extractDeps fa sa td else [] + | otherwise -> case M.lookup qsn' sa of + Nothing -> mzero + Just True -> go td + Just False -> [] + +-- | Interface. +validateTree :: Index -> Tree (QGoalReasons, Scope) -> Tree QGoalReasons +validateTree idx t = runReader (validate t) (VS idx M.empty (PA M.empty M.empty M.empty)) diff --git a/Distribution/Client/Dependency/Modular/Version.hs b/Distribution/Client/Dependency/Modular/Version.hs new file mode 100644 --- /dev/null +++ b/Distribution/Client/Dependency/Modular/Version.hs @@ -0,0 +1,43 @@ +module Distribution.Client.Dependency.Modular.Version where + +import qualified Distribution.Version as CV -- from Cabal +import Distribution.Text -- from Cabal + +-- | Preliminary type for versions. +type Ver = CV.Version + +-- | String representation of a version. +showVer :: Ver -> String +showVer = display + +-- | Version range. Consists of a lower and upper bound. +type VR = CV.VersionRange + +-- | String representation of a version range. +showVR :: VR -> String +showVR = display + +-- | Unconstrained version range. +anyVR :: VR +anyVR = CV.anyVersion + +-- | Version range fixing a single version. +eqVR :: Ver -> VR +eqVR = CV.thisVersion + +-- | Intersect two version ranges. +(.&&.) :: VR -> VR -> VR +(.&&.) = CV.intersectVersionRanges + +-- | Simplify a version range. +simplifyVR :: VR -> VR +simplifyVR = CV.simplifyVersionRange + +-- | Checking a version against a version range. +checkVR :: VR -> Ver -> Bool +checkVR = flip CV.withinRange + +-- | Make a version number. +mkV :: [Int] -> Ver +mkV xs = CV.Version xs [] + diff --git a/Distribution/Client/Dependency/TopDown.hs b/Distribution/Client/Dependency/TopDown.hs --- a/Distribution/Client/Dependency/TopDown.hs +++ b/Distribution/Client/Dependency/TopDown.hs @@ -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 diff --git a/Distribution/Client/Dependency/TopDown/Constraints.hs b/Distribution/Client/Dependency/TopDown/Constraints.hs --- a/Distribution/Client/Dependency/TopDown/Constraints.hs +++ b/Distribution/Client/Dependency/TopDown/Constraints.hs @@ -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 ] diff --git a/Distribution/Client/Dependency/TopDown/Types.hs b/Distribution/Client/Dependency/TopDown/Types.hs --- a/Distribution/Client/Dependency/TopDown/Types.hs +++ b/Distribution/Client/Dependency/TopDown/Types.hs @@ -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) diff --git a/Distribution/Client/Dependency/Types.hs b/Distribution/Client/Dependency/Types.hs --- a/Distribution/Client/Dependency/Types.hs +++ b/Distribution/Client/Dependency/Types.hs @@ -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 diff --git a/Distribution/Client/Fetch.hs b/Distribution/Client/Fetch.hs --- a/Distribution/Client/Fetch.hs +++ b/Distribution/Client/Fetch.hs @@ -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 () diff --git a/Distribution/Client/Haddock.hs b/Distribution/Client/Haddock.hs --- a/Distribution/Client/Haddock.hs +++ b/Distribution/Client/Haddock.hs @@ -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 diff --git a/Distribution/Client/HttpUtils.hs b/Distribution/Client/HttpUtils.hs --- a/Distribution/Client/HttpUtils.hs +++ b/Distribution/Client/HttpUtils.hs @@ -5,6 +5,7 @@ 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 @@ -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 diff --git a/Distribution/Client/IndexUtils.hs b/Distribution/Client/IndexUtils.hs --- a/Distribution/Client/IndexUtils.hs +++ b/Distribution/Client/IndexUtils.hs @@ -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 diff --git a/Distribution/Client/Init.hs b/Distribution/Client/Init.hs --- a/Distribution/Client/Init.hs +++ b/Distribution/Client/Init.hs @@ -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 () diff --git a/Distribution/Client/Init/Heuristics.hs b/Distribution/Client/Init/Heuristics.hs --- a/Distribution/Client/Init/Heuristics.hs +++ b/Distribution/Client/Init/Heuristics.hs @@ -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 ] diff --git a/Distribution/Client/Init/Licenses.hs b/Distribution/Client/Init/Licenses.hs --- a/Distribution/Client/Init/Licenses.hs +++ b/Distribution/Client/Init/Licenses.hs @@ -12,7 +12,7 @@ bsd3 :: String -> String -> License bsd3 authors year = unlines - [ "Copyright (c)" ++ year ++ ", " ++ authors + [ "Copyright (c) " ++ year ++ ", " ++ authors , "" , "All rights reserved." , "" diff --git a/Distribution/Client/Init/Types.hs b/Distribution/Client/Init/Types.hs --- a/Distribution/Client/Init/Types.hs +++ b/Distribution/Client/Init/Types.hs @@ -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 diff --git a/Distribution/Client/Install.hs b/Distribution/Client/Install.hs --- a/Distribution/Client/Install.hs +++ b/Distribution/Client/Install.hs @@ -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 (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' diff --git a/Distribution/Client/InstallPlan.hs b/Distribution/Client/InstallPlan.hs --- a/Distribution/Client/InstallPlan.hs +++ b/Distribution/Client/InstallPlan.hs @@ -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" diff --git a/Distribution/Client/InstallSymlink.hs b/Distribution/Client/InstallSymlink.hs --- a/Distribution/Client/InstallSymlink.hs +++ b/Distribution/Client/InstallSymlink.hs @@ -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 diff --git a/Distribution/Client/List.hs b/Distribution/Client/List.hs --- a/Distribution/Client/List.hs +++ b/Distribution/Client/List.hs @@ -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) diff --git a/Distribution/Client/PackageIndex.hs b/Distribution/Client/PackageIndex.hs --- a/Distribution/Client/PackageIndex.hs +++ b/Distribution/Client/PackageIndex.hs @@ -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). -- diff --git a/Distribution/Client/Setup.hs b/Distribution/Client/Setup.hs --- a/Distribution/Client/Setup.hs +++ b/Distribution/Client/Setup.hs @@ -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 = diff --git a/Distribution/Client/SetupWrapper.hs b/Distribution/Client/SetupWrapper.hs --- a/Distribution/Client/SetupWrapper.hs +++ b/Distribution/Client/SetupWrapper.hs @@ -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 diff --git a/Distribution/Client/SrcDist.hs b/Distribution/Client/SrcDist.hs --- a/Distribution/Client/SrcDist.hs +++ b/Distribution/Client/SrcDist.hs @@ -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" diff --git a/Distribution/Client/Tar.hs b/Distribution/Client/Tar.hs --- a/Distribution/Client/Tar.hs +++ b/Distribution/Client/Tar.hs @@ -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' diff --git a/Distribution/Client/Targets.hs b/Distribution/Client/Targets.hs --- a/Distribution/Client/Targets.hs +++ b/Distribution/Client/Targets.hs @@ -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 () diff --git a/Distribution/Client/Types.hs b/Distribution/Client/Types.hs --- a/Distribution/Client/Types.hs +++ b/Distribution/Client/Types.hs @@ -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 diff --git a/Distribution/Client/Unpack.hs b/Distribution/Client/Unpack.hs --- a/Distribution/Client/Unpack.hs +++ b/Distribution/Client/Unpack.hs @@ -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) diff --git a/Distribution/Client/Update.hs b/Distribution/Client/Update.hs --- a/Distribution/Client/Update.hs +++ b/Distribution/Client/Update.hs @@ -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 ( 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.version laterPreferredVersions = [ packageVersion pkg - | pkg <- PackageIndex.lookupPackageName available self + | pkg <- PackageIndex.lookupPackageName sourcePkgIndex self , let version = packageVersion pkg , version > currentVersion , version `withinRange` preferredVersionRange ] diff --git a/Distribution/Client/Upload.hs b/Distribution/Client/Upload.hs --- a/Distribution/Client/Upload.hs +++ b/Distribution/Client/Upload.hs @@ -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" diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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. -- diff --git a/README b/README --- a/README +++ b/README @@ -17,13 +17,10 @@ is sometimes packaged separately by Linux distributions, for example on debian or ubuntu it is in "libghc6-network-dev". -It requires a few other Haskell packages that are not always installed: - - * Cabal (version 1.10 or later) - * HTTP (version 4000 or later) - * zlib (version 0.4 or later) - -All of these are available from [Hackage](http://hackage.haskell.org). +It requires a few other Haskell packages that are not always installed. +The exact list is specified in the `.cabal` file or in the `bootstrap.sh` +file. All these packages are available from +[Hackage](http://hackage.haskell.org). Note that on some Unix systems you may need to install an additional zlib development package using your system package manager, for example on @@ -45,7 +42,7 @@ $ ./bootstrap.sh -It will download and install the above three dependencies. The script will +It will download and install the dependencies. The script will install the library packages into `$HOME/.cabal/` and the `cabal` program will be installed into `$HOME/.cabal/bin/`. @@ -139,13 +136,6 @@ By default it installs the latest available version however you can optionally specify exact versions or version ranges. For example `cabal install alex-2.2` or `cabal install parsec < 3`. - - $ cabal upgrade xmonad - -This is a variation on the `install` command. Both mean to install the latest -version, the only difference is in the treatment of dependencies. The `install` -command tries to use existing installed versions of dependent packages while -the `upgrade` command tries to upgrade all the dependencies too. $ cabal list xml diff --git a/bootstrap.sh b/bootstrap.sh --- a/bootstrap.sh +++ b/bootstrap.sh @@ -7,7 +7,6 @@ # It expects to be run inside the cabal-install directory. # install settings, you can override these by setting environment vars -PREFIX=${PREFIX:-${HOME}/.cabal} #VERBOSE #EXTRA_CONFIGURE_OPTS @@ -20,6 +19,7 @@ TAR=${TAR:-tar} GUNZIP=${GUNZIP:-gunzip} SCOPE_OF_INSTALLATION="--user" +DEFAULT_PREFIX="${HOME}/.cabal" for arg in $* @@ -30,7 +30,7 @@ shift;; "--global") SCOPE_OF_INSTALLATION=${arg} - PREFIX="/usr/local" + DEFAULT_PREFIX="/usr/local" shift;; *) echo "Unknown argument or option, quitting: ${arg}" @@ -43,17 +43,21 @@ esac done +PREFIX=${PREFIX:-${DEFAULT_PREFIX}} # Versions of the packages to install. # The version regex says what existing installed versions are ok. -PARSEC_VER="3.1.1"; PARSEC_VER_REGEXP="[23]\." # == 2.* || == 3.* -NETWORK_VER="2.3.0.2"; NETWORK_VER_REGEXP="2\." # == 2.* -CABAL_VER="1.10.1.0"; CABAL_VER_REGEXP="1\.10\.[^0]" # == 1.10.* && >= 1.10.1 -TRANS_VER="0.2.2.0"; TRANS_VER_REGEXP="0\.2\." # == 0.2.* -MTL_VER="2.0.1.0"; MTL_VER_REGEXP="[12]\." # == 1.* || == 2.* -HTTP_VER="4000.1.1"; HTTP_VER_REGEXP="4000\.[01]\." # == 4000.0.* || 4000.1.* -ZLIB_VER="0.5.3.1"; ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || ==0.5.* -TIME_VER="1.2.0.4" TIME_VER_REGEXP="1\.[12]\." # == 0.1.* || ==0.2.* +PARSEC_VER="3.1.2"; PARSEC_VER_REGEXP="[23]\." # == 2.* || == 3.* +DEEPSEQ_VER="1.3.0.0"; DEEPSEQ_VER_REGEXP="1\.[1-9]\." # >= 1.1 && < 2 +TEXT_VER="0.11.2.0"; TEXT_VER_REGEXP="0\.([2-9]|(1[0-1]))\." # >= 0.2 && < 0.12 +NETWORK_VER="2.3.0.11"; NETWORK_VER_REGEXP="2\." # == 2.* +CABAL_VER="1.14.0"; CABAL_VER_REGEXP="1\.(13\.3|14\.)" # >= 1.13.3 && < 1.15 +TRANS_VER="0.3.0.0"; TRANS_VER_REGEXP="0\.[23]\." # >= 0.2.* && < 0.4.* +MTL_VER="2.1"; MTL_VER_REGEXP="[12]\." # == 1.* || == 2.* +HTTP_VER="4000.2.3"; HTTP_VER_REGEXP="4000\.[012]\." # == 4000.0.* || 4000.1.* || 4000.2.* +ZLIB_VER="0.5.3.3"; ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || == 0.5.* +TIME_VER="1.4" TIME_VER_REGEXP="1\.[1234]\.?" # >= 1.1 && < 1.5 +RANDOM_VER="1.0.1.1" RANDOM_VER_REGEXP="1\.0\." # >= 1 && < 1.1 HACKAGE_URL="http://hackage.haskell.org/packages/archive" @@ -86,7 +90,7 @@ need_pkg () { PKG=$1 VER_MATCH=$2 - if grep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1 + if egrep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1 then return 1; else @@ -186,20 +190,26 @@ info_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} info_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP} info_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} +info_pkg "deepseq" ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} +info_pkg "text" ${TEXT_VER} ${TEXT_VER_REGEXP} info_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} info_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} info_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP} info_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP} info_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} +info_pkg "random" ${RANDOM_VER} ${RANDOM_VER_REGEXP} do_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} do_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP} do_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} +do_pkg "deepseq" ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} +do_pkg "text" ${TEXT_VER} ${TEXT_VER_REGEXP} do_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} do_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} do_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP} do_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP} do_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} +do_pkg "random" ${RANDOM_VER} ${RANDOM_VER_REGEXP} install_pkg "cabal-install" diff --git a/cabal-install.cabal b/cabal-install.cabal --- a/cabal-install.cabal +++ b/cabal-install.cabal @@ -1,5 +1,5 @@ Name: cabal-install -Version: 0.10.2 +Version: 0.14.0 Synopsis: The command-line interface for Cabal and Hackage. Description: The \'cabal\' command-line program simplifies the process of managing @@ -19,7 +19,7 @@ 2006 Paolo Martini 2007 Bjorn Bringert 2007 Isaac Potoczny-Jones - 2007-2011 Duncan Coutts + 2007-2012 Duncan Coutts Category: Distribution Build-type: Simple Extra-Source-Files: README bash-completion/cabal bootstrap.sh @@ -27,12 +27,8 @@ source-repository head type: darcs - location: http://darcs.haskell.org/cabal-install/ - -source-repository this - type: darcs - location: http://darcs.haskell.org/cabal-branches/cabal-install-0.10/ - tag: 0.10.0 + location: http://darcs.haskell.org/cabal/ + subdir: cabal-install flag old-base description: Old, monolithic base @@ -42,9 +38,7 @@ Executable cabal Main-Is: Main.hs - -- We want assertion checking on even if people build with -O - -- although it is expensive, we want to catch problems early: - ghc-options: -Wall -fno-ignore-asserts + ghc-options: -Wall if impl(ghc >= 6.8) ghc-options: -fwarn-tabs Other-Modules: @@ -60,6 +54,25 @@ Distribution.Client.Dependency.TopDown.Constraints Distribution.Client.Dependency.TopDown.Types Distribution.Client.Dependency.Types + Distribution.Client.Dependency.Modular + Distribution.Client.Dependency.Modular.Assignment + Distribution.Client.Dependency.Modular.Builder + Distribution.Client.Dependency.Modular.Configured + Distribution.Client.Dependency.Modular.ConfiguredConversion + Distribution.Client.Dependency.Modular.Dependency + Distribution.Client.Dependency.Modular.Explore + Distribution.Client.Dependency.Modular.Flag + Distribution.Client.Dependency.Modular.Index + Distribution.Client.Dependency.Modular.IndexConversion + Distribution.Client.Dependency.Modular.Log + Distribution.Client.Dependency.Modular.Message + Distribution.Client.Dependency.Modular.Package + Distribution.Client.Dependency.Modular.Preference + Distribution.Client.Dependency.Modular.PSQ + Distribution.Client.Dependency.Modular.Solver + Distribution.Client.Dependency.Modular.Tree + Distribution.Client.Dependency.Modular.Validate + Distribution.Client.Dependency.Modular.Version Distribution.Client.Fetch Distribution.Client.FetchUtils Distribution.Client.GZipUtils @@ -93,24 +106,25 @@ Paths_cabal_install build-depends: base >= 2 && < 5, - Cabal >= 1.10.1 && < 1.11, - filepath >= 1.0 && < 1.3, + Cabal >= 1.14.0 && < 1.15, + filepath >= 1.0 && < 1.4, network >= 1 && < 3, HTTP >= 4000.0.2 && < 4001, zlib >= 0.4 && < 0.6, - time >= 1.1 && < 1.3 + time >= 1.1 && < 1.5, + mtl >= 2.0 && < 3 if flag(old-base) build-depends: base < 3 else build-depends: base >= 3, - process >= 1 && < 1.1, + process >= 1 && < 1.2, directory >= 1 && < 1.2, - pretty >= 1 && < 1.1, + pretty >= 1 && < 1.2, random >= 1 && < 1.1, containers >= 0.1 && < 0.5, - array >= 0.1 && < 0.4, - old-time >= 1 && < 1.1 + array >= 0.1 && < 0.5, + old-time >= 1 && < 1.2 if flag(bytestring-in-base) build-depends: base >= 2.0 && < 2.2 @@ -121,5 +135,5 @@ build-depends: Win32 >= 2 && < 3 cpp-options: -DWIN32 else - build-depends: unix >= 1.0 && < 2.5 + build-depends: unix >= 1.0 && < 2.6 extensions: CPP