Plumb verbosity level down to where its needed

Use `setVerbose` in two of the unit tests in preparation for upcoming
changes to the `skipping ...` message.

Author: erikd

cabal-install-solver/src/Distribution/Solver/Modular.hs

@@ -200,7 +200,7 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
           -- original goal order.
           goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc)
 
-      in unlines ("Could not resolve dependencies:" : map renderSummarizedMessage (messages (toProgress (runSolver True sc'))))
+      in unlines ("Could not resolve dependencies:" : map (renderSummarizedMessage (solverVerbosity sc)) (messages (toProgress (runSolver True sc'))))
 
     printFullLog = solverVerbosity sc >= verbose
 

cabal-install-solver/src/Distribution/Solver/Modular/Message.hs

@@ -54,6 +54,7 @@ import Distribution.Types.LibraryName
     ( LibraryName(LSubLibName, LMainLibName) )
 import Distribution.Types.UnqualComponentName
     ( unUnqualComponentName )
+import Distribution.Verbosity (Verbosity, verbose)
 
 import Text.PrettyPrint ( nest, render )
 
@@ -69,32 +70,32 @@ data Message =
   | Success
   | Failure ConflictSet FailReason
 
-renderSummarizedMessage :: SummarizedMessage -> String
-renderSummarizedMessage (SummarizedMsg i) = displayMessageAtLevel i
-renderSummarizedMessage (StringMsg s) = s
+renderSummarizedMessage :: Verbosity -> SummarizedMessage -> String
+renderSummarizedMessage verb (SummarizedMsg i) = displayMessageAtLevel verb i
+renderSummarizedMessage _ (StringMsg s) = s
 
-displayMessageAtLevel :: EntryAtLevel -> String
-displayMessageAtLevel (AtLevel l msg) =
+displayMessageAtLevel :: Verbosity -> EntryAtLevel -> String
+displayMessageAtLevel verb (AtLevel l msg) =
   let s = show l
-  in  "[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ displayMessage msg
-
-displayMessage :: Entry -> String
-displayMessage (EntryPackageGoal qpn gr) = "next goal: " ++ showQPN qpn ++ showGR gr
-displayMessage (EntryRejectF qfn b c fr) = "rejecting: " ++ showQFNBool qfn b ++ showFR c fr
-displayMessage (EntryRejectS qsn b c fr) = "rejecting: " ++ showQSNBool qsn b ++ showFR c fr
-displayMessage (EntrySkipping cs) = "skipping: " ++ showConflicts cs
-displayMessage (EntryTryingF qfn b) = "trying: " ++ showQFNBool qfn b
-displayMessage (EntryTryingP qpn i) = "trying: " ++ showOption qpn i
-displayMessage (EntryTryingNewP qpn i gr) = "trying: " ++ showOption qpn i ++ showGR gr
-displayMessage (EntryTryingS qsn b) = "trying: " ++ showQSNBool qsn b
-displayMessage (EntryUnknownPackage qpn gr) = "unknown package: " ++ showQPN qpn ++ showGR gr
-displayMessage EntrySuccess = "done"
-displayMessage (EntryFailure c fr) = "fail" ++ showFR c fr
-displayMessage (EntrySkipMany qsn b cs) = "skipping: " ++ showOptions qsn b ++ " " ++ showConflicts cs
+  in  "[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ displayMessage verb msg
+
+displayMessage :: Verbosity -> Entry -> String
+displayMessage _ (EntryPackageGoal qpn gr) = "next goal: " ++ showQPN qpn ++ showGR gr
+displayMessage _ (EntryRejectF qfn b c fr) = "rejecting: " ++ showQFNBool qfn b ++ showFR c fr
+displayMessage _ (EntryRejectS qsn b c fr) = "rejecting: " ++ showQSNBool qsn b ++ showFR c fr
+displayMessage _ (EntrySkipping cs) = "skipping: " ++ showConflicts cs
+displayMessage _ (EntryTryingF qfn b) = "trying: " ++ showQFNBool qfn b
+displayMessage _ (EntryTryingP qpn i) = "trying: " ++ showOption qpn i
+displayMessage _ (EntryTryingNewP qpn i gr) = "trying: " ++ showOption qpn i ++ showGR gr
+displayMessage _ (EntryTryingS qsn b) = "trying: " ++ showQSNBool qsn b
+displayMessage _ (EntryUnknownPackage qpn gr) = "unknown package: " ++ showQPN qpn ++ showGR gr
+displayMessage _ EntrySuccess = "done"
+displayMessage _ (EntryFailure c fr) = "fail" ++ showFR c fr
+displayMessage verb (EntrySkipMany qsn b cs) = "skipping: " ++ showOptions verb qsn b ++ " " ++ showConflicts cs
 -- Instead of displaying `aeson-1.0.2.1, aeson-1.0.2.0, aeson-1.0.1.0, ...`,
 -- the following line aims to display `aeson: 1.0.2.1, 1.0.2.0, 1.0.1.0, ...`.
 --
-displayMessage (EntryRejectMany qpn is c fr) = "rejecting: " ++ showOptions qpn is ++ showFR c fr
+displayMessage verb (EntryRejectMany qpn is c fr) = "rejecting: " ++ showOptions verb qpn is ++ showFR c fr
 
 -- | Transforms the structured message type to actual messages (SummarizedMessage s).
 --
@@ -283,15 +284,15 @@ showOption qpn@(Q _pp pn) (POption i linkedTo) =
 -- "foo-bar; foo-bar~>bazqux.foo-bar-1, foo-bar~>bazqux.foo-bar-2"
 -- >>> showOptions foobarQPN [v0, i1, k2]
 -- "foo-bar; 0, 1/installed-inplace, foo-bar~>bazqux.foo-bar-2 and earlier versions"
-showOptions :: QPN -> [POption] -> String
-showOptions _ [] = "unexpected empty list of versions"
-showOptions q [x] = showOption q x
-showOptions q xs = showQPN q ++ "; " ++ (L.intercalate ", "
+showOptions :: Verbosity -> QPN -> [POption] -> String
+showOptions _ _ [] = "unexpected empty list of versions"
+showOptions _ q [x] = showOption q x
+showOptions verb q xs = showQPN q ++ "; " ++ (L.intercalate ", "
   [if isJust linkedTo
     then showOption q x
     else showI i -- Don't show the package, just the version
-  | x@(POption i linkedTo) <- take 3 xs
-  ] ++ if length xs >= 3 then " and other versions" else "")
+  | x@(POption i linkedTo) <- if verb >= verbose then xs else take 3 xs
+  ] ++ if verb < verbose && length xs >= 3 then " and other versions" else "")
 
 showGR :: QGoalReason -> String
 showGR UserGoal            = " (user goal)"

cabal-install/src/Distribution/Client/Dependency.hs

@@ -854,7 +854,7 @@ resolveDependencies platform comp pkgConfigDB params =
           else dontInstallNonReinstallablePackages params
 
     formatProgress :: Progress SummarizedMessage String a -> Progress String String a
-    formatProgress p = foldProgress (\x xs -> Step (renderSummarizedMessage x) xs) Fail Done p
+    formatProgress p = foldProgress (\x xs -> Step (renderSummarizedMessage (depResolverVerbosity params) x) xs) Fail Done p
 
     preferences :: PackageName -> PackagePreferences
     preferences = interpretPackagesPreference targets defpref prefs

cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs

@@ -951,8 +951,9 @@ tests =
                     ]
                   rejecting = "rejecting: A-3.0.0"
                   skipping = "skipping: A; 2.0.0, 1.0.0"
-               in mkTest db "show skipping versions list" ["B"] $
-                    solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)
+               in setVerbose $
+                    mkTest db "show skipping versions list" ["B"] $
+                      solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)
           , runTest $
               let db =
                     [ Left $ exInst "A" 1 "A-1.0.0" []
@@ -962,8 +963,9 @@ tests =
                     ]
                   rejecting = "rejecting: A-3.0.0/installed-3.0.0"
                   skipping = "skipping: A; 2.0.0/installed-2.0.0, 1.0.0/installed-1.0.0"
-               in mkTest db "show skipping versions list, installed" ["B"] $
-                    solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)
+               in setVerbose $
+                    mkTest db "show skipping versions list, installed" ["B"] $
+                      solverFailure (\msg -> rejecting `isInfixOf` msg && skipping `isInfixOf` msg)
           , runTest $
               let db =
                     [ Right $ exAv "A" 1 []