better tui for watch

hakysidian.cabal

@@ -31,6 +31,7 @@ executable hakysidian
                   , array
                   , directory
                   , filepath
+                  , process
                   , time
                   , wai-app-static
                   , warp

src/site.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -7,7 +8,10 @@
 
 import ChaoDoc
 import Control.Concurrent (forkIO, threadDelay)
-import Control.Monad (filterM, unless, void, when)
+import Control.Exception (SomeException, bracket_, try)
+import Control.Monad (filterM, unless, void)
+import Data.Char (isSpace)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.Kind (Type)
 import Data.List (intercalate, isPrefixOf, sort, sortOn)
 import qualified Data.Map.Strict as M
@@ -15,6 +19,8 @@ import Data.Maybe (fromMaybe)
 import Data.String (fromString)
 import qualified Data.Text as T
 import Data.Time.Clock (UTCTime)
+import Data.Time.Format (defaultTimeLocale, formatTime)
+import Data.Time.LocalTime (getZonedTime)
 import Hakyll
 import Hakyll.Core.Runtime (RunMode (RunModeNormal))
 import qualified Network.Wai.Handler.Warp as Warp
@@ -27,10 +33,19 @@ import System.Directory
     getModificationTime,
     listDirectory
   )
-import System.Environment (getArgs)
+import System.Environment (getArgs, getExecutablePath, lookupEnv)
 import System.Exit (ExitCode (..), die, exitSuccess, exitWith)
 import System.FilePath
 import Network.Wai.Application.Static (staticApp)
+import System.IO
+  ( BufferMode (NoBuffering),
+    hFlush,
+    hGetBuffering,
+    hIsTerminalDevice,
+    hSetBuffering,
+    stdout
+  )
+import System.Process (CreateProcess (cwd), proc, readCreateProcessWithExitCode)
 import Text.Pandoc (HTMLMathMethod (MathML), WriterOptions (..), compileTemplate)
 import Text.Read (readMaybe)
 
@@ -89,6 +104,30 @@ data CliCommand
 type FileSnapshot :: Type
 type FileSnapshot = M.Map FilePath UTCTime
 
+type ServerStatus :: Type
+data ServerStatus
+  = ServerDisabled
+  | ServerStarting
+  | ServerRunning
+  | ServerFailed String
+  deriving stock (Eq)
+
+type DashboardState :: Type
+data DashboardState = DashboardState
+  { dashboardStatus :: String,
+    dashboardLastChange :: String,
+    dashboardLastBuild :: String,
+    dashboardLogLines :: [String]
+  }
+  deriving stock (Eq)
+
+type TerminalSize :: Type
+data TerminalSize = TerminalSize
+  { terminalRows :: Int,
+    terminalCols :: Int
+  }
+  deriving stock (Eq)
+
 --------------------------------------------------------------------------------
 -- https://www.rohanjain.in/hakyll-clean-urls/
 cleanRoute :: Routes
@@ -196,41 +235,17 @@ validateProject projectRoot = do
         "hakysidian is missing required project inputs:" :
         map ("  - " ++) missing
 
