Rendering performance experiments

3 files changed, 125 insertions, 2 deletions

diff --git a/pages/calendar-day.mustache b/pages/calendar-day.mustache
index 3483d59..9df9998 100644
--- a/pages/calendar-day.mustache
+++ b/pages/calendar-day.mustache
@@ -21,7 +21,7 @@
         {{#events}}
           <tr{{#classlist}} class="{{&.}}"{{/classlist}}>
             <td><a href="/cal/{{&alias}}/{{&date}}?eid={{&linkid}}#ev-{{&linkid}}" name="ev-{{&linkid}}">{{&time}}</a></td>
-            <td>{{#nickwrap1}}<span class="nickwrap">{{&nickwrap1}}</span>{{/nickwrap1}}{{&nickE}}{{#nickwrap2}}<span class="nickwrap">{{&nickwrap2}}</span>{{/nickwrap2}}</td>
+            <td>{{#nickwrap1}}<span class="nickwrap">{{&.}}</span>{{/nickwrap1}}{{&nickE}}{{#nickwrap2}}<span class="nickwrap">{{&.}}</span>{{/nickwrap2}}</td>
             <td>{{&messageE}}</td>
           </tr>
         {{/events}}
diff --git a/src/Main.hs b/src/Main.hs
index 08feeb8..5c73fce 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,9 +1,11 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LinearTypes #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ViewPatterns #-}
 module Main (main) where
 
+import Control.Applicative ((<|>))
 import Control.Monad (forM, guard, forM_)
 import Data.ByteString (ByteString)
 import Data.ByteString qualified as BS
@@ -11,11 +13,13 @@ import Data.ByteString.Char8 qualified as BS8
 import Data.ByteString.Lazy qualified as BSL
 import Data.Char (isDigit, ord)
 import Data.Function (on)
+import Data.HashMap.Strict qualified as HM
 import Data.List.NonEmpty (NonEmpty((:|)), groupBy)
 import Data.Map.Strict (Map)
 import Data.Map.Strict qualified as Map
 import Data.Text (Text)
 import Data.Text qualified as T
+import Data.Text.Builder.Linear.Buffer
 import Data.Text.Encoding qualified as TE
 import Data.Text.IO.Utf8 qualified as T
 import Data.Time (Day, toGregorian, fromGregorianValid)
@@ -25,6 +29,7 @@ import System.FilePath ((</>))
 import Text.Mustache (Template, compileTemplate, substituteValue, (~>))
 import Text.Mustache qualified as M
 import Text.Mustache.Types (Value(..))
+import Text.Mustache.Types qualified as M
 import Text.Read (readMaybe)
 
 import Network.HTTP.Server.Mini
@@ -130,6 +135,114 @@ pageLog conf pages index req alias =
       | n < 1000 = T.show n
       | otherwise = renderLargeNumber (n `div` 1000) <> "," <> T.pack (pad '0' 3 (n `mod` 1000))
 
+-- rnfValue :: Value -> ()
+-- rnfValue (Object o) = foldMap rnfValue o
+-- rnfValue (Array a) = foldMap rnfValue a
+-- rnfValue (Number !_) = ()
+-- rnfValue (String !_) = ()
+-- rnfValue Lambda{} = error "Lambda"
+-- rnfValue (Bool !_) = ()
+-- rnfValue Null = ()
+
+-- {-# NOINLINE forceValue #-}
+-- forceValue :: Value -> Value
+-- forceValue v = rnfValue v `seq` v
+
+data SimpleNode
+  = STextBlock !Text
+  | SSection !Text ![SimpleNode]
+  | SVariable {-# UNPACK #-} !Bool !Text
+  deriving (Show)
+
+toSimple :: Template -> [SimpleNode]
+toSimple (M.Template _ nodes _) = map (go Nothing) nodes
+  where
+    go :: Maybe Text -> M.Node Text -> SimpleNode
+    go _ (M.TextBlock t) = STextBlock t
+    go _ (M.Variable esc (M.NamedData [name])) = SVariable esc name
+    go (Just ctx) (M.Variable esc M.Implicit) = SVariable esc ctx
+    go Nothing (M.Variable _ M.Implicit) = error "toSimple: {{.}} outside section"
+    go _ (M.Section (M.NamedData [name]) ns) = SSection name (map (go (Just name)) ns)
+    go _ node = error $ "toSimple: unsupported node: " ++ show node
+
+renderSimple :: [SimpleNode] -> Value -> ByteString
+renderSimple topnodes topvalue = runBufferBS (\b -> foldlIntoBuffer (go [topvalue]) b topnodes)
+  where
+    go :: [Value] -> Buffer %1 -> SimpleNode -> Buffer
+    go values buf node = case node of
+      STextBlock t -> buf |> t
+      SSection name nodes -> case searchName name values of
+        Just (M.Bool False) -> buf
+        Just (M.Array vec) ->
+          foldlIntoBuffer (\b v -> foldlIntoBuffer (go (v : values)) b nodes) buf (toList vec)
+        Just value -> foldlIntoBuffer (go (value : values)) buf nodes
+        Nothing -> case consumeBuffer buf of () -> error $ "renderSimple: name " ++ show name ++ " not found"
+      SVariable esc name -> case searchName name values of
+        Just (M.String t)
+          | esc -> buf |> escapeXML t
+          | otherwise -> buf |> t
+        Just M.Null -> buf
+        Just value -> case consumeBuffer buf of () -> error $ "renderSimple: unsupported value type " ++ show value
+        Nothing -> case consumeBuffer buf of () -> error $ "renderSimple: name " ++ show name ++ " not found"
+
+    searchName :: Text -> [Value] -> Maybe Value
+    searchName n (M.Object obj : vs) = HM.lookup n obj <|> searchName n vs
+    searchName _ [] = Nothing
+    searchName n (_ : vs) = searchName n vs
+
+-- renderCalendarDayPage :: Template -> Channel -> Day -> Text -> Maybe Int -> [(HMS, EventID, Event)] -> ByteString
+-- renderCalendarDayPage (M.Template _ nodes _) chan day alias mpagehighlight events =
+--   runBufferBS (\b -> foldlIntoBuffer goTop b nodes)
+--   where
+--     date = T.pack (ymdToString (dayToYMD day))
+
+--     goTop :: Buffer %1-> M.Node Text -> Buffer
+--     goTop buf node = case node of
+--       M.TextBlock t -> buf |> t
+--       M.Variable _ (M.NamedData ["channel"]) -> buf |> chanChannel chan
+--       M.Variable _ (M.NamedData ["network"]) -> buf |> chanNetwork chan
+--       M.Variable _ (M.NamedData ["date"]) -> buf |> date
+--       M.Variable _ (M.NamedData ["alias"]) -> buf |> alias
+--       M.Section (M.NamedData ["events"]) ns ->
+--         foldlIntoBuffer
+--           (\b ((time, eid, event), dayidx) ->
+--             let tup = renderEvent event
+--             in foldlIntoBuffer (\b' n -> goEv b' time eid dayidx tup n) b ns)
+--           buf (zip events [0..])
+--       _ -> case consumeBuffer buf of
+--              () -> error $ "renderCalendarDayPage: unexpected top node " ++ show node
+
+--     goEv :: Buffer %1-> HMS -> EventID -> Int -> (Maybe Text, (Maybe Text, Text, Maybe Text), Text) -> M.Node Text -> Buffer
+--     goEv buf time eid dayidx (classlist, (nickw1, nick, nickw2), msg) node = case node of
+--       M.TextBlock t -> buf |> t
+--       M.Variable _ (M.NamedData ["alias"]) -> buf |> alias
+--       M.Variable _ (M.NamedData ["date"]) -> buf |> date
+--       M.Variable _ (M.NamedData ["linkid"]) -> buf |> eid
+--       M.Variable _ (M.NamedData ["time"]) ->
+--         buf |> T.pack (let HMS h mi s = time
+--                        in pad '0' 2 h ++ ':' : pad '0' 2 mi ++ ':' : pad '0' 2 s)
+--       M.Variable _ (M.NamedData ["nickE"]) -> buf |> escapeXML nick
+--       M.Variable _ (M.NamedData ["messageE"]) -> buf |> escapeXML msg
+--       M.Section (M.NamedData ["classlist"]) ns ->
+--         let classlist' | mpagehighlight == Just dayidx = Just (classlist `classListAdd` "highlight")
+--                        | otherwise = classlist
+--         in goMaybe buf goImplicit classlist' ns
+--       M.Section (M.NamedData ["nickwrap1"]) ns -> goMaybe buf goImplicit nickw1 ns
+--       M.Section (M.NamedData ["nickwrap2"]) ns -> goMaybe buf goImplicit nickw2 ns
+--       _ -> case consumeBuffer buf of
+--              () -> error $ "renderCalendarDayPage: unexpected node in event section: " ++ show node
+
+--     goMaybe :: Buffer %1-> (Buffer %1-> a -> M.Node Text -> Buffer) -> Maybe a -> [M.Node Text] -> Buffer
+--     goMaybe buf _ Nothing _ = buf
+--     goMaybe buf f (Just x) ns = foldlIntoBuffer (\b n -> f b x n) buf ns
+
+--     goImplicit :: Buffer %1-> Text -> M.Node Text -> Buffer
+--     goImplicit buf cl node = case node of
+--       M.TextBlock t -> buf |> t
+--       M.Variable False M.Implicit -> buf |> cl
+--       _ -> case consumeBuffer buf of
+--              () -> error $ "renderCalendarDayPage: unexpected node in implicit section: " ++ show node
+
 pageCalendarDay :: Config -> Pages -> Index -> Request -> Text -> Text -> IO Response
 pageCalendarDay conf pages index req alias datestr =
   case (econfAlias2Chan conf Map.!? alias, parseDatestr datestr) of
@@ -146,7 +259,15 @@ pageCalendarDay conf pages index req alias datestr =
                        return (Just evdayidx)
                  _ -> return Nothing
            | otherwise -> return Nothing
-      return $ sendPage200 pages "calendar-day" $ M.object
+
+      -- return $ responseBS
+      --   status200
+      --   [("Content-Type", "text/html")]
+      --   (renderCalendarDayPage (getPage pages "calendar-day") chan day alias mpagehighlight events)
+
+      -- -- return $ sendPage200 pages "calendar-day" $! forceValue $ M.object
+      -- return $ sendPage200 pages "calendar-day" $ M.object
+      return $ responseBS status200 [("Content-Type", "text/html")] $ renderSimple (toSimple (getPage pages "calendar-day")) $ M.object
         ["network" ~> chanNetwork chan
         ,"channel" ~> chanChannel chan
         ,"alias" ~> alias
diff --git a/tirclogv.cabal b/tirclogv.cabal
index f65130a..051453b 100644
--- a/tirclogv.cabal
+++ b/tirclogv.cabal
@@ -40,11 +40,13 @@ executable tirclogv
     filepath,
     fsnotify,
     mustache,
+    text-builder-linear,
     random,
     text >= 2.1.2,
     transformers,
     time,
     unix,
+    unordered-containers,
     vector
   hs-source-dirs: src
   c-sources: