Merge pull request #3404 from commercialhaskell/2650-pretty-upgrade

[WIP] pretty up `s/S/Upgrade`

src/Stack/Coverage.hs

@@ -134,7 +134,7 @@ generateHpcReport pkgDir package tests = do
                         Just includeName -> ["--include", includeName ++ ":"]
                         Nothing -> []
                 mreportPath <- generateHpcReportInternal tixSrc reportDir report extraArgs extraArgs
-                forM_ mreportPath (displayReportPath report)
+                forM_ mreportPath (displayReportPath report . display)
 
 generateHpcReportInternal :: HasEnvConfig env
                           => Path Abs File -> Path Abs Dir -> Text -> [String] -> [String]
@@ -271,7 +271,7 @@ generateHpcReportForTargets opts = do
             then do
                 prettyInfo $ "Opening" <+> display reportPath <+> "in the browser."
                 void $ liftIO $ openBrowser (toFilePath reportPath)
-            else displayReportPath report reportPath
+            else displayReportPath report (display reportPath)
 
 generateHpcUnifiedReport :: HasEnvConfig env => RIO env ()
 generateHpcUnifiedReport = do
@@ -296,7 +296,7 @@ generateHpcUnifiedReport = do
         else do
             let report = "unified report"
             mreportPath <- generateUnionReport report reportDir tixFiles
-            forM_ mreportPath (displayReportPath report)
+            forM_ mreportPath (displayReportPath report . display)
 
 generateUnionReport :: HasEnvConfig env
                     => Text -> Path Abs Dir -> [Path Abs File]
@@ -443,10 +443,10 @@ findPackageFieldForBuiltPackage pkgDir pkgId field = do
                 _ -> return $ Left $ "Multiple files matching " <> T.pack (pkgIdStr ++ "-*.conf") <> " found in " <>
                     T.pack (toFilePath inplaceDir) <> ". Maybe try 'stack clean' on this package?"
 
-displayReportPath :: (HasAnsiAnn (Ann a), Display a, HasRunner env)
-                  => Text -> a -> RIO env ()
+displayReportPath :: (HasRunner env)
+                  => Text -> AnsiDoc -> RIO env ()
 displayReportPath report reportPath =
-     prettyInfo $ "The" <+> fromString (T.unpack report) <+> "is available at" <+> display reportPath
+     prettyInfo $ "The" <+> fromString (T.unpack report) <+> "is available at" <+> reportPath
 
 findExtraTixFiles :: HasEnvConfig env => RIO env [Path Abs File]
 findExtraTixFiles = do

src/Stack/PrettyPrint.hs

@@ -11,7 +11,7 @@ module Stack.PrettyPrint
       -- * Logging based on pretty-print typeclass
     , prettyDebug, prettyInfo, prettyWarn, prettyError
     , prettyDebugL, prettyInfoL, prettyWarnL, prettyErrorL
-    , prettyWarnS, prettyErrorS
+    , prettyDebugS, prettyInfoS, prettyWarnS, prettyErrorS
       -- * Semantic styling functions
       -- | These are preferred to styling or colors directly, so that we can
       -- encourage consistency.
@@ -63,53 +63,43 @@ prettyWith level f = logOther level <=< displayWithColor . f
 
 -- Note: I think keeping this section aligned helps spot errors, might be
 -- worth keeping the alignment in place.
-prettyDebugWith, prettyInfoWith
-  :: (HasCallStack, HasRunner env, Display b, HasAnsiAnn (Ann b),
-      MonadReader env m, MonadLogger m)
-  => (a -> b) -> a -> m ()
-prettyDebugWith = prettyWith LevelDebug
-prettyInfoWith  = prettyWith LevelInfo
 
-prettyWarnWith, prettyErrorWith
+prettyDebugWith, prettyInfoWith, prettyWarnWith, prettyErrorWith
   :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m)
   => (a -> Doc AnsiAnn) -> a -> m ()
+prettyDebugWith = prettyWith LevelDebug
+prettyInfoWith  = prettyWith LevelInfo
 prettyWarnWith f  = prettyWith LevelWarn
                           ((line <>) . (styleWarning "Warning:" <+>) .
                            indentAfterLabel . f)
 prettyErrorWith f = prettyWith LevelError
                           ((line <>) . (styleError   "Error:" <+>) .
                            indentAfterLabel . f)
 
-prettyDebug, prettyInfo
-  :: (HasCallStack, HasRunner env, Display b, HasAnsiAnn (Ann b),
-      MonadReader env m, MonadLogger m)
-  => b -> m ()
-prettyDebug  = prettyDebugWith id
-prettyInfo   = prettyInfoWith  id
-
-prettyWarn, prettyError
+prettyDebug, prettyInfo, prettyWarn, prettyError
   :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m)
   => Doc AnsiAnn -> m ()
+prettyDebug  = prettyDebugWith id
+prettyInfo   = prettyInfoWith  id
 prettyWarn   = prettyWarnWith  id
 prettyError  = prettyErrorWith id
 