-renderWatchPanel :: FilePath -> Configuration -> WatchSettings -> IO ()
+initialDashboardState :: DashboardState
-renderWatchPanel projectRoot config watchSettings = do
+initialDashboardState =
-  notesExists <- doesDirectoryExist (projectRoot </> "notes")
+  DashboardState
-  bibExists <- doesFileExist (projectRoot </> "reference.bib")
+    { dashboardStatus = "starting",
-  macrosExists <- doesFileExist (projectRoot </> "math-macros.md")
+      dashboardLastChange = "waiting for first build",
-  imagesExists <- doesDirectoryExist (projectRoot </> "images")
+      dashboardLastBuild = "pending",
-  let urlText = fromMaybe "disabled (--no-server)" (watchUrl watchSettings)
+      dashboardLogLines =
-      statusText =
+        [ "watcher ready",
-        "notes="
+          "watching notes/, reference.bib, math-macros.md, images/ (optional)"
-          ++ presentStatus notesExists
-          ++ ", bib="
-          ++ presentStatus bibExists
-          ++ ", macros="
-          ++ presentStatus macrosExists
-          ++ ", images="
-          ++ optionalStatus imagesExists
-  mapM_
-    putStrLn
-    [ "------------------------------------------------------------",
-      "hakysidian watch",
-      "project  : " ++ projectRoot,
-      "output   : " ++ destinationDirectory config,
-      "url      : " ++ urlText,
-      "watching : notes/, reference.bib, math-macros.md, images/ (optional)",
-      "status   : " ++ statusText,
-      "------------------------------------------------------------"
         ]
-
+    }
-presentStatus :: Bool -> String
-presentStatus True = "ok"
-presentStatus False = "missing"
-
-optionalStatus :: Bool -> String
-optionalStatus True = "present"
-optionalStatus False = "absent"
 
 parseWatchSettings :: Configuration -> [String] -> WatchSettings
 parseWatchSettings config args =
@@ -272,6 +287,177 @@ extractOptionValue option = go
       | optionPrefix `isPrefixOf` arg = Just (drop (length optionPrefix) arg)
       | otherwise = go (value : rest)
 
+withWatchTui :: IO a -> IO a
+withWatchTui action = do
+  interactive <- hIsTerminalDevice stdout
+  if interactive
+    then do
+      originalBuffering <- hGetBuffering stdout
+      bracket_
+        (do
+            hSetBuffering stdout NoBuffering
+            putStr "\ESC[?1049h\ESC[2J\ESC[H\ESC[?25l"
+            hFlush stdout)
+        (do
+            putStr "\ESC[0m\ESC[?25h\ESC[?1049l"
+            hFlush stdout
+            hSetBuffering stdout originalBuffering)
+        action
+    else action
+
+renderWatchDashboard ::
+  IORef (Maybe (TerminalSize, ServerStatus, DashboardState)) ->
+  FilePath ->
+  Configuration ->
+  WatchSettings ->
+  IORef ServerStatus ->
+  DashboardState ->
+  IO ()
+renderWatchDashboard renderStateRef projectRoot config watchSettings serverStatusRef dashboard = do
+  terminalSize <- getTerminalSize
+  serverStatus <- readIORef serverStatusRef
+  previousRenderState <- readIORef renderStateRef
+  let currentRenderState = Just (terminalSize, serverStatus, dashboard)
+  unless (currentRenderState == previousRenderState) do
+    let rows = max 1 (terminalRows terminalSize)
+        cols = max 4 (terminalCols terminalSize)
+        border = "+" ++ replicate (cols - 2) '-' ++ "+"
+        infoRows =
+          [ dashboardRow cols ("Project : " ++ projectRoot),
+            dashboardRow cols ("Output  : " ++ destinationDirectory config),
+            dashboardRow cols ("Preview : " ++ renderServerStatus watchSettings serverStatus),
+            dashboardRow cols "Watch   : notes/, reference.bib, math-macros.md, images/ (optional)",
+            dashboardRow cols ("Change  : " ++ dashboardLastChange dashboard),
+            dashboardRow cols ("Build   : " ++ dashboardLastBuild dashboard)
+          ]
+        headerRows =
+          [ border,
+            dashboardTitleRow cols "hakysidian watch" (dashboardStatus dashboard),
+            border
+          ]
+            ++ infoRows
+            ++ [border, dashboardRow cols "Recent activity", border]
+        footerRows = [border]
+        availableLogRows = max 1 (rows - length headerRows - length footerRows)
+        logRows =
+          map (dashboardRow cols) $
+            padRows availableLogRows $
+              takeLast availableLogRows (dashboardLogLines dashboard)
+        screenRows = take rows (headerRows ++ logRows ++ footerRows)
+    putStr "\ESC[2J\ESC[H"
+    putStr (unlines screenRows)
+    hFlush stdout
+    writeIORef renderStateRef currentRenderState
+
+dashboardTitleRow :: Int -> String -> String -> String
+dashboardTitleRow width leftText rightText =
+  dashboardFramedRow width (leftText ++ spacer ++ clippedRight)
+  where
+    usableWidth = max 1 (width - 4)
+    rightWidth = min (usableWidth `div` 3) (length rightText)
+    clippedRight =
+      if null rightText
+        then ""
+        else ellipsize rightWidth rightText
+    leftWidth = max 1 (usableWidth - length clippedRight - 1)
+    clippedLeft = ellipsize leftWidth leftText
+    spacer
+      | null clippedRight = ""
+      | otherwise = replicate (max 1 (usableWidth - length clippedLeft - length clippedRight)) ' '
+
+dashboardRow :: Int -> String -> String
+dashboardRow width = dashboardFramedRow width
+
+dashboardFramedRow :: Int -> String -> String
+dashboardFramedRow width content =
+  "| " ++ padRight usableWidth (ellipsize usableWidth content) ++ " |"
+  where
+    usableWidth = max 1 (width - 4)
+
+padRight :: Int -> String -> String
+padRight width text = text ++ replicate (max 0 (width - length text)) ' '
+
+padRows :: Int -> [String] -> [String]
+padRows count rows =
+  rows ++ replicate (max 0 (count - length rows)) ""
+
+takeLast :: Int -> [a] -> [a]
+takeLast count xs = drop (max 0 (length xs - count)) xs
+
+ellipsize :: Int -> String -> String
+ellipsize width text
+  | width <= 0 = ""
+  | length text <= width = text
+  | width <= 3 = take width text
+  | otherwise = take (width - 3) text ++ "..."
+
+renderServerStatus :: WatchSettings -> ServerStatus -> String
+renderServerStatus watchSettings serverStatus = case serverStatus of
+  ServerDisabled -> "disabled (--no-server)"
+  ServerStarting -> maybe "starting" (++ " (starting)") (watchUrl watchSettings)
+  ServerRunning -> fromMaybe "running" (watchUrl watchSettings)
+  ServerFailed err ->
+    "failed: " ++ err
+
+getTerminalSize :: IO TerminalSize
+getTerminalSize = do
+  sttySize <- queryTerminalSize
+  case sttySize of
+    Just terminalSize -> pure terminalSize
+    Nothing -> do
+      rows <- maybe 24 id . (>>= readMaybe) <$> lookupEnv "LINES"
+      cols <- maybe 80 id . (>>= readMaybe) <$> lookupEnv "COLUMNS"
+      pure (TerminalSize rows cols)
+
+queryTerminalSize :: IO (Maybe TerminalSize)
+queryTerminalSize = do
+  result <-
+    try $
+      readCreateProcessWithExitCode
+        (proc "sh" ["-c", "stty size </dev/tty"])
+        "" :: IO (Either SomeException (ExitCode, String, String))
+  pure $ do
+    (exitCode, stdoutText, _) <- either (const Nothing) Just result
+    case exitCode of
+      ExitSuccess -> case words stdoutText of
+        [rowsText, colsText] -> do
+          rows <- readMaybe rowsText
+          cols <- readMaybe colsText
+          Just (TerminalSize rows cols)
+        _ -> Nothing
+      ExitFailure _ -> Nothing
+
+watchTimestamp :: IO String
+watchTimestamp = formatTime defaultTimeLocale "%H:%M:%S" <$> getZonedTime
+
+trimTrailingSpace :: String -> String
+trimTrailingSpace = reverse . dropWhile isSpace . reverse
+
+normalizeLogLines :: String -> String -> [String]
+normalizeLogLines stdoutText stderrText =
+  filter (not . null) $
+    map trimTrailingSpace $
+      lines (stdoutText ++ if null stderrText then "" else "\n" ++ stderrText)
+
+appendLogBatch :: DashboardState -> String -> String -> [String] -> DashboardState
+appendLogBatch dashboard title timestamp buildLines =
+  dashboard
+    { dashboardLogLines =
+        takeLast 200 $
+          dashboardLogLines dashboard
+            ++ ("[" ++ timestamp ++ "] " ++ title)
+            : map ("  " ++) buildLines
+    }
+
+runCapturedSiteCommand :: FilePath -> String -> IO (ExitCode, [String])
+runCapturedSiteCommand projectRoot command = do
+  executablePath <- getExecutablePath
+  (exitCode, stdoutText, stderrText) <-
+    readCreateProcessWithExitCode
+      (proc executablePath [command]) {cwd = Just projectRoot}
+      ""
+  pure (exitCode, normalizeLogLines stdoutText stderrText)
+
 buildOptions :: Options
 buildOptions = Options {verbosity = False, optCommand = Build RunModeNormal}
 
@@ -286,47 +472,126 @@ runSiteCommand config options cslPath =
   hakyllWithExitCodeAndArgs config options (siteRules cslPath)
 
 runWatch :: FilePath -> Configuration -> FilePath -> WatchSettings -> IO ExitCode
-runWatch projectRoot config cslPath watchSettings = do
+runWatch projectRoot config _cslPath watchSettings =
-  renderWatchPanel projectRoot config watchSettings
+  withWatchTui do
-  initialExit <- runSiteCommand config buildOptions cslPath
+    serverStatusRef <- newIORef initialServerStatus
-  when (initialExit /= ExitSuccess) $
+    renderStateRef <- newIORef Nothing
-    putStrLn "build    : initial build failed; continuing to watch for changes"
+    startPreviewServer config watchSettings serverStatusRef
-  startPreviewServer config watchSettings
+    renderWatchDashboard renderStateRef projectRoot config watchSettings serverStatusRef initialDashboardState
+    (_, initialDashboard) <-
+      runWatchBuild
+        "build"
+        "initial build"
+        "initial build"
+        projectRoot
+        config
+        watchSettings
+        renderStateRef
+        serverStatusRef
+        initialDashboardState
     initialSnapshot <- snapshotInputs projectRoot
-  watchLoop initialSnapshot
+    watchLoop renderStateRef serverStatusRef initialSnapshot initialDashboard
   where
-    watchLoop :: FileSnapshot -> IO ExitCode
+    initialServerStatus
-    watchLoop previousSnapshot = do
+      | watchServerEnabled watchSettings = ServerStarting
+      | otherwise = ServerDisabled
+
+    watchLoop ::
+      IORef (Maybe (TerminalSize, ServerStatus, DashboardState)) ->
+      IORef ServerStatus ->
+      FileSnapshot ->
+      DashboardState ->
+      IO ExitCode
+    watchLoop renderStateRef serverStatusRef previousSnapshot dashboard = do
+      renderWatchDashboard renderStateRef projectRoot config watchSettings serverStatusRef dashboard
       threadDelay 1000000
       nextSnapshot <- snapshotInputs projectRoot
       if nextSnapshot == previousSnapshot
-        then watchLoop previousSnapshot
+        then watchLoop renderStateRef serverStatusRef previousSnapshot dashboard
         else do
           let changedFiles = diffSnapshots previousSnapshot nextSnapshot
-              options =
+              command :: String
+              command =
                 if any (`M.notMember` nextSnapshot) (M.keys previousSnapshot)
-                  then rebuildOptions
+                  then "rebuild"
-                  else buildOptions
+                  else "build"
-          putStrLn ("change   : " ++ intercalate ", " changedFiles)
+              changeSummary = intercalate ", " changedFiles
-          buildExit <- runSiteCommand config options cslPath
+          (_, nextDashboard) <-
-          putStrLn ("build    : " ++ renderBuildResult buildExit)
+            runWatchBuild
-          watchLoop nextSnapshot
+              command
+              command
+              changeSummary
+              projectRoot
+              config
+              watchSettings
+              renderStateRef
+              serverStatusRef
+              dashboard
+          watchLoop renderStateRef serverStatusRef nextSnapshot nextDashboard
 
 renderBuildResult :: ExitCode -> String
 renderBuildResult ExitSuccess = "success"
 renderBuildResult (ExitFailure code) = "failed (" ++ show code ++ ")"
 
-startPreviewServer :: Configuration -> WatchSettings -> IO ()
+runWatchBuild ::
-startPreviewServer config watchSettings
+  String ->
+  String ->
+  String ->
+  FilePath ->
+  Configuration ->
+  WatchSettings ->
+  IORef (Maybe (TerminalSize, ServerStatus, DashboardState)) ->
+  IORef ServerStatus ->
+  DashboardState ->
+  IO (ExitCode, DashboardState)
+runWatchBuild command label changeSummary projectRoot config watchSettings renderStateRef serverStatusRef dashboard = do
+  startedAt <- watchTimestamp
+  let runningDashboard =
+        dashboard
+          { dashboardStatus = "building (" ++ label ++ ")",
+            dashboardLastChange = changeSummary,
+            dashboardLastBuild = "running since " ++ startedAt
+          }
+  renderWatchDashboard renderStateRef projectRoot config watchSettings serverStatusRef runningDashboard
+  (exitCode, buildLines) <- runCapturedSiteCommand projectRoot command
+  finishedAt <- watchTimestamp
+  let loggedDashboard =
+        appendLogBatch runningDashboard (label ++ ": " ++ changeSummary) finishedAt buildLines
+      completedDashboard =
+        loggedDashboard
+          { dashboardStatus =
+              if exitCode == ExitSuccess
+                then "watching"
+                else "watching after failed " ++ label,
+            dashboardLastBuild =
+              renderBuildResult exitCode
+                ++ " at "
+                ++ finishedAt
+                ++ " via "
+                ++ label
+          }
+  renderWatchDashboard renderStateRef projectRoot config watchSettings serverStatusRef completedDashboard
+  pure (exitCode, completedDashboard)
+
+startPreviewServer :: Configuration -> WatchSettings -> IORef ServerStatus -> IO ()
+startPreviewServer config watchSettings serverStatusRef
   | watchServerEnabled watchSettings =
       void $
         forkIO $
+          do
+            result <-
+              (try $
                  Warp.runSettings settings $
                    staticApp $
-              previewSettings config (destinationDirectory config)
+                     previewSettings config (destinationDirectory config)) ::
-  | otherwise = pure ()
+                IO (Either SomeException ())
+            case result of
+              Left err -> writeIORef serverStatusRef (ServerFailed (show err))
+              Right () -> pure ()
+  | otherwise = writeIORef serverStatusRef ServerDisabled
   where
     settings =
+      Warp.setBeforeMainLoop (writeIORef serverStatusRef ServerRunning) $
       Warp.setPort (watchPort watchSettings) $
         Warp.setHost (fromString (watchHost watchSettings)) $
           Warp.defaultSettings