Stack init and solver finish up and doc update

doc/yaml_configuration.md

@@ -128,6 +128,28 @@ You can also specify `entrypoints`. By default all your executables are placed
 in `/usr/local/bin`, but you can specify a list using `executables` to only add
 some.
 
+### user-message
+
+A user-message is inserted by `stack init` when it omits packages or adds
+external dependencies. For example:
+
+```yaml
+user-message: ! 'Warning: Some packages were found to be incompatible with the resolver
+  and have been left commented out in the packages section.
+
+  Warning: Specified resolver could not satisfy all dependencies. Some external packages
+  have been added as dependencies.
+
+  You can suppress this message by removing it from stack.yaml
+
+'
+```
+
+This messages is displayed every time the config is loaded by stack and serves
+as a reminder for the user to review the configuration and make any changes if
+needed. The user can delete this message if the generated configuration is
+acceptable.
+
 ## Non-project config
 
 Non-project config options may go in the global config (`/etc/stack/config.yaml`) or the user config (`~/.stack/config.yaml`).

src/Stack/BuildPlan.hs

@@ -10,10 +10,14 @@
 -- snapshot.
 
 module Stack.BuildPlan
-    ( gpdPackages
-    , BuildPlanException (..)
+    ( BuildPlanException (..)
     , BuildPlanCheck (..)
     , checkSnapBuildPlan
+    , DepError(..)
+    , DepErrors
+    , gpdPackageDeps
+    , gpdPackages
+    , gpdPackageName
     , MiniBuildPlan(..)
     , MiniPackageInfo(..)
     , loadMiniBuildPlan
@@ -23,8 +27,7 @@ module Stack.BuildPlan
     , ToolMap
     , getToolMap
     , shadowMiniBuildPlan
-    , showCompilerErrors
-    , showDepErrors
+    , showItems
     , parseCustomMiniBuildPlan
     ) where
 
@@ -652,6 +655,36 @@ data BuildPlanCheck =
     | BuildPlanCheckFail    (Map PackageName (Map FlagName Bool)) DepErrors
                             CompilerVersion
 
+-- Greater means a better plan
+instance Ord BuildPlanCheck where
+  BuildPlanCheckPartial _ e1 `compare` BuildPlanCheckPartial _ e2 =
+      compare (Map.size e1) (Map.size e2)
+
+  BuildPlanCheckFail _ e1 _  `compare` BuildPlanCheckFail _ e2 _ =
+      let numUserPkgs e = Map.size $ Map.unions (Map.elems (fmap deNeededBy e))
+      in compare (numUserPkgs e1) (numUserPkgs e2)
+
+  BuildPlanCheckOk {}        `compare` BuildPlanCheckOk {}      = EQ
+  BuildPlanCheckOk {}        `compare` BuildPlanCheckPartial {} = GT
+  BuildPlanCheckOk {}        `compare` BuildPlanCheckFail {}    = GT
+  BuildPlanCheckPartial {}   `compare` BuildPlanCheckFail {}    = GT
+  _ `compare` _ = LT
+
+instance Eq BuildPlanCheck where
+  BuildPlanCheckOk {}          == BuildPlanCheckOk {}        = True
+  BuildPlanCheckPartial _ e1   == BuildPlanCheckPartial _ e2 =
+      Map.size e1 == Map.size e2
+  BuildPlanCheckFail _ e1 _  == BuildPlanCheckFail _ e2 _    =
+      let numUserPkgs e = Map.size $ Map.unions (Map.elems (fmap deNeededBy e))
+      in numUserPkgs e1 == numUserPkgs e2
+
+  _ == _ = False
+
+instance Show BuildPlanCheck where
+    show BuildPlanCheckOk {} = ""
+    show (BuildPlanCheckPartial f e)  = T.unpack $ showDepErrors f e
+    show (BuildPlanCheckFail f e c) = T.unpack $ showCompilerErrors f e c
+
 -- | Check a set of 'GenericPackageDescription's and a set of flags against a
 -- given snapshot. Returns how well the snapshot satisfies the dependencies of
 -- the packages.
@@ -697,67 +730,67 @@ selectBestSnapshot
        , MonadBaseControl IO m)
     => [GenericPackageDescription]
     -> [SnapName]
-    -> m (Maybe SnapName)
+    -> m (SnapName, BuildPlanCheck)
 selectBestSnapshot gpds snaps = do
     $logInfo $ "Selecting the best among "
                <> T.pack (show (length snaps))
                <> " snapshots...\n"
     loop Nothing snaps
     where
