Commit 03cd0c96 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Switch DependencyResolver to return Progress and String errors

rather than Either and structured error type [Dependency]. The reason
we cannot use that as a structured error type any more is because
missing dependencies is not the only failure reason. There are
several reasons, several of which are pretty complex. For now we'll
have to do with a human readable message. Perhaps we may be able to
find a common structured type that the different dep resolvers can
all agree on. I'm not hopeful however as error reporting seems to be
closely tied to the dep resolution approach.
parent 825e9cba
......@@ -27,7 +27,7 @@ import Hackage.InstallPlan (InstallPlan)
import Hackage.Types
( UnresolvedDependency(..), AvailablePackage(..) )
import Hackage.Dependency.Types
( DependencyResolver )
( DependencyResolver, Progress(..), foldProgress )
import Distribution.Package
( PackageIdentifier(..), packageVersion, packageName
, Dependency(..), Package(..), PackageFixedDeps(..) )
......@@ -54,12 +54,14 @@ resolveDependencies :: OS
-> Maybe (PackageIndex InstalledPackageInfo)
-> PackageIndex AvailablePackage
-> [UnresolvedDependency]
-> Either [Dependency] (InstallPlan a)
-> Either String (InstallPlan a)
resolveDependencies os arch comp (Just installed) available deps =
foldProgress (flip const) Left Right $
dependencyResolver defaultResolver
os arch comp installed available deps
resolveDependencies os arch comp Nothing available deps =
foldProgress (flip const) Left Right $
dependencyResolver bogusResolver
os arch comp mempty available deps
......@@ -83,15 +85,16 @@ dependencyResolver
-> PackageIndex InstalledPackageInfo
-> PackageIndex AvailablePackage
-> [UnresolvedDependency]
-> Either [Dependency] (InstallPlan a)
dependencyResolver resolver os arch comp installed available deps =
-> Progress String String (InstallPlan a)
dependencyResolver resolver os arch comp installed available =
let installed' = hideBrokenPackages installed
available' = hideBasePackage available
in case resolver os arch comp installed' available' deps of
Left unresolved -> Left unresolved
Right pkgs ->
in fmap toPlan . resolver os arch comp installed' available'
where
toPlan pkgs =
case InstallPlan.new os arch comp (PackageIndex.fromList pkgs) of
Right plan -> Right plan
Right plan -> plan
Left problems -> error $ unlines $
"internal error: could not construct a valid install plan."
: "The proposed (invalid) plan contained the following problems:"
......
......@@ -22,12 +22,14 @@ import Hackage.Types
( UnresolvedDependency(..), AvailablePackage(..)
, ConfiguredPackage(..) )
import Hackage.Dependency.Types
( DependencyResolver )
( DependencyResolver, Progress(..) )
import Distribution.Package
( PackageIdentifier(..), Dependency(..), Package(..) )
import Distribution.PackageDescription.Configuration
( finalizePackageDescription)
import Distribution.Simple.Utils (comparing)
import Hackage.Utils
( showDependencies )
import Data.List (maximumBy)
......@@ -39,8 +41,9 @@ import Data.List (maximumBy)
bogusResolver :: DependencyResolver a
bogusResolver os arch comp _ available deps =
case unzipEithers (map resolveFromAvailable deps) of
(ok, []) -> Right ok
(_ , missing) -> Left missing
(ok, []) -> Done ok
(_ , missing) -> Fail $ "Unresolved dependencies: "
++ showDependencies missing
where
resolveFromAvailable (UnresolvedDependency dep flags) =
case latestAvailableSatisfying available dep of
......
......@@ -25,7 +25,7 @@ import Hackage.Types
( UnresolvedDependency(..), AvailablePackage(..)
, ConfiguredPackage(..) )
import Hackage.Dependency.Types
( DependencyResolver )
( DependencyResolver, Progress(..) )
import Distribution.Package
( PackageIdentifier(..), Dependency(..), Package(..) )
import Distribution.PackageDescription
......@@ -38,6 +38,8 @@ import Distribution.Compiler
import Distribution.System
( OS, Arch )
import Distribution.Simple.Utils (comparing, intercalate)
import Hackage.Utils
( showDependencies )
import Distribution.Text
( display )
......@@ -117,7 +119,7 @@ getDependencies os arch comp installed available pkg flags
packagesToInstall :: PackageIndex InstalledPackageInfo
-> [ResolvedDependency]
-> Either [Dependency] [InstallPlan.PlanPackage a]
-> Progress String String [InstallPlan.PlanPackage a]
-- ^ Either a list of missing dependencies, or a graph
-- of packages to install, with their options.
packagesToInstall allInstalled deps0 =
......@@ -138,10 +140,11 @@ packagesToInstall allInstalled deps0 =
allInstalled
(getInstalled deps0)
in Right $ map InstallPlan.Configured selectedAvailable
in Done $ map InstallPlan.Configured selectedAvailable
++ map InstallPlan.PreExisting selectedInstalled
(missing, _) -> Left $ concat missing
(missing, _) -> Fail $ "Unresolved dependencies: "
++ showDependencies (concat missing)
where
getAvailable :: ResolvedDependency
......
......@@ -56,8 +56,6 @@ import qualified Data.Set as Set
import Data.Set (Set)
import qualified Data.Graph as Graph
import Debug.Trace (trace)
-- ------------------------------------------------------------
-- * Search state types
-- ------------------------------------------------------------
......@@ -173,10 +171,10 @@ search configure constraints =
topDownResolver :: DependencyResolver a
topDownResolver = (((((mapMessages .).).).).) . topDownResolver'
where
mapMessages :: Progress Log Failure a -> Either [Dependency] a
mapMessages = Progress.foldProgress (trace . showLog)
(error . showFailure)
Right
mapMessages :: Progress Log Failure a -> Progress String String a
mapMessages = Progress.foldProgress (Progress.Step . showLog)
(Progress.Fail . showFailure)
Progress.Done
-- | The native resolver with detailed structured logging and failure types.
--
......
......@@ -24,8 +24,8 @@ import Hackage.Dependency.TopDown.Types
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (PackageIndex)
import Distribution.Package
( PackageIdentifier(..), Package(..), packageVersion, packageName
, Dependency(..) )
( PackageIdentifier, Package(packageId), packageVersion, packageName
, Dependency(Dependency) )
import Distribution.Version
( withinRange )
import Distribution.Simple.Utils
......
......@@ -20,8 +20,6 @@ import Hackage.Types
( UnresolvedDependency(..), AvailablePackage(..) )
import qualified Hackage.InstallPlan as InstallPlan
import Distribution.Package
( Dependency )
import Distribution.InstalledPackageInfo
( InstalledPackageInfo )
import Distribution.Simple.PackageIndex
......@@ -47,7 +45,7 @@ type DependencyResolver a = OS
-> PackageIndex InstalledPackageInfo
-> PackageIndex AvailablePackage
-> [UnresolvedDependency]
-> Either [Dependency] [InstallPlan.PlanPackage a]
-> Progress String String [InstallPlan.PlanPackage a]
-- | A type to represent the unfolding of an expensive long running
-- calculation that may fail. We may get intermediate steps before the final
......
......@@ -135,7 +135,7 @@ fetch verbosity packageDB repos comp conf deps
deps' <- IndexUtils.disambiguateDependencies available deps
case resolveDependencies buildOS buildArch
(compilerId comp) installed available deps' of
Left missing -> die $ "Unresolved dependencies: " ++ showDependencies missing
Left message -> die message
Right pkgs -> do
ps <- filterM (fmap not . isFetched)
[ pkg | (InstallPlan.Configured
......
......@@ -37,7 +37,6 @@ import Hackage.Tar (extractTarGzFile)
import Hackage.Types as Available
( UnresolvedDependency(..), AvailablePackage(..)
, AvailablePackageSource(..), Repo, ConfiguredPackage(..) )
import Hackage.Utils (showDependencies)
import Hackage.SetupWrapper
( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
import Paths_cabal_install (getBinDir)
......@@ -113,7 +112,7 @@ upgrade verbosity packageDB repos comp =
type Planner = Maybe (PackageIndex InstalledPackageInfo)
-> PackageIndex AvailablePackage
-> IO (Either [Dependency] (InstallPlan BuildResult))
-> IO (Either String (InstallPlan BuildResult))
-- |Installs the packages generated by a planner.
installWithPlanner ::
......@@ -134,7 +133,7 @@ installWithPlanner planner verbosity packageDB repos comp conf configFlags insta
info verbosity "Resolving dependencies..."
case maybePlan of
Left missing -> die $ "Unresolved dependencies: " ++ showDependencies missing
Left message -> die message
Right installPlan -> do
when (dryRun || verbosity >= verbose) $
printDryRun verbosity installPlan
......@@ -169,12 +168,7 @@ installWithPlanner planner verbosity packageDB repos comp conf configFlags insta
-- | Make an 'InstallPlan' for the unpacked package in the current directory,
-- and all its dependencies.
--
planLocalPackage :: Verbosity
-> Compiler
-> Cabal.ConfigFlags
-> Maybe (PackageIndex InstalledPackageInfo)
-> PackageIndex AvailablePackage
-> IO (Either [Dependency] (InstallPlan BuildResult))
planLocalPackage :: Verbosity -> Compiler -> Cabal.ConfigFlags -> Planner
planLocalPackage verbosity comp configFlags installed available = do
pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity
let -- The trick is, we add the local package to the available index and
......@@ -199,20 +193,13 @@ planLocalPackage verbosity comp configFlags installed available = do
-- | Make an 'InstallPlan' for the given dependencies.
--
planRepoPackages :: Compiler
-> [UnresolvedDependency]
-> Maybe (PackageIndex InstalledPackageInfo)
-> PackageIndex AvailablePackage
-> IO (Either [Dependency] (InstallPlan BuildResult))
planRepoPackages :: Compiler -> [UnresolvedDependency] -> Planner
planRepoPackages comp deps installed available = do
deps' <- IndexUtils.disambiguateDependencies available deps
return $ resolveDependencies buildOS buildArch (compilerId comp)
installed available deps'
planUpgradePackages :: Compiler
-> Maybe (PackageIndex InstalledPackageInfo)
-> PackageIndex AvailablePackage
-> IO (Either [Dependency] (InstallPlan BuildResult))
planUpgradePackages :: Compiler -> Planner
planUpgradePackages comp (Just installed) available = return $
resolveDependencies buildOS buildArch (compilerId comp) (Just installed) available
[ UnresolvedDependency dep []
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment