diff --git a/hakysidian.cabal b/hakysidian.cabal index 2ed272e..5b8f531 100644 --- a/hakysidian.cabal +++ b/hakysidian.cabal @@ -33,6 +33,7 @@ executable hakysidian , filepath , process , time + , unix , wai-app-static , warp -- , ghc-syntax-highlighter diff --git a/src/site.hs b/src/site.hs index 8c80a0b..bb49a29 100644 --- a/src/site.hs +++ b/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 - if interactive + stdoutInteractive <- hIsTerminalDevice stdout + 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 - nextSnapshot <- snapshotInputs projectRoot - if nextSnapshot == previousSnapshot - then watchLoop renderStateRef serverStatusRef previousSnapshot dashboard + shouldQuit <- waitForWatchQuit watchInputEnabled watchLoopDelayMicros + if shouldQuit + then pure ExitSuccess else do - let changedFiles = diffSnapshots previousSnapshot nextSnapshot - command :: String - command = - if any (`M.notMember` nextSnapshot) (M.keys previousSnapshot) - then "rebuild" - else "build" - changeSummary = intercalate ", " changedFiles - (_, nextDashboard) <- - runWatchBuild - command - command - changeSummary - projectRoot - config - watchSettings - renderStateRef - serverStatusRef - dashboard - watchLoop renderStateRef serverStatusRef nextSnapshot nextDashboard + nextSnapshot <- snapshotInputs projectRoot + if nextSnapshot == previousSnapshot + then watchLoop watchInputEnabled renderStateRef serverStatusRef previousSnapshot dashboard + else do + let changedFiles = diffSnapshots previousSnapshot nextSnapshot + command :: String + command = + if any (`M.notMember` nextSnapshot) (M.keys previousSnapshot) + then "rebuild" + else "build" + changeSummary = intercalate ", " changedFiles + (_, nextDashboard) <- + runWatchBuild + command + command + changeSummary + projectRoot + config + watchSettings + renderStateRef + serverStatusRef + dashboard + watchLoop watchInputEnabled renderStateRef serverStatusRef nextSnapshot nextDashboard renderBuildResult :: ExitCode -> String renderBuildResult ExitSuccess = "success"