Add Unix and enable stdin-driven quit in watch TUI

hakysidian.cabal

@@ -33,6 +33,7 @@ executable hakysidian
                   , filepath
                   , process
                   , time
+                  , unix
                   , wai-app-static
                   , warp
                   -- , ghc-syntax-highlighter

src/site.hs

@@ -8,7 +8,7 @@
 import ChaoDoc
 import Control.Concurrent (forkIO, threadDelay)
 import Control.Exception (SomeException, bracket_, try)
-import Control.Monad (filterM, unless, void)
+import Control.Monad (filterM, unless, void, when)
 import Data.Char (isSpace)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.Kind (Type)
@@ -40,10 +40,24 @@ import System.IO
   ( BufferMode (NoBuffering),
     hFlush,
     hGetBuffering,
+    hGetChar,
     hIsTerminalDevice,
     hSetBuffering,
+    hWaitForInput,
+    stdin,
     stdout,
   )
+import System.Posix.IO (stdInput)
+import System.Posix.Terminal
+  ( TerminalAttributes,
+    TerminalMode (EnableEcho, ProcessInput),
+    TerminalState (Immediately),
+    getTerminalAttributes,
+    setTerminalAttributes,
+    withMinInput,
+    withTime,
+    withoutMode,
+  )
 import System.Process (CreateProcess (cwd), proc, readCreateProcessWithExitCode)
 import Text.Pandoc (HTMLMathMethod (MathML), WriterOptions (..), compileTemplate)
 import Text.Read (readMaybe)
@@ -288,24 +302,54 @@ extractOptionValue option = go
 
 withWatchTui :: IO a -> IO a
 withWatchTui action = do
-  interactive <- hIsTerminalDevice stdout
+  stdoutInteractive <- hIsTerminalDevice stdout
-  if interactive
+  stdinInteractive <- hIsTerminalDevice stdin
+  if stdoutInteractive
     then do
       originalBuffering <- hGetBuffering stdout
+      originalInputBuffering <- hGetBuffering stdin
+      originalInputMode <-
+        if stdinInteractive
+          then Just <$> getTerminalAttributes stdInput
+          else pure Nothing
       bracket_
         ( do
             hSetBuffering stdout NoBuffering
+            when stdinInteractive do
+              hSetBuffering stdin NoBuffering
+              maybe
+                (pure ())
+                (\inputMode -> setTerminalAttributes stdInput (watchInputMode inputMode) Immediately)
+                originalInputMode
             putStr "\ESC[?1049h\ESC[2J\ESC[H\ESC[?25l"
             hFlush stdout
         )
         ( do
             putStr "\ESC[0m\ESC[?25h\ESC[?1049l"
             hFlush stdout
+            maybe
+              (pure ())
+              (\inputMode -> setTerminalAttributes stdInput inputMode Immediately)
+              originalInputMode
+            when stdinInteractive do
+              hSetBuffering stdin originalInputBuffering
             hSetBuffering stdout originalBuffering
         )
         action
     else action
 
+watchInputMode :: TerminalAttributes -> TerminalAttributes
+watchInputMode inputMode =
+  withTime
+    ( withMinInput
+        ( withoutMode
+            (withoutMode inputMode ProcessInput)
+            EnableEcho
+        )
+        1
+    )
+    0
+
 renderWatchDashboard ::
   IORef (Maybe (TerminalSize, ServerStatus, DashboardState)) ->
   FilePath ->
@@ -338,7 +382,11 @@ renderWatchDashboard renderStateRef projectRoot config watchSettings serverStatu
           ]
             ++ infoRows
             ++ [border, dashboardRow cols "Recent activity", border]
-        footerRows = [border]
+        footerRows =
+          [ border,
+            dashboardRow cols "Controls: q quit, Ctrl-C interrupt",
+            border
+          ]
         availableLogRows = max 1 (rows - length headerRows - length footerRows)
         logRows =
           map (dashboardRow cols) $
@@ -429,6 +477,38 @@ queryTerminalSize = do
 watchTimestamp :: IO String
 watchTimestamp = formatTime defaultTimeLocale "%H:%M:%S" <$> getZonedTime
 
