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

@@ -4,12 +4,11 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneKindSignatures #-}
-{-# LANGUAGE ViewPatterns #-}
 
 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)
@@ -23,6 +22,7 @@ import Data.Time.Format (defaultTimeLocale, formatTime)
 import Data.Time.LocalTime (getZonedTime)
 import Hakyll
 import Hakyll.Core.Runtime (RunMode (RunModeNormal))
+import Network.Wai.Application.Static (staticApp)
 import qualified Network.Wai.Handler.Warp as Warp
 import qualified Paths_hakysidian as Paths
 import System.Directory
@@ -31,19 +31,32 @@ import System.Directory
     doesFileExist,
     getCurrentDirectory,
     getModificationTime,
-    listDirectory
+    listDirectory,
   )
 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,
+    hGetChar,
     hIsTerminalDevice,
     hSetBuffering,
-    stdout
+    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)
@@ -232,8 +245,8 @@ validateProject projectRoot = do
   unless (null missing) $
     die $
       unlines $
-        "hakysidian is missing required project inputs:" :
+        "hakysidian is missing required project inputs:"
-        map ("  - " ++) missing
+          : map ("  - " ++) missing
 
 initialDashboardState :: DashboardState
 initialDashboardState =
@@ -289,22 +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
+        ( 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)
+            hFlush stdout
-        (do
+        )
+        ( do
             putStr "\ESC[0m\ESC[?25h\ESC[?1049l"
             hFlush stdout
-            hSetBuffering stdout originalBuffering)
+            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 ->
@@ -337,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) $
@@ -351,7 +400,7 @@ renderWatchDashboard renderStateRef projectRoot config watchSettings serverStatu
 
 dashboardTitleRow :: Int -> String -> String -> String
 dashboardTitleRow width leftText rightText =
-  dashboardFramedRow width (leftText ++ spacer ++ clippedRight)
+  dashboardRow width (leftText ++ spacer ++ clippedRight)
   where
     usableWidth = max 1 (width - 4)
     rightWidth = min (usableWidth `div` 3) (length rightText)
@@ -366,10 +415,7 @@ dashboardTitleRow width leftText rightText =
       | otherwise = replicate (max 1 (usableWidth - length clippedLeft - length clippedRight)) ' '
 
 dashboardRow :: Int -> String -> String
-dashboardRow width = dashboardFramedRow width
+dashboardRow width content =
-
-dashboardFramedRow :: Int -> String -> String
-dashboardFramedRow width content =
   "| " ++ padRight usableWidth (ellipsize usableWidth content) ++ " |"
   where
     usableWidth = max 1 (width - 4)
@@ -405,8 +451,8 @@ getTerminalSize = do
   case sttySize of
     Just terminalSize -> pure terminalSize
     Nothing -> do
-      rows <- maybe 24 id . (>>= readMaybe) <$> lookupEnv "LINES"
+      rows <- fromMaybe 24 . (>>= readMaybe) <$> lookupEnv "LINES"
-      cols <- maybe 80 id . (>>= readMaybe) <$> lookupEnv "COLUMNS"
+      cols <- fromMaybe 80 . (>>= readMaybe) <$> lookupEnv "COLUMNS"
       pure (TerminalSize rows cols)
 
 queryTerminalSize :: IO (Maybe TerminalSize)
@@ -415,7 +461,8 @@ queryTerminalSize = do
     try $
       readCreateProcessWithExitCode
         (proc "sh" ["-c", "stty size </dev/tty"])
-        "" :: IO (Either SomeException (ExitCode, String, String))
+        "" ::
+      IO (Either SomeException (ExitCode, String, String))
   pure $ do
     (exitCode, stdoutText, _) <- either (const Nothing) Just result
     case exitCode of
@@ -430,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
 
@@ -472,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
@@ -490,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"
@@ -580,10 +666,11 @@ startPreviewServer config watchSettings serverStatusRef
         forkIO $
           do
             result <-
-              (try $
+              ( try $
-                 Warp.runSettings settings $
+                  Warp.runSettings settings $
-                   staticApp $
+                    staticApp $
-                     previewSettings config (destinationDirectory config)) ::
+                      previewSettings config (destinationDirectory config)
+              ) ::
                 IO (Either SomeException ())
             case result of
               Left err -> writeIORef serverStatusRef (ServerFailed (show err))
@@ -592,9 +679,10 @@ startPreviewServer config watchSettings serverStatusRef
   where
     settings =
       Warp.setBeforeMainLoop (writeIORef serverStatusRef ServerRunning) $
-      Warp.setPort (watchPort watchSettings) $
+        Warp.setPort (watchPort watchSettings) $
-        Warp.setHost (fromString (watchHost watchSettings)) $
+          Warp.setHost
-          Warp.defaultSettings
+            (fromString (watchHost watchSettings))
+            Warp.defaultSettings
 
 snapshotInputs :: FilePath -> IO FileSnapshot
 snapshotInputs projectRoot = do
@@ -625,8 +713,8 @@ trackedFilesIn root = do
   if exists
     then do
       entries <- listDirectory root
-      fmap concat $
+      fmap concat
-        traverse
+        <$> traverse
           ( \name -> do
               let path = root </> name
               isDir <- doesDirectoryExist path