-        loop Nothing [] = return Nothing
-        loop (Just (snap, _)) [] = return $ Just snap
+        loop Nothing []          = error "Bug: in best snapshot selection"
+        loop (Just pair) []      = return pair
         loop bestYet (snap:rest) = do
             result <- checkSnapBuildPlan gpds Nothing snap
             reportResult result snap
+            let new = (snap, result)
             case result of
-                BuildPlanCheckFail _ _ _ -> loop bestYet rest
-                BuildPlanCheckOk _ -> return $ Just snap
-                BuildPlanCheckPartial _ e -> do
-                    case bestYet of
-                        Nothing -> loop (Just (snap, e)) rest
-                        Just prev ->
-                            loop (Just (betterSnap prev (snap, e))) rest
-
-        betterSnap (s1, e1) (s2, e2)
-          | (Map.size e1) <= (Map.size e2) = (s1, e1)
-          | otherwise = (s2, e2)
-
-        reportResult (BuildPlanCheckOk _) snap = do
-            $logInfo $ "* Selected " <> renderSnapName snap
+                BuildPlanCheckOk {} -> return new
+                _ -> case bestYet of
+                        Nothing  -> loop (Just new) rest
+                        Just old -> loop (Just (betterSnap old new)) rest
+
+        betterSnap (s1, r1) (s2, r2)
+          | r1 <= r2  = (s1, r1)
+          | otherwise = (s2, r2)
+
+        reportResult BuildPlanCheckOk {} snap = do
+            $logInfo $ "* Matches " <> renderSnapName snap
             $logInfo ""
 
-        reportResult (BuildPlanCheckPartial f errs) snap = do
+        reportResult r@BuildPlanCheckPartial {} snap = do
             $logWarn $ "* Partially matches " <> renderSnapName snap
-            $logWarn $ indent $ showDepErrors f errs
+            $logWarn $ indent $ T.pack $ show r
 
-        reportResult (BuildPlanCheckFail f errs compiler) snap = do
+        reportResult r@BuildPlanCheckFail {} snap = do
             $logWarn $ "* Rejected " <> renderSnapName snap
-            $logWarn $ indent $ showCompilerErrors f errs compiler
+            $logWarn $ indent $ T.pack $ show r
 
         indent t = T.unlines $ fmap ("    " <>) (T.lines t)
 
+showItems :: Show a => [a] -> Text
+showItems items = T.concat (map formatItem items)
+    where
+        formatItem item = T.concat
+            [ "    - "
+            , T.pack $ show item
+            , "\n"
+            ]
+
+showMapPackages :: Map PackageName a -> Text
+showMapPackages mp = showItems $ Map.keys mp
+
 showCompilerErrors
     :: Map PackageName (Map FlagName Bool)
     -> DepErrors
     -> CompilerVersion
     -> Text
 showCompilerErrors flags errs compiler =
-    -- TODO print the package filename to enable quick mapping for the user
     T.concat
         [ compilerVersionText compiler
         , " cannot be used for these packages:\n"
-        , T.concat (map formatError (Map.toList errs))
+        , showMapPackages $ Map.unions (Map.elems (fmap deNeededBy errs))
         , showDepErrors flags errs -- TODO only in debug mode
         ]
-    where
-        formatError (_, DepError _ neededBy) = T.concat $
-            map formatItem (Map.toList neededBy)
-
-        formatItem (user, _) = T.concat
-            [ "    - "
-            , T.pack $ packageNameString user
-            , "\n"
-            ]
 
 showDepErrors :: Map PackageName (Map FlagName Bool) -> DepErrors -> Text
 showDepErrors flags errs =

src/Stack/Config.hs

@@ -374,6 +374,11 @@ loadConfig configArgs mstackYaml mresolver = do
                               (configMonoidDockerOpts c) {dockerMonoidDefaultEnable = False}})
                 extraConfigs0
     mproject <- loadProjectConfig mstackYaml
+
+    let printUserMessage (p, _, _) =
+         maybe (return ()) ($logWarn . T.pack) (projectUserMsg p)
+    maybe (return ()) printUserMessage mproject
+
     let mproject' = (\(project, stackYaml, _) -> (project, stackYaml)) <$> mproject
     config <- configFromConfigMonoid stackRoot userConfigPath mresolver mproject' $ mconcat $
         case mproject of
@@ -435,7 +440,8 @@ loadBuildConfig mproject config mresolver mcompiler = do
                    $logInfo ("Writing implicit global project config file to: " <> T.pack dest')
                    $logInfo "Note: You can change the snapshot via the resolver field there."
                    let p = Project
-                           { projectPackages = mempty
+                           { projectUserMsg = Nothing
+                           , projectPackages = mempty
                            , projectExtraDeps = mempty
                            , projectFlags = mempty
                            , projectResolver = r