-prettyDebugL, prettyInfoL
-  :: (HasCallStack, HasRunner env, HasAnsiAnn a, MonadReader env m, MonadLogger m)
-  => [Doc a] -> m ()
-prettyDebugL = prettyDebugWith fillSep
-prettyInfoL  = prettyInfoWith  fillSep
-
-prettyWarnL, prettyErrorL
+prettyDebugL, prettyInfoL, prettyWarnL, prettyErrorL
   :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m)
   => [Doc AnsiAnn] -> m ()
+prettyDebugL = prettyDebugWith fillSep
+prettyInfoL  = prettyInfoWith  fillSep
 prettyWarnL  = prettyWarnWith  fillSep
 prettyErrorL = prettyErrorWith fillSep
 
-prettyWarnS, prettyErrorS
+prettyDebugS, prettyInfoS, prettyWarnS, prettyErrorS
   :: (HasCallStack, HasRunner env, MonadReader env m, MonadLogger m)
   => String -> m ()
+prettyDebugS = prettyDebugWith flow
+prettyInfoS  = prettyInfoWith  flow
 prettyWarnS  = prettyWarnWith  flow
 prettyErrorS = prettyErrorWith flow
+
 -- End of aligned section
 
 -- | Use after a label and before the rest of what's being labelled for

src/Stack/Upgrade.hs

@@ -26,6 +26,7 @@ import           Stack.Build
 import           Stack.Config
 import           Stack.Fetch
 import           Stack.PackageIndex
+import           Stack.PrettyPrint
 import           Stack.Setup
 import           Stack.Types.PackageIdentifier
 import           Stack.Types.PackageIndex
@@ -116,9 +117,11 @@ upgrade gConfigMonoid mresolver builtHash (UpgradeOpts mbo mso) =
         -- See #2977 - if --git or --git-repo is specified, do source upgrade.
         (_, Just so@(SourceOpts (Just _))) -> source so
         (Just bo, Just so) -> binary bo `catchAny` \e -> do
-            logWarn "Exception occured when trying to perform binary upgrade:"
-            logWarn $ T.pack $ show e
-            logWarn "Falling back to source upgrade"
+            prettyWarnL
+               [ flow "Exception occured when trying to perform binary upgrade:"
+               , fromString . show $ e
+               , line <> flow "Falling back to source upgrade"
+               ]
 
             source so
   where
@@ -141,28 +144,30 @@ binaryUpgrade (BinaryOpts mplatform force' mver morg mrepo) = do
     isNewer <-
         case mdownloadVersion of
             Nothing -> do
-                logError "Unable to determine upstream version from Github metadata"
-                unless force $
-                    logError "Rerun with --force-download to force an upgrade"
+                prettyErrorL $
+                    flow "Unable to determine upstream version from Github metadata"
+                  :
+                  [ line <> flow "Rerun with --force-download to force an upgrade"
+                    | not force]
                 return False
             Just downloadVersion -> do
-                logInfo $ T.concat
-                    [ "Current Stack version: "
-                    , versionText stackVersion
-                    , ", available download version: "
-                    , versionText downloadVersion
+                prettyInfoL
+                    [ flow "Current Stack version:"
+                    , display stackVersion <> ","
+                    , flow "available download version:"
+                    , display downloadVersion
                     ]
                 return $ downloadVersion > stackVersion
 
     toUpgrade <- case (force, isNewer) of
         (False, False) -> do
-            logInfo "Skipping binary upgrade, you are already running the most recent version"
+            prettyInfoS "Skipping binary upgrade, you are already running the most recent version"
             return False
         (True, False) -> do
-            logInfo "Forcing binary upgrade"
+            prettyInfoS "Forcing binary upgrade"
             return True
         (_, True) -> do
-            logInfo "Newer version detected, downloading"
+            prettyInfoS "Newer version detected, downloading"
             return True
     when toUpgrade $ do
         config <- view configL
@@ -191,16 +196,17 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) =
             [] -> throwString $ "No commits found for branch " ++ branch ++ " on repo " ++ repo
             x:_ -> return x
         when (isNothing builtHash) $
-            logWarn $ "Information about the commit this version of stack was "
+            prettyWarnS $
+                       "Information about the commit this version of stack was "
                     <> "built from is not available due to how it was built. "
                     <> "Will continue by assuming an upgrade is needed "
                     <> "because we have no information to the contrary."
         if builtHash == Just latestCommit
             then do
-                logInfo "Already up-to-date, no upgrade required"
+                prettyInfoS "Already up-to-date, no upgrade required"
                 return Nothing
             else do
-                logInfo "Cloning stack"
+                prettyInfoS "Cloning stack"
                 -- NOTE: "--recursive" was added after v1.0.0 (and before the
                 -- next release).  This means that we can't use submodules in
                 -- the stack repo until we're comfortable with "stack upgrade
@@ -221,7 +227,7 @@ sourceUpgrade gConfigMonoid mresolver builtHash (SourceOpts gitRepo) =
         let version = Data.List.maximum versions
         if version <= fromCabalVersion (mkVersion' Paths.version)
             then do
-                logInfo "Already at latest version, no upgrade required"
+                prettyInfoS "Already at latest version, no upgrade required"
                 return Nothing
             else do
                 let ident = PackageIdentifier $(mkPackageName "stack") version