From 0080bed0bc6ee4f2f0714c214bee42131f023f11 Mon Sep 17 00:00:00 2001
From: Andreas Klebinger <klebinger.andreas@gmx.at>
Date: Thu, 3 Oct 2024 14:50:46 +0200
Subject: [PATCH] Adjust progress message for hadrian to include cwd.
Fixes #25335
---
hadrian/hadrian.cabal | 1 +
hadrian/src/Main.hs | 3 ++-
hadrian/src/Progress.hs | 14 ++++++++++++++
3 files changed, 17 insertions(+), 1 deletion(-)
create mode 100644 hadrian/src/Progress.hs
diff --git a/hadrian/hadrian.cabal b/hadrian/hadrian.cabal
index e6d168cfe0d6..496ced64234f 100644
--- a/hadrian/hadrian.cabal
+++ b/hadrian/hadrian.cabal
@@ -74,6 +74,7 @@ executable hadrian
, Oracles.ModuleFiles
, Oracles.TestSettings
, Packages
+ , Progress
, Rules
, Rules.BinaryDist
, Rules.CabalReinstall
diff --git a/hadrian/src/Main.hs b/hadrian/src/Main.hs
index f2eeb8f0b710..51f1600f9bba 100644
--- a/hadrian/src/Main.hs
+++ b/hadrian/src/Main.hs
@@ -27,6 +27,7 @@ import qualified Rules.Selftest
import qualified Rules.SourceDist
import qualified Rules.Test
import qualified UserSettings
+import qualified Progress
main :: IO ()
main = do
@@ -56,7 +57,7 @@ main = do
options = shakeOptions
{ shakeChange = ChangeModtimeAndDigest
, shakeFiles = buildRoot -/- Base.shakeFilesDir
- , shakeProgress = progressSimple
+ , shakeProgress = Progress.hadrianProgress (cwd -/- "hadrian > " <> buildRoot <> ":")
, shakeRebuild = rebuild
, shakeTimings = False
, shakeColor = shakeColor
diff --git a/hadrian/src/Progress.hs b/hadrian/src/Progress.hs
new file mode 100644
index 000000000000..39cf3a2adb7d
--- /dev/null
+++ b/hadrian/src/Progress.hs
@@ -0,0 +1,14 @@
+module Progress (hadrianProgress) where
+
+import Development.Shake
+
+-- | A simple method for displaying progress messages, suitable for using as 'Development.Shake.shakeProgress'.
+-- This is the shakeProgress function hadrian uses. It writes the current progress to the titlebar every five seconds
+-- using 'progressTitlebar', and calls any @shake-progress@ program on the @$PATH@ using 'progressProgram'.
+--
+-- Unlike the default shake progress bar it includes a prefix for the status bar.
+hadrianProgress :: String -> IO Progress -> IO ()
+hadrianProgress prefix p = do
+ program <- progressProgram
+ progressDisplay 5 (\status -> let s = prefix <> status in progressTitlebar s >> program s) p
+
--
GitLab