better tui for watch

Add data-files and bundled templates/fonts/css to the package and
rename the executable to hakysidian (autogen Paths_hakysidian).
Refactor site.hs to parse CLI commands (build/clean/rebuild/watch),
start a preview server, snapshot inputs and run an incremental watch
loop, and move rules into a siteRules function. Update ChaoDoc and
filters to accept math-macros, and add favicon links to templates.

css/chao-theorems.css

@@ -36,6 +36,7 @@
 }
 
 .Proof {
+  background: none;
   font-style: normal;
   position: relative;
 }

css/default.css

@@ -264,20 +264,6 @@ ul {
     list-style-type: square;
     padding-left: 2em;
 }
-.notes-list {
-    list-style: none;
-    padding-left: 0;
-    margin-left: 0;
-}
-.notes-list li {
-    position: relative;
-    padding-left: 1em;
-}
-.notes-list li::before {
-    content: "-";
-    position: absolute;
-    left: 0;
-}
 li {
     margin-bottom: 0.15em;
 }

hakysidian.cabal

@@ -1,13 +1,22 @@
-name:               hakyll-blog
+cabal-version:      2.4
+name:               hakysidian
 version:            0.1.0.0
 build-type:         Simple
-cabal-version:      >= 1.10
 
+data-files:
+    bib_style.csl
+    favicon.ico
+    css/*.css
+    fonts/*.otf
+    fonts/*.ttf
+    fonts/*.woff2
+    templates/*.html
 
-executable site
+executable hakysidian
   hs-source-dirs:   src
   main-is:          site.hs
-  other-modules:    ChaoDoc, SideNoteHTML, Pangu
+  other-modules:    ChaoDoc, SideNoteHTML, Pangu, Paths_hakysidian
+  autogen-modules:  Paths_hakysidian
   build-depends:    base   >= 4.18
                   , hakyll >= 4.15
                   , mtl >= 2.2.2
@@ -20,7 +29,12 @@ executable site
                   -- , process
                   -- , regex-compat
                   , array
+                  , directory
                   , filepath
+                  , process
+                  , time
+                  , wai-app-static
+                  , warp
                   -- , ghc-syntax-highlighter
                   -- , blaze-html >= 0.9
                   , megaparsec
@@ -34,4 +48,4 @@ executable site
                   -Wno-unsafe
                   -Wno-prepositive-qualified-module
                   -O2 -threaded -rtsopts -with-rtsopts=-N
-  default-language: Haskell2010
+  default-language: Haskell2010

makefile

@@ -1,5 +1,6 @@
 
 COMMANDS := build watch rebuild clean
+BIN := hakysidian
 .PHONY: $(COMMANDS), publish
 
 # Set the default goal, so running 'make' without arguments will run 'make build'.
@@ -7,20 +8,20 @@ COMMANDS := build watch rebuild clean
 
 
 # --- 
-$(COMMANDS): site
-	@echo "Running command: ./site $@"
-	-@./site $@
+$(COMMANDS): $(BIN)
+	@echo "Running command: ./$(BIN) $@"
+	-@./$(BIN) $@
 
 
 # --- Rules ---
 # using relative symlinks should be fine since everything only works at ./
 
 
-site: src/site.hs src/ChaoDoc.hs
-	cabal build
-	ln -sf "$(shell cabal list-bin exe:site)" site
+$(BIN): src/site.hs src/ChaoDoc.hs
+	cabal build exe:hakysidian
+	ln -sf "$(shell cabal list-bin exe:hakysidian)" $(BIN)
 
 # move from katex to mathjax
 # katex_cli:
 # 	cd katex_rust_fork && cargo build --release
-# 	ln -sf ./katex_rust_fork/target/release/katex_cli katex_cli
+# 	ln -sf ./katex_rust_fork/target/release/katex_cli katex_cli

src/ChaoDoc.hs

@@ -124,9 +124,9 @@ preprocessTheorems (Div attr xs)
     attr' = addAttr attr "type" theoremType
 preprocessTheorems x = return x
 
-theoremFilter :: Pandoc -> Pandoc
-theoremFilter doc =
-  walk makeTheorem $
+theoremFilter :: Text -> Pandoc -> Pandoc
+theoremFilter mathMacros doc =
+  walk (makeTheorem mathMacros) $
     autorefFilter $
       evalState (walkM preprocessTheorems normalizedDoc) 1
   where
@@ -171,24 +171,13 @@ autorefFilter x = walk (autoref links) x
   where
     links = query theoremIndex x
 
--- processCitations works on AST. If you want to use citations in theorem name,
--- then you need to convert citations there to AST as well and then use processCitations\
--- Thus one need to apply the theorem filter first.
--- autoref still does not work.
-mathMacros :: Text
-mathMacros = unsafePerformIO (pack <$> readFile "math-macros.md")
-{-# NOINLINE mathMacros #-}
-
 prependMacros :: Text -> Text -> Text
 prependMacros macros body = macros <> "\n\n" <> body
 
-prependMathMacros :: Text -> Text
-prependMathMacros = prependMacros mathMacros
-
-thmNamePandoc :: Text -> Pandoc
-thmNamePandoc x =
+thmNamePandoc :: Text -> Text -> Pandoc
+thmNamePandoc mathMacros x =
   fromRight (Pandoc nullMeta []) . runPure $
-    readMarkdown chaoDocRead (prependMathMacros x)
+    readMarkdown chaoDocRead (prependMacros mathMacros x)
 
 obsidianTheoremFilter :: Pandoc -> Pandoc
 obsidianTheoremFilter = attachStandaloneLabels . walk rewriteObsidianBlockQuote
@@ -390,8 +379,8 @@ unsnoc (x : xs) = do
   (prefix, lastElem) <- unsnoc xs
   return (x : prefix, lastElem)
 
-makeTheorem :: Block -> Block
-makeTheorem (Div attr xs)
+makeTheorem :: Text -> Block -> Block
+makeTheorem mathMacros (Div attr xs)
   | isNothing t = Div attr xs
   | otherwise = Div (addClass attr "theorem-environment") (Plain [header] : xs)
   where
@@ -408,26 +397,23 @@ makeTheorem (Div attr xs)
     nametext =
       if isNothing name
         then Str ""
-        else Span (addClass nullAttr "name") (pandocToInline $ thmNamePandoc $ fromJust name)
-makeTheorem x = x
+        else Span (addClass nullAttr "name") (pandocToInline $ thmNamePandoc mathMacros $ fromJust name)
+makeTheorem _ x = x
 
--- bib from https://github.com/chaoxu/chaoxu.github.io/tree/develop
-cslFile :: String
-cslFile = "bib_style.csl"
-
-bibFile :: String
+bibFile :: T.Text
 bibFile = "reference.bib"
 
-chaoDocPandocCompiler :: Compiler (Item Pandoc)
-chaoDocPandocCompiler = do
+chaoDocPandocCompiler :: FilePath -> Compiler (Item Pandoc)
+chaoDocPandocCompiler cslPath = do
   macros <- T.pack <$> loadBody "math-macros.md"
+  void (loadBody "reference.bib" :: Compiler String)
   body <- getResourceBody
   let bodyWithMacros =
         fmap (T.unpack . prependMacros macros . T.pack) body
-  myReadPandocBiblio chaoDocRead (T.pack cslFile) (T.pack bibFile) myFilter bodyWithMacros
+  myReadPandocBiblio chaoDocRead (T.pack cslPath) bibFile (myFilter macros) bodyWithMacros
 
-chaoDocCompiler :: Compiler (Item String)
-chaoDocCompiler = chaoDocPandocCompiler <&> writePandocWith chaoDocWrite
+chaoDocCompiler :: FilePath -> Compiler (Item String)
+chaoDocCompiler cslPath = chaoDocPandocCompiler cslPath <&> writePandocWith chaoDocWrite
 
 addMeta :: T.Text -> MetaValue -> Pandoc -> Pandoc
 addMeta name value (Pandoc meta a) =
@@ -465,8 +451,9 @@ myReadPandocBiblio ropt csl biblio pdfilter item = do
                         -- let a x = itemSetBody (pandoc' x)
   return $ fmap (const pandoc') item
 
-myFilter :: Pandoc -> Pandoc
-myFilter = usingSideNotesHTML chaoDocWrite . theoremFilter . panguFilter . displayMathFilter
+myFilter :: Text -> Pandoc -> Pandoc
+myFilter mathMacros =
+  usingSideNotesHTML chaoDocWrite . theoremFilter mathMacros . panguFilter . displayMathFilter
 
 -- pangu filter
 lastChar :: Inline -> Maybe Char

src/site.hs

@@ -1,116 +1,675 @@
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
 {-# LANGUAGE ViewPatterns #-}
 
 import ChaoDoc
-import Data.List (sortOn)
+import Control.Concurrent (forkIO, threadDelay)
+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
+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
+import qualified Paths_hakysidian as Paths
+import System.Directory
+  ( canonicalizePath,
+    doesDirectoryExist,
+    doesFileExist,
+    getCurrentDirectory,
+    getModificationTime,
+    listDirectory
+  )
+import System.Environment (getArgs, getExecutablePath, lookupEnv)
+import System.Exit (ExitCode (..), die, exitSuccess, exitWith)
 import System.FilePath
-import Text.Pandoc
+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)
+
+--------------------------------------------------------------------------------
+
+notesPattern :: Pattern
+notesPattern = fromGlob "notes/**"
+
+bundledCssFiles :: [FilePath]
+bundledCssFiles =
+  [ "css/fonts.css",
+    "css/default.css",
+    "css/pygentize.css",
+    "css/chao-theorems.css",
+    "css/sidenotes.css"
+  ]
+
+bundledFontFiles :: [FilePath]
+bundledFontFiles =
+  [ "fonts/Lato-BoldItalic.woff2",
+    "fonts/IosevkaCustom-Bold.woff2",
+    "fonts/IosevkaCustom-Regular.woff2",
+    "fonts/Lato-Bold.woff2",
+    "fonts/Lato-Regular.woff2",
+    "fonts/IosevkaCustom-Italic.woff2",
+    "fonts/LeteSansMath.woff2",
+    "fonts/LeteSansMath-Bold.woff2",
+    "fonts/Lato-Italic.woff2"
+  ]
+
+bundledTemplateFiles :: [FilePath]
+bundledTemplateFiles =
+  [ "templates/head.html",
+    "templates/note.html",
+    "templates/notes.html",
+    "templates/notes-list.html",
+    "templates/index.html",
+    "templates/navbar.html"
+  ]
+
+type WatchSettings :: Type
+data WatchSettings = WatchSettings
+  { watchHost :: String,
+    watchPort :: Int,
+    watchServerEnabled :: Bool
+  }
+
+type CliCommand :: Type
+data CliCommand
+  = BuildCommand
+  | CleanCommand
+  | HelpCommand
+  | RebuildCommand
+  | WatchCommand WatchSettings
+
+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
 cleanRoute = customRoute createIndexRoute
   where
-    createIndexRoute ident = takeDirectory p </> takeBaseName p </> "index.html"
+    createIndexRoute ident = takeDirectory path </> takeBaseName path </> "index.html"
       where
-        p = toFilePath ident
+        path = toFilePath ident
 
 cleanIndexHtmls :: Item String -> Compiler (Item String)
 cleanIndexHtmls = return . fmap (replaceAll pattern replacement)
   where
-    pattern :: String = "/index.html"
-    replacement :: String -> String = const "/"
+    pattern :: String
+    pattern = "/index.html"
+
+    replacement :: String -> String
+    replacement = const "/"
 
 loadNoteLinks :: Compiler [Item String]
 loadNoteLinks = do
-  noteIds <- sortOn toFilePath <$> getMatches "notes/*"
+  noteIds <- sortOn toFilePath <$> getMatches notesPattern
   pure [Item noteId "" | noteId <- noteIds]
 
 --------------------------------------------------------------------------------
 
-config :: Configuration
-config =
+siteConfiguration :: FilePath -> Configuration
+siteConfiguration projectRoot =
   defaultConfiguration
-    { ignoreFile = \path ->
-        ignoreFile defaultConfiguration path
-          || ".git" `elem` splitDirectories (normalise path)
+    { destinationDirectory = projectRoot </> "_site",
+      storeDirectory = projectRoot </> "_cache",
+      tmpDirectory = projectRoot </> "_cache" </> "tmp",
+      providerDirectory = projectRoot,
+      ignoreFile = ignoreProjectFile (ignoreFile defaultConfiguration),
+      watchIgnore = ignoreProjectFile (watchIgnore defaultConfiguration)
     }
 
+ignoreProjectFile :: (FilePath -> Bool) -> FilePath -> Bool
+ignoreProjectFile defaultIgnore path = defaultIgnore path || ignoredProjectPath path
+
+ignoredProjectPath :: FilePath -> Bool
+ignoredProjectPath path =
+  any (`elem` [".git", ".obsidian"]) (splitDirectories (normalise path))
+
+--------------------------------------------------------------------------------
+
 main :: IO ()
-main = hakyllWith config $ do
+main = do
+  args <- getArgs
+  projectRoot <- canonicalizePath =<< getCurrentDirectory
+  let config = siteConfiguration projectRoot
+  cslPath <- Paths.getDataFileName "bib_style.csl"
+  case parseCliCommand config args of
+    Left err -> die (err <> "\n\n" <> usageText)
+    Right HelpCommand -> putStrLn usageText >> exitSuccess
+    Right CleanCommand ->
+      exitWith =<< runSiteCommand config cleanOptions cslPath
+    Right BuildCommand -> do
+      validateProject projectRoot
+      exitWith =<< runSiteCommand config buildOptions cslPath
+    Right RebuildCommand -> do
+      validateProject projectRoot
+      exitWith =<< runSiteCommand config rebuildOptions cslPath
+    Right (WatchCommand watchSettings) -> do
+      validateProject projectRoot
+      exitWith =<< runWatch projectRoot config cslPath watchSettings
+
+usageText :: String
+usageText =
+  unlines
+    [ "usage: hakysidian [build|clean|rebuild|watch [--host HOST] [--port PORT] [--no-server]]",
+      "",
+      "Run inside a project directory containing notes/, reference.bib, math-macros.md, and optional images/."
+    ]
+
+parseCliCommand :: Configuration -> [String] -> Either String CliCommand
+parseCliCommand config args
+  | any (`elem` ["-h", "--help"]) args = Right HelpCommand
+  | otherwise = case args of
+      [] -> Right BuildCommand
+      ["build"] -> Right BuildCommand
+      ["clean"] -> Right CleanCommand
+      ["rebuild"] -> Right RebuildCommand
+      "watch" : rest -> Right (WatchCommand (parseWatchSettings config rest))
+      command : _ -> Left ("Unknown command: " <> command)
+
+validateProject :: FilePath -> IO ()
+validateProject projectRoot = do
+  notesExists <- doesDirectoryExist (projectRoot </> "notes")
+  bibExists <- doesFileExist (projectRoot </> "reference.bib")
+  macrosExists <- doesFileExist (projectRoot </> "math-macros.md")
+  let missing :: [String]
+      missing =
+        [ "notes/"
+          | not notesExists
+        ]
+          ++ [ "reference.bib"
+               | not bibExists
+             ]
+          ++ [ "math-macros.md"
+               | not macrosExists
+             ]
+  unless (null missing) $
+    die $
+      unlines $
+        "hakysidian is missing required project inputs:" :
+        map ("  - " ++) missing
+
+initialDashboardState :: DashboardState
+initialDashboardState =
+  DashboardState
+    { dashboardStatus = "starting",
+      dashboardLastChange = "waiting for first build",
+      dashboardLastBuild = "pending",
+      dashboardLogLines =
+        [ "watcher ready",
+          "watching notes/, reference.bib, math-macros.md, images/ (optional)"
+        ]
+    }
+
+parseWatchSettings :: Configuration -> [String] -> WatchSettings
+parseWatchSettings config args =
+  WatchSettings
+    { watchHost = fromMaybe (previewHost config) (extractOptionValue "--host" args),
+      watchPort =
+        fromMaybe (previewPort config) $
+          extractOptionValue "--port" args >>= readMaybe,
+      watchServerEnabled = "--no-server" `notElem` args
+    }
+
+watchUrl :: WatchSettings -> Maybe String
+watchUrl settings
+  | watchServerEnabled settings =
+      Just $
+        "http://"
+          ++ displayHost (watchHost settings)
+          ++ ":"
+          ++ show (watchPort settings)
+          ++ "/"
+  | otherwise = Nothing
+  where
+    displayHost :: String -> String
+    displayHost "0.0.0.0" = "127.0.0.1"
+    displayHost hostName = hostName
+
+extractOptionValue :: String -> [String] -> Maybe String
+extractOptionValue option = go
+  where
+    optionPrefix = option ++ "="
+
+    go :: [String] -> Maybe String
+    go [] = Nothing
+    go [arg]
+      | optionPrefix `isPrefixOf` arg = Just (drop (length optionPrefix) arg)
+      | otherwise = Nothing
+    go (arg : value : rest)
+      | arg == option = Just value
+      | 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}
+
+cleanOptions :: Options
+cleanOptions = Options {verbosity = False, optCommand = Clean}
+
+rebuildOptions :: Options
+rebuildOptions = Options {verbosity = False, optCommand = Rebuild}
+
+runSiteCommand :: Configuration -> Options -> FilePath -> IO ExitCode
+runSiteCommand config options cslPath =
+  hakyllWithExitCodeAndArgs config options (siteRules cslPath)
+
+runWatch :: FilePath -> Configuration -> FilePath -> WatchSettings -> IO ExitCode
+runWatch projectRoot config _cslPath watchSettings =
+  withWatchTui do
+    serverStatusRef <- newIORef initialServerStatus
+    renderStateRef <- newIORef Nothing
+    startPreviewServer config watchSettings serverStatusRef
+    renderWatchDashboard renderStateRef projectRoot config watchSettings serverStatusRef initialDashboardState
+    (_, initialDashboard) <-
+      runWatchBuild
+        "build"
+        "initial build"
+        "initial build"
+        projectRoot
+        config
+        watchSettings
+        renderStateRef
+        serverStatusRef
+        initialDashboardState
+    initialSnapshot <- snapshotInputs projectRoot
+    watchLoop renderStateRef serverStatusRef initialSnapshot initialDashboard
+  where
+    initialServerStatus
+      | 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 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 renderStateRef serverStatusRef nextSnapshot nextDashboard
+
+renderBuildResult :: ExitCode -> String
+renderBuildResult ExitSuccess = "success"
+renderBuildResult (ExitFailure code) = "failed (" ++ show code ++ ")"
+
+runWatchBuild ::
+  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)) ::
+                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
+
+snapshotInputs :: FilePath -> IO FileSnapshot
+snapshotInputs projectRoot = do
+  inputFiles <- trackedInputs projectRoot
+  entries <- traverse toSnapshotEntry inputFiles
+  pure (M.fromList entries)
+  where
+    toSnapshotEntry :: FilePath -> IO (FilePath, UTCTime)
+    toSnapshotEntry path = do
+      modifiedAt <- getModificationTime path
+      pure (makeRelative projectRoot path, modifiedAt)
+
+trackedInputs :: FilePath -> IO [FilePath]
+trackedInputs projectRoot = do
+  requiredFiles <-
+    filterM
+      doesFileExist
+      [ projectRoot </> "reference.bib",
+        projectRoot </> "math-macros.md"
+      ]
+  noteFiles <- trackedFilesIn (projectRoot </> "notes")
+  imageFiles <- trackedFilesIn (projectRoot </> "images")
+  pure (sort (requiredFiles ++ noteFiles ++ imageFiles))
+
+trackedFilesIn :: FilePath -> IO [FilePath]
+trackedFilesIn root = do
+  exists <- doesDirectoryExist root
+  if exists
+    then do
+      entries <- listDirectory root
+      fmap concat $
+        traverse
+          ( \name -> do
+              let path = root </> name
+              isDir <- doesDirectoryExist path
+              if isDir
+                then trackedFilesIn path
+                else pure [path]
+          )
+          entries
+    else pure []
+
+diffSnapshots :: FileSnapshot -> FileSnapshot -> [FilePath]
+diffSnapshots previousSnapshot nextSnapshot =
+  sort
+    [ path
+      | path <- M.keys (M.union previousSnapshot nextSnapshot),
+        M.lookup path previousSnapshot /= M.lookup path nextSnapshot
+    ]
+
+--------------------------------------------------------------------------------
+
+siteRules :: FilePath -> Rules ()
+siteRules cslPath = do
   match "images/**" $ do
     route idRoute
     compile copyFileCompiler
 
-  match "math-macros.md" $ compile getResourceBody
+  match "math-macros.md" $
+    compile getResourceBody
 
-  match "fonts/*.woff2" $ do
-    route idRoute
-    compile copyFileCompiler
+  match "reference.bib" $
+    compile getResourceBody
 
-  match "favicon.ico" $ do
-    route idRoute
-    compile copyFileCompiler
+  mapM_ createBundledCss bundledCssFiles
+  mapM_ createBundledCopy bundledFontFiles
+  createBundledCopy "favicon.ico"
+  mapM_ createBundledTemplate bundledTemplateFiles
 
-  -- match "404.html" $ do
-  --   route cleanRoute
-  --   compile copyFileCompiler
-
-  match "css/*" $ do
-    route idRoute
-    compile compressCssCompiler
-
-  -- match "about.md" $ do
-  --   route cleanRoute
-  --   compile $
-  --     chaoDocCompiler
-  --       >>= loadAndApplyTemplate "templates/about.html" defaultContext
-  --       >>= relativizeUrls
-
-  -- -- build up tags
-  -- tags <- buildTags "posts/*" (fromCapture "tags/*.html")
-  -- tagsRules tags $ \tag pattern -> do
-  --   let title = "Posts tagged \"" ++ tag ++ "\""
-  --   route cleanRoute
-  --   compile $ do
-  --     posts <- recentFirst =<< loadAll pattern
-  --     let ctx =
-  --           constField "title" title
-  --             `mappend` listField "posts" (postCtxWithTags tags) (return posts)
-  --             `mappend` defaultContext
-  --     makeItem ""
-  --       >>= loadAndApplyTemplate "templates/tag.html" ctx
-  --       >>= loadAndApplyTemplate "templates/default.html" ctx
-  --       >>= relativizeUrls
-
-  -- create ["tags.html"] $ do
-  --   route cleanRoute
-  --   compile $ do
-  --     makeItem ""
-  --       >>= loadAndApplyTemplate "templates/tags.html" (defaultCtxWithTags tags)
-  --       >>= loadAndApplyTemplate "templates/default.html" (defaultCtxWithTags tags)
-
-  -- match "posts/*" $ do
-  --   route cleanRoute
-  --   compile $ do
-  --     tocCtx <- getTocCtx (postCtxWithTags tags)
-  --     chaoDocCompiler
-  --       >>= loadAndApplyTemplate "templates/post.html" tocCtx
-  --       >>= loadAndApplyTemplate "templates/default.html" tocCtx
-  --       >>= relativizeUrls
-  -- --    >>= katexFilter
-
-  match "notes/*" $ do
+  match notesPattern $ do
     route cleanRoute
     compile $ do
       notes <- loadNoteLinks
-      tocCtx <- getTocCtx $ listField "notes" defaultContext (return notes) <> defaultContext
-      chaoDocCompiler
+      tocCtx <- getTocCtx cslPath (listField "notes" defaultContext (pure notes) <> defaultContext)
+      chaoDocCompiler cslPath
         >>= loadAndApplyTemplate "templates/note.html" tocCtx
         >>= relativizeUrls
 
@@ -119,118 +678,63 @@ main = hakyllWith config $ do
     compile $ do
       notes <- loadNoteLinks
       let notesCtx =
-            listField "notes" defaultContext (return notes)
-              `mappend` constField "title" "Notes"
-              `mappend` defaultContext
+            listField "notes" defaultContext (pure notes)
+              <> constField "title" "Notes"
+              <> defaultContext
       makeItem ""
         >>= loadAndApplyTemplate "templates/notes.html" notesCtx
         >>= loadAndApplyTemplate "templates/index.html" notesCtx
         >>= relativizeUrls
         >>= cleanIndexHtmls
 
-  -- create ["archive.html"] $ do
-  --   route cleanRoute
-  --   compile $ do
-  --     posts <- recentFirst =<< loadAll "posts/*"
-  --     let archiveCtx =
-  --           listField "posts" postCtx (return posts)
-  --             `mappend` constField "title" "Archives"
-  --             `mappend` defaultContext
-  --     makeItem ""
-  --       >>= loadAndApplyTemplate "templates/archive.html" archiveCtx
-  --       >>= loadAndApplyTemplate "templates/index.html" archiveCtx
-  --       >>= relativizeUrls
-  --       >>= cleanIndexHtmls
+createBundledCss :: FilePath -> Rules ()
+createBundledCss relPath = create [fromFilePath relPath] $ do
+  route idRoute
+  compile bundledCssCompiler
 
-  -- create ["draft.html"] $ do
-  --   route cleanRoute
-  --   compile $ do
-  --     posts <- recentFirst =<< loadAll "posts/*"
-  --     let draftCtx =
-  --           listField "posts" postCtx (return posts)
-  --             `mappend` constField "title" "Drafts"
-  --             `mappend` defaultContext
-  --     makeItem ""
-  --       >>= loadAndApplyTemplate "templates/draft.html" draftCtx
-  --       >>= loadAndApplyTemplate "templates/index.html" draftCtx
-  --       >>= relativizeUrls
-  --       >>= cleanIndexHtmls
+createBundledCopy :: FilePath -> Rules ()
+createBundledCopy relPath = create [fromFilePath relPath] $ do
+  route idRoute
+  compile bundledCopyCompiler
 
-  -- match "index.html" $ do
-  --   route idRoute
-  --   compile $ do
-  --     posts <- fmap (take 25) . recentFirst =<< loadAll "posts/*"
-  --     let indexCtx =
-  --           listField "posts" postCtx (return posts)
-  --             `mappend` defaultContext
-  --     getResourceBody
-  --       >>= applyAsTemplate indexCtx
-  --       >>= loadAndApplyTemplate "templates/index.html" indexCtx
-  --       >>= relativizeUrls
-  --       >>= cleanIndexHtmls
+createBundledTemplate :: FilePath -> Rules ()
+createBundledTemplate relPath =
+  create [fromFilePath relPath] $
+    compile bundledTemplateCompiler
 
-  match "templates/*" $ compile templateBodyCompiler
+bundledAssetPath :: Compiler FilePath
+bundledAssetPath = do
+  ident <- getUnderlying
+  unsafeCompiler $ Paths.getDataFileName (toFilePath ident)
 
--- https://robertwpearce.com/hakyll-pt-2-generating-a-sitemap-xml-file.html
--- create ["sitemap.xml"] $ do
---   route idRoute
---   compile $ do
---     posts <- recentFirst =<< loadAll "posts/*"
---     singlePages <- loadAll (fromList ["about.md"])
---     let pages = posts <> singlePages
---         sitemapCtx =
---           constField "root" root
---             <> listField "pages" postCtx (return pages) -- here
---     makeItem ""
---       >>= loadAndApplyTemplate "templates/sitemap.xml" sitemapCtx
+bundledTextCompiler :: Compiler (Item String)
+bundledTextCompiler = do
+  assetPath <- bundledAssetPath
+  contents <- unsafeCompiler (readFile assetPath)
+  makeItem contents
+
+bundledCssCompiler :: Compiler (Item String)
+bundledCssCompiler = fmap compressCss <$> bundledTextCompiler
+
+bundledCopyCompiler :: Compiler (Item CopyFile)
+bundledCopyCompiler = do
+  assetPath <- bundledAssetPath
+  makeItem (CopyFile assetPath)
+
+bundledTemplateCompiler :: Compiler (Item Template)
+bundledTemplateCompiler = do
+  item <- bundledTextCompiler
+  template <- compileTemplateItem item
+  pure (itemSetBody template item)
 
 --------------------------------------------------------------------------------
 
--- isZhField :: Context String
--- isZhField = boolFieldM "isZh" isZh
---   where
---     isZh :: Item String -> Compiler Bool
---     isZh item = do
---       maybeLang <- getMetadataField (itemIdentifier item) "lang"
---       return (maybeLang == Just "zh")
-
--- postCtx :: Context String
--- postCtx =
---   dateField "date" "%B %e, %Y"
---     <> dateField "date" "%Y-%m-%d"
---     <> isZhField
---     <> defaultContext
-
--- postCtxWithTags :: Tags -> Context String
--- postCtxWithTags tags = tagsField "tags" tags `mappend` postCtx
-
--- defaultCtxWithTags :: Tags -> Context String
--- defaultCtxWithTags tags = listField "tags" tagsCtx getAllTags <> defaultContext
---   where
---     getAllTags :: Compiler [Item (String, [Identifier])]
---     getAllTags = pure . map mkItem $ tagsMap tags
---       where
---         mkItem :: (String, [Identifier]) -> Item (String, [Identifier])
---         mkItem x@(t, _) = Item (tagsMakeId tags t) x
---     tagsCtx =
---       listFieldWith "posts" (postCtxWithTags tags) getPosts
---         <> metadataField
---         <> urlField "url"
---         <> pathField "path"
---         <> titleField "title"
---         <> missingField
---       where
---         getPosts ::
---           Item (String, [Identifier]) ->
---           Compiler [Item String]
---         getPosts (itemBody -> (_, is)) = mapM load is
-
 -- toc from https://github.com/slotThe/slotThe.github.io
-getTocCtx :: Context a -> Compiler (Context a)
-getTocCtx ctx = do
+getTocCtx :: FilePath -> Context a -> Compiler (Context a)
+getTocCtx cslPath ctx = do
   noToc <- (Just "true" ==) <$> (getUnderlying >>= (`getMetadataField` "no-toc"))
   writerOpts <- mkTocWriter defaultHakyllWriterOptions
-  toc <- writePandocWith writerOpts <$> chaoDocPandocCompiler
+  toc <- writePandocWith writerOpts <$> chaoDocPandocCompiler cslPath
   pure $
     mconcat
       [ ctx,

templates/head.html

@@ -3,6 +3,7 @@
 <meta name="viewport" content="width=device-width, initial-scale=1" />
 <meta name="googlebot" content="noindex" />
 <title>$title$</title>
+<link rel="icon" href="/favicon.ico" />
 <link rel="stylesheet" href="/css/fonts.css" />
 <link rel="stylesheet" href="/css/default.css" />
 <link rel="stylesheet" href="/css/pygentize.css" />

templates/index.html

@@ -7,6 +7,7 @@
     <meta name="viewport" content="width=device-width, initial-scale=1">
     <meta name="googlebot" content="noindex">
     <title></title>
+    <link rel="icon" href="/favicon.ico" />
     <link rel="stylesheet" href="/css/fonts.css" />
     <link rel="stylesheet" href="/css/default.css" />
     <link rel="stylesheet" href="/css/pygentize.css" />
@@ -31,4 +32,4 @@
     </div>
 </body>
 
-</html>
+</html>