+watchLoopDelayMicros :: Int
+watchLoopDelayMicros = 1000000
+
+watchInputPollMicros :: Int
+watchInputPollMicros = 100000
+
+waitForWatchQuit :: Bool -> Int -> IO Bool
+waitForWatchQuit watchInputEnabled remainingMicros
+  | remainingMicros <= 0 = pure False
+  | otherwise = do
+      shouldQuit <- pollWatchQuit watchInputEnabled
+      if shouldQuit
+        then pure True
+        else do
+          threadDelay (min watchInputPollMicros remainingMicros)
+          waitForWatchQuit watchInputEnabled (remainingMicros - watchInputPollMicros)
+
+pollWatchQuit :: Bool -> IO Bool
+pollWatchQuit watchInputEnabled
+  | not watchInputEnabled = pure False
+  | otherwise = drainInput
+  where
+    drainInput = do
+      hasInput <- hWaitForInput stdin 0
+      if hasInput
+        then do
+          inputChar <- hGetChar stdin
+          if inputChar == 'q'
+            then pure True
+            else drainInput
+        else pure False
+
 trimTrailingSpace :: String -> String
 trimTrailingSpace = reverse . dropWhile isSpace . reverse
 
@@ -471,7 +551,10 @@ runSiteCommand config options cslPath =
   hakyllWithExitCodeAndArgs config options (siteRules cslPath)
 
 runWatch :: FilePath -> Configuration -> FilePath -> WatchSettings -> IO ExitCode
-runWatch projectRoot config _cslPath watchSettings =
+runWatch projectRoot config _cslPath watchSettings = do
+  stdoutInteractive <- hIsTerminalDevice stdout
+  stdinInteractive <- hIsTerminalDevice stdin
+  let watchInputEnabled = stdoutInteractive && stdinInteractive
   withWatchTui do
     serverStatusRef <- newIORef initialServerStatus
     renderStateRef <- newIORef Nothing
@@ -489,44 +572,48 @@ runWatch projectRoot config _cslPath watchSettings =
         serverStatusRef
         initialDashboardState
     initialSnapshot <- snapshotInputs projectRoot
-    watchLoop renderStateRef serverStatusRef initialSnapshot initialDashboard
+    watchLoop watchInputEnabled renderStateRef serverStatusRef initialSnapshot initialDashboard
   where
     initialServerStatus
       | watchServerEnabled watchSettings = ServerStarting
       | otherwise = ServerDisabled
 
     watchLoop ::
+      Bool ->
       IORef (Maybe (TerminalSize, ServerStatus, DashboardState)) ->
       IORef ServerStatus ->
       FileSnapshot ->
       DashboardState ->
       IO ExitCode
-    watchLoop renderStateRef serverStatusRef previousSnapshot dashboard = do
+    watchLoop watchInputEnabled renderStateRef serverStatusRef previousSnapshot dashboard = do
       renderWatchDashboard renderStateRef projectRoot config watchSettings serverStatusRef dashboard
-      threadDelay 1000000
+      shouldQuit <- waitForWatchQuit watchInputEnabled watchLoopDelayMicros
-      nextSnapshot <- snapshotInputs projectRoot
+      if shouldQuit
-      if nextSnapshot == previousSnapshot
+        then pure ExitSuccess
-        then watchLoop renderStateRef serverStatusRef previousSnapshot dashboard
         else do
-          let changedFiles = diffSnapshots previousSnapshot nextSnapshot
+          nextSnapshot <- snapshotInputs projectRoot
-              command :: String
+          if nextSnapshot == previousSnapshot
-              command =
+            then watchLoop watchInputEnabled renderStateRef serverStatusRef previousSnapshot dashboard
-                if any (`M.notMember` nextSnapshot) (M.keys previousSnapshot)
+            else do
-                  then "rebuild"
+              let changedFiles = diffSnapshots previousSnapshot nextSnapshot
-                  else "build"
+                  command :: String
-              changeSummary = intercalate ", " changedFiles
+                  command =
-          (_, nextDashboard) <-
+                    if any (`M.notMember` nextSnapshot) (M.keys previousSnapshot)
-            runWatchBuild
+                      then "rebuild"
-              command
+                      else "build"
-              command
+                  changeSummary = intercalate ", " changedFiles
-              changeSummary
+              (_, nextDashboard) <-
-              projectRoot
+                runWatchBuild
-              config
+                  command
-              watchSettings
+                  command
-              renderStateRef
+                  changeSummary
-              serverStatusRef
+                  projectRoot
-              dashboard
+                  config
-          watchLoop renderStateRef serverStatusRef nextSnapshot nextDashboard
+                  watchSettings
+                  renderStateRef
+                  serverStatusRef
+                  dashboard
+              watchLoop watchInputEnabled renderStateRef serverStatusRef nextSnapshot nextDashboard
 
 renderBuildResult :: ExitCode -> String
 renderBuildResult ExitSuccess = "success"