Expose the status of currently-running tasks

src/Control/Effect/Diagnostics.hs

@@ -39,13 +39,14 @@ where
 
 import Control.Algebra as X
 import Control.Exception (SomeException (..))
+import Data.List (intersperse)
 import qualified Data.List.NonEmpty as NE
 import Data.Maybe (catMaybes)
 import Data.Semigroup (sconcat)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Prettyprint.Doc
-import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle)
+import Data.Text.Prettyprint.Doc.Render.Terminal
 import Prelude
 
 data Diagnostics m k where
@@ -146,19 +147,26 @@ instance Show FailureBundle where
 renderFailureBundle :: FailureBundle -> Doc AnsiStyle
 renderFailureBundle FailureBundle {..} =
   vsep
-    [ "----------",
-      "An error occurred:",
+    [ annotate (color Yellow) "----------",
+      annotate (color Yellow) "An error occurred:",
       "",
-      indent 4 (align (renderSomeDiagnostic failureCause)),
+      indent 4 (renderSomeDiagnostic failureCause),
       "",
       ">>>",
-      indent 2 "Relevant warnings include:",
       "",
-      indent 4 (align (renderWarnings failureWarnings))
+      indent 2 (annotate (color Yellow) "Relevant warnings include:"),
+      "",
+      indent 4 (renderWarnings failureWarnings)
     ]
 
 renderSomeDiagnostic :: SomeDiagnostic -> Doc AnsiStyle
-renderSomeDiagnostic (SomeDiagnostic stack cause) = renderDiagnostic cause <> line <> align (indent 2 (vsep (map (pretty . ("when " <>)) stack)))
+renderSomeDiagnostic (SomeDiagnostic stack cause) =
+  renderDiagnostic cause
+    <> line
+    <> line
+    <> annotate (color Cyan) "Traceback:"
+    <> line
+    <> indent 2 (vsep (map (pretty . ("- " <>)) stack))
 
 renderWarnings :: [SomeDiagnostic] -> Doc AnsiStyle
-renderWarnings = align . vsep . map renderSomeDiagnostic
+renderWarnings = vsep . intersperse (line <> "--" <> line) . map renderSomeDiagnostic

src/Effect/Exec.hs

@@ -40,7 +40,7 @@ import Data.String (fromString)
 import Data.String.Conversion (decodeUtf8)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Prettyprint.Doc (pretty, viaShow)
+import Data.Text.Prettyprint.Doc (pretty, viaShow, vsep, line, indent)
 import Data.Void (Void)
 import GHC.Generics (Generic)
 import Path
@@ -129,7 +129,20 @@ data ExecErr
 
 instance ToDiagnostic ExecErr where
   renderDiagnostic = \case
-    CommandFailed err -> "Command execution failed: " <> viaShow err
+    CommandFailed err ->
+      "Command execution failed: "
+        <> line
+        <> indent
+          4
+          ( vsep
+              [ "command: " <> pretty (cmdFailureName err)
+              , "args: " <> pretty (cmdFailureArgs err)
+              , "dir: " <> pretty (cmdFailureDir err)
+              , "exit: " <> viaShow (cmdFailureExit err)
+              , "stdout: " <> line <> indent 2 (pretty @Text (decodeUtf8 (cmdFailureStdout err)))
+              , "stderr: " <> line <> indent 2 (pretty @Text (decodeUtf8 (cmdFailureStderr err)))
+              ]
+          )
     CommandParseError cmd err -> "Failed to parse command output. command: " <> viaShow cmd <> " . error: " <> pretty err
 
 -- | Execute a command and return its @(exitcode, stdout, stderr)@
@@ -156,7 +169,7 @@ execJson dir cmd = do
 
 -- | A variant of 'exec' that throws a 'ExecErr' when the command returns a non-zero exit code
 execThrow :: (Has Exec sig m, Has Diagnostics sig m) => Path x Dir -> Command -> m BL.ByteString
-execThrow dir cmd = context ("Running command: " <> T.pack (show cmd)) $ do
+execThrow dir cmd = context ("Running command '" <> cmdName cmd <> "'") $ do
   result <- exec dir cmd
   case result of
     Left failure -> fatal (CommandFailed failure)

src/Effect/Logger.hs

@@ -111,7 +111,7 @@ termLoggerFormatter :: LogFormatter
 termLoggerFormatter sev msg = renderIt $ formatCommon sev msg <> line
 
 formatCommon :: Severity -> Doc AnsiStyle -> Doc AnsiStyle
-formatCommon sev msg = pretty '[' <> showSev sev <> pretty @String "] " <> msg
+formatCommon sev msg = hang 2 (pretty '[' <> showSev sev <> pretty @String "] " <> msg)
   where
     showSev SevError = annotate (color Red) (pretty @String "ERROR")
     showSev SevWarn = annotate (color Yellow) (pretty @String " WARN")

src/Effect/ReadFS.hs

@@ -60,7 +60,7 @@ import Data.Kind (Type)
 import Data.String.Conversion (decodeUtf8)
 import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Prettyprint.Doc (pretty)
+import Data.Text.Prettyprint.Doc (pretty, line, indent, vsep)
 import Data.Void (Void)
 import Data.Yaml (decodeEither', prettyPrintParseException)
 import GHC.Generics (Generic)
@@ -100,10 +100,19 @@ $(deriveReplayable ''ReadFS)
 
 instance ToDiagnostic ReadFSErr where
   renderDiagnostic = \case
-    FileReadError path err -> "Error reading file " <> pretty path <> " : " <> pretty err
-    FileParseError path err -> "Error parsing file " <> pretty path <> " : " <> pretty err
-    ResolveError base rel err -> "Error resolving a relative file. base: " <> pretty base <> " . relative: " <> pretty rel <> " . error: " <> pretty err
-    ListDirError dir err -> "Error listing directory contents at " <> pretty dir <> " : " <> pretty err
+    FileReadError path err -> "Error reading file " <> pretty path <> ":" <> line <> indent 4 (pretty err)
+    FileParseError path err -> "Error parsing file " <> pretty path <> ":" <> line <> indent 4 (pretty err)
+    ResolveError base rel err ->
+      "Error resolving a relative file:" <> line
+        <> indent
+          4
+          ( vsep
+              [ "base: " <> pretty base
+              , "relative: " <> pretty rel
+              , "error: " <> pretty err
+              ]
+          )
+    ListDirError dir err -> "Error listing directory contents at " <> pretty dir <> ":" <> line <> indent 2 (pretty err)
 
 -- | Read file contents into a strict 'ByteString'
 readContentsBS' :: Has ReadFS sig m => Path b File -> m (Either ReadFSErr ByteString)

src/Strategy/Gradle.hs

@@ -79,15 +79,15 @@ findProjects = walk' $ \dir _ files -> do
     Just _ -> do
 
       projectsStdout <- errorBoundary .
-        context ("getting gradle projects rooted at " <> pathToText dir) $
+        context ("Listing gradle projects at " <> pathToText dir) $
           execThrow dir (gradleProjectsCmd (pathToText dir <> "gradlew"))
             <||> execThrow dir (gradleProjectsCmd (pathToText dir <> "gradlew.bat"))
             <||> execThrow dir (gradleProjectsCmd "gradle")
 
       case projectsStdout of
         Left err -> do
           logWarn $ renderFailureBundle err
-          pure ([], WalkContinue)
+          pure ([], WalkSkipAll)
         Right result -> do
           let subprojects = parseProjects result