better progress bar

src/Psb/Main.hs

@@ -21,7 +21,7 @@ import Development.Shake.FilePath ((</>))
 import qualified Development.Shake.FilePath as FP
 import Templates
 import Types
-import Utilities.Action (getPublishedPosts, isDraft', markdownToHtml, markdownToPost, now)
+import Utilities.Action (getPublishedPosts, isDraft', markdownToHtml, markdownToPost, now, psbProgress)
 import Utilities.FilePath (indexHtmlOutputPath, indexHtmlSourcePaths, isMarkdownPost, urlConvert)
 
 -- target = thing we want
@@ -31,7 +31,12 @@ import Utilities.FilePath (indexHtmlOutputPath, indexHtmlSourcePaths, isMarkdown
 -- note: live watch should be done outside of shake with the watcher then running shake which is rather annoying
 main :: IO ()
 main = do
-  Shake.shakeArgs Shake.shakeOptions {Shake.shakeProgress = psbProgress} $ do
+  Shake.shakeArgs
+    Shake.shakeOptions
+      { Shake.shakeProgress = psbProgress,
+        Shake.shakeColor = True
+      }
+    $ do
       Shake.withTargetDocs "Build the site" $
         "build" ~> buildSite
       Shake.withTargetDocs "Clean the built site" $
@@ -169,6 +174,3 @@ postHandles = [(isMarkdownPost, markdownToPost)]
 
 isDraft :: FilePath -> Action Bool
 isDraft = isDraft' postHandles
-
-psbProgress :: IO Shake.Progress -> IO ()
-psbProgress = Shake.progressDisplay 0.01 putStrLn

src/Utilities/Action.hs

@@ -1,19 +1,25 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Utilities.Action where
 
 import Config (postGlobs)
 import Control.Monad (filterM)
 import Data.Functor.Identity (Identity (runIdentity))
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.List (find)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding (encodeUtf8)
+import qualified Data.Text.IO as TIO
 import Data.Time (getCurrentTime)
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Yaml.Aeson
 import Development.Shake (Action)
 import qualified Development.Shake as Shake
+import GHC.IO (unsafePerformIO)
 import HTML
 import Markdown
+import System.IO (hFlush, hPutStr, stderr)
 import Text.Megaparsec (errorBundlePretty, runParserT)
 import Types
 
@@ -60,3 +66,14 @@ getPublishedPosts :: (FilePath -> Action Bool) -> Action [FilePath]
 getPublishedPosts draftCheck = do
   postPaths <- Shake.getDirectoryFiles "" postGlobs
   filterM (fmap not . draftCheck) postPaths
+
+psbProgress :: IO Shake.Progress -> IO ()
+psbProgress getProgress = do
+  Shake.progressDisplay 0.01 psbProgress' getProgress
+  where
+    psbProgress' msg = do
+      TIO.hPutStr stderr "\x1b[K\r"
+      hPutStr stderr msg
+      hFlush stderr
+      p <- getProgress
+      if (Shake.countTodo p + Shake.countUnknown p) < 5 then putStrLn "" else pure ()