From 1111e351cdb9d0c890821018706e637ef92a6303 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 24 Jun 2015 06:14:27 +0300 Subject: [PATCH] Display information on why a snapshot was rejected #381 --- ChangeLog.md | 1 + src/Stack/BuildPlan.hs | 111 +++++++++++++++++++++++++---------------- 2 files changed, 68 insertions(+), 44 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 32b0f12c1d..9db84b82cb 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -6,6 +6,7 @@ * single test suite failure should show entire log [#388](https://github.com/commercialhaskell/stack/issues/388) * valid-wanted is a confusing option name [#386](https://github.com/commercialhaskell/stack/issues/386) * stack init in multi-package project should use local packages for dependency checking [#384](https://github.com/commercialhaskell/stack/issues/384) +* Display information on why a snapshot was rejected [#381](https://github.com/commercialhaskell/stack/issues/381) ## 0.1.0.0 diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 905db2c580..e5f85120c5 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -47,10 +47,9 @@ import Data.List (intercalate) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (mapMaybe) -import Data.Monoid ((<>)) +import Data.Monoid ((<>), Monoid (..)) import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) import qualified Data.Text as T import Data.Time (Day) import qualified Data.Traversable as Tr @@ -62,6 +61,8 @@ import Distribution.PackageDescription (GenericPackageDescription, executables, exeName, library, libBuildInfo, buildable) import qualified Distribution.Package as C import qualified Distribution.PackageDescription as C +import qualified Distribution.Version as C +import Distribution.Text (display) import Network.HTTP.Download import Path import Prelude -- Fix AMP warning @@ -481,19 +482,19 @@ checkBuildPlan :: (MonadLogger m, MonadThrow m, MonadIO m, MonadReader env m, Ha => Map PackageName Version -- ^ locally available packages -> MiniBuildPlan -> GenericPackageDescription - -> m (Maybe (Map FlagName Bool)) + -> m (Either DepErrors (Map PackageName (Map FlagName Bool))) checkBuildPlan locals mbp gpd = do platform <- asks (configPlatform . getConfig) - loop platform flagOptions + return $ loop platform flagOptions where packages = Map.union locals $ fmap mpiVersion $ mbpPackages mbp - loop _ [] = return Nothing - loop platform (flags:rest) = do - passes <- checkDeps flags (packageDeps pkg) packages - if passes - then return $ Just flags - else loop platform rest + loop _ [] = assert False $ Left Map.empty + loop platform (flags:rest) + | Map.null errs = Right $ Map.singleton (packageName pkg) flags + | null rest = Left errs + | otherwise = loop platform rest where + errs = checkDeps (packageName pkg) (packageDeps pkg) packages pkg = resolvePackage pkgConfig gpd pkgConfig = PackageConfig { packageConfigEnableTests = True @@ -522,33 +523,37 @@ checkBuildPlan locals mbp gpd = do -- | Checks if the given package dependencies can be satisfied by the given set -- of packages. Will fail if a package is either missing or has a version -- outside of the version range. -checkDeps :: MonadLogger m - => Map FlagName Bool -- ^ used only for debugging purposes +checkDeps :: PackageName -- ^ package using dependencies, for constructing DepErrors -> Map PackageName VersionRange -> Map PackageName Version - -> m Bool -checkDeps flags deps packages = do - let errs = mapMaybe go $ Map.toList deps - if null errs - then return True - else do - $logDebug $ "Checked against following flags: " <> T.pack (show flags) - mapM_ $logDebug errs - return False + -> DepErrors +checkDeps myName deps packages = + Map.unionsWith mappend $ map go $ Map.toList deps where - go :: (PackageName, VersionRange) -> Maybe Text + go :: (PackageName, VersionRange) -> DepErrors go (name, range) = case Map.lookup name packages of - Nothing -> Just $ "Package not present: " <> packageNameText name + Nothing -> Map.singleton name DepError + { deVersion = Nothing + , deNeededBy = Map.singleton myName range + } Just v - | withinRange v range -> Nothing - | otherwise -> Just $ T.concat - [ packageNameText name - , " version available: " - , versionText v - , " does not match " - , versionRangeText range - ] + | withinRange v range -> Map.empty + | otherwise -> Map.singleton name DepError + { deVersion = Just v + , deNeededBy = Map.singleton myName range + } + +type DepErrors = Map PackageName DepError +data DepError = DepError + { deVersion :: !(Maybe Version) + , deNeededBy :: !(Map PackageName VersionRange) + } +instance Monoid DepError where + mempty = DepError Nothing Map.empty + mappend (DepError a x) (DepError b y) = DepError + (maybe a Just b) + (Map.unionWith C.intersectVersionRanges x y) -- | Find a snapshot and set of flags that is compatible with the given -- 'GenericPackageDescription'. Returns 'Nothing' if no such snapshot is found. @@ -563,25 +568,43 @@ findBuildPlan gpds0 = loop (name:names') = do mbp <- loadMiniBuildPlan name $logInfo $ "Checking against build plan " <> renderSnapName name - let checkGPDs flags [] = return $ Just (name, flags) - checkGPDs flags (gpd:gpds) = do - let C.PackageIdentifier pname' _ = C.package $ C.packageDescription gpd - pname = fromCabalPackageName pname' - mflags <- checkBuildPlan localNames mbp gpd - case mflags of - Nothing -> loop names' - Just flags' -> checkGPDs - (if Map.null flags' - then flags - else Map.insert pname flags' flags) - gpds - checkGPDs Map.empty gpds0 + res <- mapM (checkBuildPlan localNames mbp) gpds0 + case partitionEithers res of + ([], flags) -> return $ Just (name, Map.unions flags) + (errs, _) -> do + $logInfo "" + $logInfo "* Build plan did not match your requirements:" + displayDepErrors $ Map.unionsWith mappend errs + $logInfo "" + loop names' localNames = Map.fromList $ map (fromCabalIdent . C.package . C.packageDescription) gpds0 fromCabalIdent (C.PackageIdentifier name version) = (fromCabalPackageName name, fromCabalVersion version) +displayDepErrors :: MonadLogger m => DepErrors -> m () +displayDepErrors errs = + F.forM_ (Map.toList errs) $ \(depName, DepError mversion neededBy) -> do + $logInfo $ T.concat + [ " " + , T.pack $ packageNameString depName + , case mversion of + Nothing -> " not found" + Just version -> T.concat + [ " version " + , T.pack $ versionString version + , " found" + ] + ] + F.forM_ (Map.toList neededBy) $ \(user, range) -> $logInfo $ T.concat + [ " - " + , T.pack $ packageNameString user + , " requires " + , T.pack $ display range + ] + $logInfo "" + shadowMiniBuildPlan :: MiniBuildPlan -> Set PackageName -> (MiniBuildPlan, Map PackageName MiniPackageInfo)