Display information on why a snapshot was rejected #381

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
 

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)