{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} -- : dep lucid -- : dep servant-lucid module Omni.Jr.Web.Components ( -- * Time formatting formatRelativeTime, relativeText, formatExactTimestamp, renderRelativeTimestamp, -- * Small components metaSep, -- * Page layout pageHead, pageBody, pageBodyWithCrumbs, navbar, -- * JavaScript navbarDropdownJs, statusDropdownJs, priorityDropdownJs, liveToggleJs, -- * Breadcrumbs Breadcrumb (..), Breadcrumbs, renderBreadcrumbs, getAncestors, taskBreadcrumbs, -- * Badges statusBadge, complexityBadge, statusBadgeWithForm, clickableBadge, statusDropdownOptions, statusOption, priorityBadgeWithForm, clickablePriorityBadge, priorityDropdownOptions, priorityOption, -- * Sorting SortOrder (..), sortOrderToParam, sortOrderLabel, sortDropdown, sortOption, -- * Progress bars multiColorProgressBar, epicProgressBar, -- * Task rendering renderTaskCard, renderBlockedTaskCard, renderListGroupItem, renderEpicReviewCard, renderEpicCardWithStats, getDescendants, -- * Metrics renderAggregatedMetrics, -- * Retry context renderRetryContextBanner, -- * Markdown MarkdownBlock (..), InlinePart (..), renderMarkdown, parseBlocks, renderBlocks, renderBlock, renderListItem, renderInline, parseInline, parseBold, renderInlineParts, renderInlinePart, -- * Comments commentForm, -- * Live toggles renderLiveToggle, renderAutoscrollToggle, -- * Cost/Token metrics aggregateCostMetrics, formatCostHeader, formatTokensHeader, -- * Timeline renderUnifiedTimeline, renderTimelineEvent, eventTypeIconAndLabel, renderActorLabel, renderCommentTimelineEvent, renderStatusChangeEvent, parseStatusChange, renderActivityEvent, renderErrorTimelineEvent, renderAssistantTimelineEvent, renderToolCallTimelineEvent, renderToolResultTimelineEvent, renderCheckpointEvent, renderGuardrailEvent, renderGenericEvent, parseToolCallContent, formatToolCallSummary, renderCollapsibleOutput, renderDecodedToolResult, timelineScrollScript, ) where import Alpha import qualified Data.Aeson as Aeson import qualified Data.Aeson.KeyMap as KeyMap import qualified Data.ByteString.Lazy as LBS import qualified Data.List as List import qualified Data.Text as Text import Data.Time (NominalDiffTime, UTCTime, defaultTimeLocale, diffUTCTime, formatTime) import qualified Lucid import qualified Lucid.Base as Lucid import Numeric (showFFloat) import qualified Omni.Task.Core as TaskCore -- * Time formatting formatRelativeTime :: UTCTime -> UTCTime -> Text formatRelativeTime now timestamp = let delta = diffUTCTime now timestamp in relativeText delta relativeText :: NominalDiffTime -> Text relativeText delta | delta < 60 = "just now" | delta < 3600 = tshow (round (delta / 60) :: Int) <> " minutes ago" | delta < 7200 = "1 hour ago" | delta < 86400 = tshow (round (delta / 3600) :: Int) <> " hours ago" | delta < 172800 = "yesterday" | delta < 604800 = tshow (round (delta / 86400) :: Int) <> " days ago" | delta < 1209600 = "1 week ago" | delta < 2592000 = tshow (round (delta / 604800) :: Int) <> " weeks ago" | delta < 5184000 = "1 month ago" | delta < 31536000 = tshow (round (delta / 2592000) :: Int) <> " months ago" | otherwise = tshow (round (delta / 31536000) :: Int) <> " years ago" formatExactTimestamp :: UTCTime -> Text formatExactTimestamp = Text.pack <. formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S UTC" renderRelativeTimestamp :: (Monad m) => UTCTime -> UTCTime -> Lucid.HtmlT m () renderRelativeTimestamp now timestamp = Lucid.span_ [ Lucid.class_ "relative-time", Lucid.title_ (formatExactTimestamp timestamp) ] (Lucid.toHtml (formatRelativeTime now timestamp)) -- * Small components metaSep :: (Monad m) => Lucid.HtmlT m () metaSep = Lucid.span_ [Lucid.class_ "meta-sep"] "·" -- * Sort types data SortOrder = SortNewest | SortOldest | SortUpdated | SortPriorityHigh | SortPriorityLow deriving (Show, Eq) sortOrderToParam :: SortOrder -> Text sortOrderToParam SortNewest = "newest" sortOrderToParam SortOldest = "oldest" sortOrderToParam SortUpdated = "updated" sortOrderToParam SortPriorityHigh = "priority-high" sortOrderToParam SortPriorityLow = "priority-low" sortOrderLabel :: SortOrder -> Text sortOrderLabel SortNewest = "Newest First" sortOrderLabel SortOldest = "Oldest First" sortOrderLabel SortUpdated = "Recently Updated" sortOrderLabel SortPriorityHigh = "Priority (High to Low)" sortOrderLabel SortPriorityLow = "Priority (Low to High)" -- * Page layout pageHead :: (Monad m) => Text -> Lucid.HtmlT m () pageHead title = Lucid.head_ <| do Lucid.title_ (Lucid.toHtml title) Lucid.meta_ [Lucid.charset_ "utf-8"] Lucid.meta_ [ Lucid.name_ "viewport", Lucid.content_ "width=device-width, initial-scale=1" ] Lucid.link_ [Lucid.rel_ "stylesheet", Lucid.href_ "/style.css"] Lucid.script_ [ Lucid.src_ "https://unpkg.com/htmx.org@2.0.4", Lucid.integrity_ "sha384-HGfztofotfshcF7+8n44JQL2oJmowVChPTg48S+jvZoztPfvwD79OC/LTtG6dMp+", Lucid.crossorigin_ "anonymous" ] ("" :: Text) Lucid.script_ [] statusDropdownJs Lucid.script_ [] priorityDropdownJs Lucid.script_ [] navbarDropdownJs Lucid.script_ [] liveToggleJs -- * JavaScript navbarDropdownJs :: Text navbarDropdownJs = Text.unlines [ "document.addEventListener('DOMContentLoaded', function() {", " document.querySelectorAll('.navbar-dropdown-btn').forEach(function(btn) {", " btn.addEventListener('click', function(e) {", " e.preventDefault();", " var dropdown = btn.closest('.navbar-dropdown');", " var isOpen = dropdown.classList.contains('open');", " document.querySelectorAll('.navbar-dropdown.open').forEach(function(d) {", " d.classList.remove('open');", " });", " if (!isOpen) {", " dropdown.classList.add('open');", " }", " });", " });", " document.addEventListener('click', function(e) {", " if (!e.target.closest('.navbar-dropdown')) {", " document.querySelectorAll('.navbar-dropdown.open').forEach(function(d) {", " d.classList.remove('open');", " });", " }", " });", "});" ] statusDropdownJs :: Text statusDropdownJs = Text.unlines [ "function toggleStatusDropdown(el) {", " var container = el.parentElement;", " var isOpen = container.classList.toggle('open');", " el.setAttribute('aria-expanded', isOpen);", " if (isOpen) {", " var firstItem = container.querySelector('[role=\"menuitem\"]');", " if (firstItem) firstItem.focus();", " }", "}", "", "function closeStatusDropdown(container) {", " container.classList.remove('open');", " var badge = container.querySelector('[role=\"button\"]');", " if (badge) {", " badge.setAttribute('aria-expanded', 'false');", " badge.focus();", " }", "}", "", "function handleStatusKeydown(event, el) {", " if (event.key === 'Enter' || event.key === ' ') {", " event.preventDefault();", " toggleStatusDropdown(el);", " } else if (event.key === 'Escape') {", " closeStatusDropdown(el.parentElement);", " } else if (event.key === 'ArrowDown') {", " event.preventDefault();", " var container = el.parentElement;", " if (!container.classList.contains('open')) {", " toggleStatusDropdown(el);", " } else {", " var firstItem = container.querySelector('[role=\"menuitem\"]');", " if (firstItem) firstItem.focus();", " }", " }", "}", "", "function handleMenuItemKeydown(event) {", " var container = event.target.closest('.status-badge-dropdown');", " var items = container.querySelectorAll('[role=\"menuitem\"]');", " var currentIndex = Array.from(items).indexOf(event.target);", " ", " if (event.key === 'ArrowDown') {", " event.preventDefault();", " var next = (currentIndex + 1) % items.length;", " items[next].focus();", " } else if (event.key === 'ArrowUp') {", " event.preventDefault();", " var prev = (currentIndex - 1 + items.length) % items.length;", " items[prev].focus();", " } else if (event.key === 'Escape') {", " event.preventDefault();", " closeStatusDropdown(container);", " } else if (event.key === 'Tab') {", " closeStatusDropdown(container);", " }", "}", "", "document.addEventListener('click', function(e) {", " var dropdowns = document.querySelectorAll('.status-badge-dropdown.open');", " dropdowns.forEach(function(d) {", " if (!d.contains(e.target)) {", " closeStatusDropdown(d);", " }", " });", "});" ] priorityDropdownJs :: Text priorityDropdownJs = Text.unlines [ "function togglePriorityDropdown(el) {", " var container = el.parentElement;", " var isOpen = container.classList.toggle('open');", " el.setAttribute('aria-expanded', isOpen);", " if (isOpen) {", " var firstItem = container.querySelector('[role=\"menuitem\"]');", " if (firstItem) firstItem.focus();", " }", "}", "", "function closePriorityDropdown(container) {", " container.classList.remove('open');", " var badge = container.querySelector('[role=\"button\"]');", " if (badge) {", " badge.setAttribute('aria-expanded', 'false');", " badge.focus();", " }", "}", "", "function handlePriorityKeydown(event, el) {", " if (event.key === 'Enter' || event.key === ' ') {", " event.preventDefault();", " togglePriorityDropdown(el);", " } else if (event.key === 'Escape') {", " closePriorityDropdown(el.parentElement);", " } else if (event.key === 'ArrowDown') {", " event.preventDefault();", " var container = el.parentElement;", " if (!container.classList.contains('open')) {", " togglePriorityDropdown(el);", " } else {", " var firstItem = container.querySelector('[role=\"menuitem\"]');", " if (firstItem) firstItem.focus();", " }", " }", "}", "", "function handlePriorityMenuItemKeydown(event) {", " var container = event.target.closest('.priority-badge-dropdown');", " var items = container.querySelectorAll('[role=\"menuitem\"]');", " var currentIndex = Array.from(items).indexOf(event.target);", " ", " if (event.key === 'ArrowDown') {", " event.preventDefault();", " var next = (currentIndex + 1) % items.length;", " items[next].focus();", " } else if (event.key === 'ArrowUp') {", " event.preventDefault();", " var prev = (currentIndex - 1 + items.length) % items.length;", " items[prev].focus();", " } else if (event.key === 'Escape') {", " event.preventDefault();", " closePriorityDropdown(container);", " } else if (event.key === 'Tab') {", " closePriorityDropdown(container);", " }", "}", "", "document.addEventListener('click', function(e) {", " var dropdowns = document.querySelectorAll('.priority-badge-dropdown.open');", " dropdowns.forEach(function(d) {", " if (!d.contains(e.target)) {", " closePriorityDropdown(d);", " }", " });", "});" ] liveToggleJs :: Text liveToggleJs = Text.unlines [ "var liveUpdatesEnabled = true;", "var autoscrollEnabled = true;", "", "function toggleLiveUpdates() {", " liveUpdatesEnabled = !liveUpdatesEnabled;", " var btn = document.getElementById('live-toggle');", " if (btn) {", " btn.classList.toggle('timeline-live-paused', !liveUpdatesEnabled);", " }", "}", "", "function toggleAutoscroll() {", " autoscrollEnabled = !autoscrollEnabled;", " var btn = document.getElementById('autoscroll-toggle');", " if (btn) {", " btn.classList.toggle('timeline-autoscroll-disabled', !autoscrollEnabled);", " }", "}", "", "document.body.addEventListener('htmx:beforeRequest', function(evt) {", " var timeline = document.getElementById('unified-timeline');", " if (timeline && timeline.contains(evt.target) && !liveUpdatesEnabled) {", " evt.preventDefault();", " }", "});", "", "document.body.addEventListener('htmx:afterSettle', function(evt) {", " if (autoscrollEnabled) {", " var log = document.querySelector('.timeline-events');", " if (log) {", " log.scrollTop = log.scrollHeight;", " }", " }", "});" ] pageBody :: (Monad m) => Lucid.HtmlT m () -> Lucid.HtmlT m () pageBody content = Lucid.body_ [Lucid.makeAttribute "hx-boost" "true"] <| do navbar content -- * Breadcrumbs data Breadcrumb = Breadcrumb { _crumbLabel :: Text, _crumbHref :: Maybe Text } type Breadcrumbs = [Breadcrumb] pageBodyWithCrumbs :: (Monad m) => Breadcrumbs -> Lucid.HtmlT m () -> Lucid.HtmlT m () pageBodyWithCrumbs crumbs content = Lucid.body_ [Lucid.makeAttribute "hx-boost" "true"] <| do navbar unless (null crumbs) <| do Lucid.div_ [Lucid.class_ "breadcrumb-container"] <| do Lucid.div_ [Lucid.class_ "container"] <| renderBreadcrumbs crumbs content renderBreadcrumbs :: (Monad m) => Breadcrumbs -> Lucid.HtmlT m () renderBreadcrumbs [] = pure () renderBreadcrumbs crumbs = Lucid.nav_ [Lucid.class_ "breadcrumbs", Lucid.makeAttribute "aria-label" "Breadcrumb"] <| do Lucid.ol_ [Lucid.class_ "breadcrumb-list"] <| do traverse_ renderCrumb (zip [0 ..] crumbs) where renderCrumb :: (Monad m') => (Int, Breadcrumb) -> Lucid.HtmlT m' () renderCrumb (idx, Breadcrumb label mHref) = do Lucid.li_ [Lucid.class_ "breadcrumb-item"] <| do when (idx > 0) <| Lucid.span_ [Lucid.class_ "breadcrumb-sep"] ">" case mHref of Just href -> Lucid.a_ [Lucid.href_ href] (Lucid.toHtml label) Nothing -> Lucid.span_ [Lucid.class_ "breadcrumb-current"] (Lucid.toHtml label) getAncestors :: [TaskCore.Task] -> TaskCore.Task -> [TaskCore.Task] getAncestors allTasks task = case TaskCore.taskParent task of Nothing -> [task] Just pid -> case TaskCore.findTask pid allTasks of Nothing -> [task] Just parent -> getAncestors allTasks parent ++ [task] taskBreadcrumbs :: [TaskCore.Task] -> TaskCore.Task -> Breadcrumbs taskBreadcrumbs allTasks task = let ancestors = getAncestors allTasks task taskCrumbs = [Breadcrumb (TaskCore.taskId t) (Just ("/tasks/" <> TaskCore.taskId t)) | t <- List.init ancestors] currentCrumb = Breadcrumb (TaskCore.taskId task) Nothing in [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks")] ++ taskCrumbs ++ [currentCrumb] -- * Navbar navbar :: (Monad m) => Lucid.HtmlT m () navbar = Lucid.nav_ [Lucid.class_ "navbar"] <| do Lucid.a_ [Lucid.href_ "/", Lucid.class_ "navbar-brand"] "Junior" Lucid.input_ [ Lucid.type_ "checkbox", Lucid.id_ "navbar-toggle", Lucid.class_ "navbar-toggle-checkbox" ] Lucid.label_ [ Lucid.for_ "navbar-toggle", Lucid.class_ "navbar-hamburger" ] <| do Lucid.span_ [Lucid.class_ "hamburger-line"] "" Lucid.span_ [Lucid.class_ "hamburger-line"] "" Lucid.span_ [Lucid.class_ "hamburger-line"] "" Lucid.div_ [Lucid.class_ "navbar-links"] <| do Lucid.a_ [Lucid.href_ "/", Lucid.class_ "navbar-link"] "Dashboard" Lucid.div_ [Lucid.class_ "navbar-dropdown"] <| do Lucid.button_ [Lucid.class_ "navbar-dropdown-btn"] "Tasks ▾" Lucid.div_ [Lucid.class_ "navbar-dropdown-content"] <| do Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "navbar-dropdown-item"] "Ready" Lucid.a_ [Lucid.href_ "/blocked", Lucid.class_ "navbar-dropdown-item"] "Blocked" Lucid.a_ [Lucid.href_ "/intervention", Lucid.class_ "navbar-dropdown-item"] "Human Action" Lucid.a_ [Lucid.href_ "/tasks", Lucid.class_ "navbar-dropdown-item"] "All" Lucid.div_ [Lucid.class_ "navbar-dropdown"] <| do Lucid.button_ [Lucid.class_ "navbar-dropdown-btn"] "Plans ▾" Lucid.div_ [Lucid.class_ "navbar-dropdown-content"] <| do Lucid.a_ [Lucid.href_ "/epics", Lucid.class_ "navbar-dropdown-item"] "Epics" Lucid.a_ [Lucid.href_ "/kb", Lucid.class_ "navbar-dropdown-item"] "KB" Lucid.a_ [Lucid.href_ "/stats", Lucid.class_ "navbar-link"] "Stats" -- * Badges statusBadge :: (Monad m) => TaskCore.Status -> Lucid.HtmlT m () statusBadge status = let (cls, label) = case status of TaskCore.Draft -> ("badge badge-draft", "Draft") TaskCore.Open -> ("badge badge-open", "Open") TaskCore.InProgress -> ("badge badge-inprogress", "In Progress") TaskCore.Review -> ("badge badge-review", "Review") TaskCore.Approved -> ("badge badge-approved", "Approved") TaskCore.Done -> ("badge badge-done", "Done") TaskCore.NeedsHelp -> ("badge badge-needshelp", "Needs Help") in Lucid.span_ [Lucid.class_ cls] label complexityBadge :: (Monad m) => Int -> Lucid.HtmlT m () complexityBadge complexity = let cls = "badge badge-complexity badge-complexity-" <> tshow complexity label = "ℂ " <> tshow complexity in Lucid.span_ [Lucid.class_ cls, Lucid.title_ "Task Complexity (1-5)"] (Lucid.toHtml label) -- * Sort dropdown sortDropdown :: (Monad m) => Text -> SortOrder -> Lucid.HtmlT m () sortDropdown basePath currentSort = Lucid.div_ [Lucid.class_ "sort-dropdown"] <| do Lucid.span_ [Lucid.class_ "sort-label"] "Sort:" Lucid.div_ [Lucid.class_ "sort-dropdown-wrapper navbar-dropdown"] <| do Lucid.button_ [Lucid.class_ "sort-dropdown-btn navbar-dropdown-btn"] <| Lucid.toHtml (sortOrderLabel currentSort <> " ▾") Lucid.div_ [Lucid.class_ "sort-dropdown-content navbar-dropdown-content"] <| do sortOption basePath SortNewest currentSort sortOption basePath SortOldest currentSort sortOption basePath SortUpdated currentSort sortOption basePath SortPriorityHigh currentSort sortOption basePath SortPriorityLow currentSort sortOption :: (Monad m) => Text -> SortOrder -> SortOrder -> Lucid.HtmlT m () sortOption basePath option currentSort = let cls = "sort-dropdown-item navbar-dropdown-item" <> if option == currentSort then " active" else "" href = basePath <> "?sort=" <> sortOrderToParam option in Lucid.a_ [Lucid.href_ href, Lucid.class_ cls] (Lucid.toHtml (sortOrderLabel option)) -- * Progress bars multiColorProgressBar :: (Monad m) => TaskCore.TaskStats -> Lucid.HtmlT m () multiColorProgressBar stats = let total = TaskCore.totalTasks stats doneCount = TaskCore.doneTasks stats inProgressCount = TaskCore.inProgressTasks stats openCount = TaskCore.openTasks stats + TaskCore.reviewTasks stats + TaskCore.approvedTasks stats donePct = if total == 0 then 0 else (doneCount * 100) `div` total inProgressPct = if total == 0 then 0 else (inProgressCount * 100) `div` total openPct = if total == 0 then 0 else (openCount * 100) `div` total in Lucid.div_ [Lucid.class_ "multi-progress-container"] <| do Lucid.div_ [Lucid.class_ "multi-progress-bar"] <| do when (donePct > 0) <| Lucid.div_ [ Lucid.class_ "multi-progress-segment progress-done", Lucid.style_ ("width: " <> tshow donePct <> "%"), Lucid.title_ (tshow doneCount <> " done") ] "" when (inProgressPct > 0) <| Lucid.div_ [ Lucid.class_ "multi-progress-segment progress-inprogress", Lucid.style_ ("width: " <> tshow inProgressPct <> "%"), Lucid.title_ (tshow inProgressCount <> " in progress") ] "" when (openPct > 0) <| Lucid.div_ [ Lucid.class_ "multi-progress-segment progress-open", Lucid.style_ ("width: " <> tshow openPct <> "%"), Lucid.title_ (tshow openCount <> " open") ] "" Lucid.div_ [Lucid.class_ "progress-legend"] <| do Lucid.span_ [Lucid.class_ "legend-item"] <| do Lucid.span_ [Lucid.class_ "legend-dot legend-done"] "" Lucid.toHtml ("Done " <> tshow doneCount) Lucid.span_ [Lucid.class_ "legend-item"] <| do Lucid.span_ [Lucid.class_ "legend-dot legend-inprogress"] "" Lucid.toHtml ("In Progress " <> tshow inProgressCount) Lucid.span_ [Lucid.class_ "legend-item"] <| do Lucid.span_ [Lucid.class_ "legend-dot legend-open"] "" Lucid.toHtml ("Open " <> tshow openCount) epicProgressBar :: (Monad m) => Int -> Int -> Int -> Int -> Lucid.HtmlT m () epicProgressBar doneCount inProgressCount openCount totalCount = let donePct = if totalCount == 0 then 0 else (doneCount * 100) `div` totalCount inProgressPct = if totalCount == 0 then 0 else (inProgressCount * 100) `div` totalCount openPct = if totalCount == 0 then 0 else (openCount * 100) `div` totalCount in Lucid.div_ [Lucid.class_ "multi-progress-container epic-progress"] <| do Lucid.div_ [Lucid.class_ "multi-progress-bar"] <| do when (donePct > 0) <| Lucid.div_ [ Lucid.class_ "multi-progress-segment progress-done", Lucid.style_ ("width: " <> tshow donePct <> "%"), Lucid.title_ (tshow doneCount <> " done") ] "" when (inProgressPct > 0) <| Lucid.div_ [ Lucid.class_ "multi-progress-segment progress-inprogress", Lucid.style_ ("width: " <> tshow inProgressPct <> "%"), Lucid.title_ (tshow inProgressCount <> " in progress") ] "" when (openPct > 0) <| Lucid.div_ [ Lucid.class_ "multi-progress-segment progress-open", Lucid.style_ ("width: " <> tshow openPct <> "%"), Lucid.title_ (tshow openCount <> " open") ] "" Lucid.div_ [Lucid.class_ "progress-legend"] <| do Lucid.span_ [Lucid.class_ "legend-item"] <| do Lucid.span_ [Lucid.class_ "legend-dot legend-done"] "" Lucid.toHtml (tshow doneCount) Lucid.span_ [Lucid.class_ "legend-item"] <| do Lucid.span_ [Lucid.class_ "legend-dot legend-inprogress"] "" Lucid.toHtml (tshow inProgressCount) Lucid.span_ [Lucid.class_ "legend-item"] <| do Lucid.span_ [Lucid.class_ "legend-dot legend-open"] "" Lucid.toHtml (tshow openCount) -- * Status badge with form statusBadgeWithForm :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m () statusBadgeWithForm status tid = Lucid.div_ [ Lucid.id_ "status-badge-container", Lucid.class_ "status-badge-dropdown" ] <| do clickableBadge status tid statusDropdownOptions status tid clickableBadge :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m () clickableBadge status _tid = let (cls, label) = case status of TaskCore.Draft -> ("badge badge-draft status-badge-clickable", "Draft" :: Text) TaskCore.Open -> ("badge badge-open status-badge-clickable", "Open") TaskCore.InProgress -> ("badge badge-inprogress status-badge-clickable", "In Progress") TaskCore.Review -> ("badge badge-review status-badge-clickable", "Review") TaskCore.Approved -> ("badge badge-approved status-badge-clickable", "Approved") TaskCore.Done -> ("badge badge-done status-badge-clickable", "Done") TaskCore.NeedsHelp -> ("badge badge-needshelp status-badge-clickable", "Needs Help") in Lucid.span_ [ Lucid.class_ cls, Lucid.tabindex_ "0", Lucid.role_ "button", Lucid.makeAttribute "aria-haspopup" "true", Lucid.makeAttribute "aria-expanded" "false", Lucid.makeAttribute "onclick" "toggleStatusDropdown(this)", Lucid.makeAttribute "onkeydown" "handleStatusKeydown(event, this)" ] <| do Lucid.toHtml label Lucid.span_ [Lucid.class_ "dropdown-arrow", Lucid.makeAttribute "aria-hidden" "true"] " ▾" statusDropdownOptions :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m () statusDropdownOptions currentStatus tid = Lucid.div_ [ Lucid.class_ "status-dropdown-menu", Lucid.role_ "menu", Lucid.makeAttribute "aria-label" "Change task status" ] <| do statusOption TaskCore.Draft currentStatus tid statusOption TaskCore.Open currentStatus tid statusOption TaskCore.InProgress currentStatus tid statusOption TaskCore.Review currentStatus tid statusOption TaskCore.Approved currentStatus tid statusOption TaskCore.Done currentStatus tid statusOption TaskCore.NeedsHelp currentStatus tid statusOption :: (Monad m) => TaskCore.Status -> TaskCore.Status -> Text -> Lucid.HtmlT m () statusOption opt currentStatus tid = let (cls, label) = case opt of TaskCore.Draft -> ("badge badge-draft", "Draft" :: Text) TaskCore.Open -> ("badge badge-open", "Open") TaskCore.InProgress -> ("badge badge-inprogress", "In Progress") TaskCore.Review -> ("badge badge-review", "Review") TaskCore.Approved -> ("badge badge-approved", "Approved") TaskCore.Done -> ("badge badge-done", "Done") TaskCore.NeedsHelp -> ("badge badge-needshelp", "Needs Help") isSelected = opt == currentStatus optClass = cls <> " status-dropdown-option" <> if isSelected then " selected" else "" in Lucid.form_ [ Lucid.class_ "status-option-form", Lucid.role_ "none", Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/status"), Lucid.makeAttribute "hx-target" "#status-badge-container", Lucid.makeAttribute "hx-swap" "outerHTML" ] <| do Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "status", Lucid.value_ (tshow opt)] Lucid.button_ [ Lucid.type_ "submit", Lucid.class_ optClass, Lucid.role_ "menuitem", Lucid.tabindex_ "-1", Lucid.makeAttribute "onkeydown" "handleMenuItemKeydown(event)" ] (Lucid.toHtml label) -- * Priority badge with form priorityBadgeWithForm :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m () priorityBadgeWithForm priority tid = Lucid.div_ [ Lucid.id_ "priority-badge-container", Lucid.class_ "priority-badge-dropdown" ] <| do clickablePriorityBadge priority tid priorityDropdownOptions priority tid clickablePriorityBadge :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m () clickablePriorityBadge priority _tid = let (cls, label) = case priority of TaskCore.P0 -> ("badge badge-p0 priority-badge-clickable", "P0 Critical" :: Text) TaskCore.P1 -> ("badge badge-p1 priority-badge-clickable", "P1 High") TaskCore.P2 -> ("badge badge-p2 priority-badge-clickable", "P2 Normal") TaskCore.P3 -> ("badge badge-p3 priority-badge-clickable", "P3 Low") TaskCore.P4 -> ("badge badge-p4 priority-badge-clickable", "P4 Defer") in Lucid.span_ [ Lucid.class_ cls, Lucid.tabindex_ "0", Lucid.role_ "button", Lucid.makeAttribute "aria-haspopup" "true", Lucid.makeAttribute "aria-expanded" "false", Lucid.makeAttribute "onclick" "togglePriorityDropdown(this)", Lucid.makeAttribute "onkeydown" "handlePriorityKeydown(event, this)" ] <| do Lucid.toHtml label Lucid.span_ [Lucid.class_ "dropdown-arrow", Lucid.makeAttribute "aria-hidden" "true"] " ▾" priorityDropdownOptions :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m () priorityDropdownOptions currentPriority tid = Lucid.div_ [ Lucid.class_ "priority-dropdown-menu", Lucid.role_ "menu", Lucid.makeAttribute "aria-label" "Change task priority" ] <| do priorityOption TaskCore.P0 currentPriority tid priorityOption TaskCore.P1 currentPriority tid priorityOption TaskCore.P2 currentPriority tid priorityOption TaskCore.P3 currentPriority tid priorityOption TaskCore.P4 currentPriority tid priorityOption :: (Monad m) => TaskCore.Priority -> TaskCore.Priority -> Text -> Lucid.HtmlT m () priorityOption opt currentPriority tid = let (cls, label) = case opt of TaskCore.P0 -> ("badge badge-p0", "P0 Critical" :: Text) TaskCore.P1 -> ("badge badge-p1", "P1 High") TaskCore.P2 -> ("badge badge-p2", "P2 Normal") TaskCore.P3 -> ("badge badge-p3", "P3 Low") TaskCore.P4 -> ("badge badge-p4", "P4 Defer") isSelected = opt == currentPriority optClass = cls <> " priority-dropdown-option" <> if isSelected then " selected" else "" in Lucid.form_ [ Lucid.class_ "priority-option-form", Lucid.role_ "none", Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/priority"), Lucid.makeAttribute "hx-target" "#priority-badge-container", Lucid.makeAttribute "hx-swap" "outerHTML" ] <| do Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "priority", Lucid.value_ (tshow opt)] Lucid.button_ [ Lucid.type_ "submit", Lucid.class_ optClass, Lucid.role_ "menuitem", Lucid.tabindex_ "-1", Lucid.makeAttribute "onkeydown" "handlePriorityMenuItemKeydown(event)" ] (Lucid.toHtml label) -- * Task rendering renderTaskCard :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m () renderTaskCard t = Lucid.a_ [ Lucid.class_ "task-card task-card-link", Lucid.href_ ("/tasks/" <> TaskCore.taskId t) ] <| do Lucid.div_ [Lucid.class_ "task-header"] <| do Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (TaskCore.taskId t)) statusBadge (TaskCore.taskStatus t) Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t))) Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t)) renderBlockedTaskCard :: (Monad m) => (TaskCore.Task, Int) -> Lucid.HtmlT m () renderBlockedTaskCard (t, impact) = Lucid.a_ [ Lucid.class_ "task-card task-card-link", Lucid.href_ ("/tasks/" <> TaskCore.taskId t) ] <| do Lucid.div_ [Lucid.class_ "task-header"] <| do Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (TaskCore.taskId t)) statusBadge (TaskCore.taskStatus t) Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t))) when (impact > 0) <| Lucid.span_ [Lucid.class_ "blocking-impact"] (Lucid.toHtml ("Blocks " <> tshow impact)) Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t)) renderListGroupItem :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m () renderListGroupItem t = Lucid.a_ [ Lucid.class_ "list-group-item", Lucid.href_ ("/tasks/" <> TaskCore.taskId t), Lucid.makeAttribute "hx-boost" "true", Lucid.makeAttribute "hx-target" "body", Lucid.makeAttribute "hx-swap" "innerHTML" ] <| do Lucid.div_ [Lucid.class_ "list-group-item-content"] <| do Lucid.span_ [Lucid.class_ "list-group-item-id"] (Lucid.toHtml (TaskCore.taskId t)) Lucid.span_ [Lucid.class_ "list-group-item-title"] (Lucid.toHtml (TaskCore.taskTitle t)) Lucid.div_ [Lucid.class_ "list-group-item-meta"] <| do statusBadge (TaskCore.taskStatus t) Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t))) renderEpicReviewCard :: (Monad m) => TaskCore.EpicForReview -> Lucid.HtmlT m () renderEpicReviewCard epicReview = do let task = TaskCore.epicTask epicReview total = TaskCore.epicTotal epicReview completed = TaskCore.epicCompleted epicReview progressText = tshow completed <> "/" <> tshow total <> " subtasks done" Lucid.div_ [Lucid.class_ "task-card"] <| do Lucid.div_ [Lucid.class_ "task-card-header"] <| do Lucid.div_ [Lucid.class_ "task-title-row"] <| do Lucid.a_ [Lucid.href_ ("/tasks/" <> TaskCore.taskId task), Lucid.class_ "task-link"] <| Lucid.toHtml (TaskCore.taskTitle task) Lucid.span_ [Lucid.class_ "badge badge-epic"] "Epic" Lucid.span_ [Lucid.class_ "task-id"] <| Lucid.toHtml (TaskCore.taskId task) Lucid.div_ [Lucid.class_ "task-card-body"] <| do Lucid.div_ [Lucid.class_ "progress-info"] <| do Lucid.span_ [Lucid.class_ "badge badge-success"] <| Lucid.toHtml progressText Lucid.div_ [Lucid.class_ "epic-actions"] <| do Lucid.form_ [ Lucid.method_ "POST", Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/status"), Lucid.class_ "inline-form" ] <| do Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "status", Lucid.value_ "done"] Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-success btn-sm"] "Approve & Close" renderEpicCardWithStats :: (Monad m) => [TaskCore.Task] -> TaskCore.Task -> Lucid.HtmlT m () renderEpicCardWithStats allTasks t = let children = getDescendants allTasks (TaskCore.taskId t) openCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Open] inProgressCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.InProgress] reviewCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Review] doneCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Done] totalCount = length children openAndReview = openCount + reviewCount in Lucid.a_ [ Lucid.class_ "task-card task-card-link", Lucid.href_ ("/tasks/" <> TaskCore.taskId t) ] <| do Lucid.div_ [Lucid.class_ "task-header"] <| do Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (TaskCore.taskId t)) statusBadge (TaskCore.taskStatus t) Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t))) Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t)) when (totalCount > 0) <| epicProgressBar doneCount inProgressCount openAndReview totalCount unless (Text.null (TaskCore.taskDescription t)) <| Lucid.p_ [Lucid.class_ "kb-preview"] (Lucid.toHtml (Text.take 200 (TaskCore.taskDescription t) <> "...")) getDescendants :: [TaskCore.Task] -> Text -> [TaskCore.Task] getDescendants allTasks parentId = let children = [c | c <- allTasks, maybe False (TaskCore.matchesId parentId) (TaskCore.taskParent c)] in children ++ concatMap (getDescendants allTasks <. TaskCore.taskId) children -- * Aggregated metrics renderAggregatedMetrics :: (Monad m) => [TaskCore.Task] -> TaskCore.Task -> TaskCore.AggregatedMetrics -> Lucid.HtmlT m () renderAggregatedMetrics allTasks task metrics = let descendants = getDescendants allTasks (TaskCore.taskId task) totalCount = length descendants costCents = TaskCore.aggTotalCostCents metrics durationSecs = TaskCore.aggTotalDurationSeconds metrics completedCount = TaskCore.aggCompletedTasks metrics tokensUsed = TaskCore.aggTotalTokens metrics in Lucid.div_ [Lucid.class_ "detail-section aggregated-metrics"] <| do Lucid.h3_ "Execution Summary" Lucid.div_ [Lucid.class_ "metrics-grid"] <| do Lucid.div_ [Lucid.class_ "metric-card"] <| do Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (tshow completedCount <> "/" <> tshow totalCount)) Lucid.div_ [Lucid.class_ "metric-label"] "Tasks Completed" Lucid.div_ [Lucid.class_ "metric-card"] <| do Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCostMetric costCents)) Lucid.div_ [Lucid.class_ "metric-label"] "Total Cost" Lucid.div_ [Lucid.class_ "metric-card"] <| do Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDurationMetric durationSecs)) Lucid.div_ [Lucid.class_ "metric-label"] "Total Time" when (tokensUsed > 0) <| do Lucid.div_ [Lucid.class_ "metric-card"] <| do Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatTokensMetric tokensUsed)) Lucid.div_ [Lucid.class_ "metric-label"] "Tokens Used" where formatCostMetric :: Int -> Text formatCostMetric cents = let dollars = fromIntegral cents / 100.0 :: Double in "$" <> Text.pack (showFFloat (Just 2) dollars "") formatDurationMetric :: Int -> Text formatDurationMetric secs | secs < 60 = tshow secs <> "s" | secs < 3600 = let mins = secs `div` 60 remSecs = secs `mod` 60 in tshow mins <> "m " <> tshow remSecs <> "s" | otherwise = let hrs = secs `div` 3600 mins = (secs `mod` 3600) `div` 60 in tshow hrs <> "h " <> tshow mins <> "m" formatTokensMetric :: Int -> Text formatTokensMetric t | t < 1000 = tshow t | t < 1000000 = Text.pack (showFFloat (Just 1) (fromIntegral t / 1000.0 :: Double) "") <> "K" | otherwise = Text.pack (showFFloat (Just 2) (fromIntegral t / 1000000.0 :: Double) "") <> "M" -- * Retry context banner renderRetryContextBanner :: (Monad m) => Text -> Maybe TaskCore.RetryContext -> Lucid.HtmlT m () renderRetryContextBanner _ Nothing = pure () renderRetryContextBanner tid (Just ctx) = Lucid.div_ [Lucid.class_ bannerClass] <| do Lucid.div_ [Lucid.class_ "retry-banner-header"] <| do Lucid.span_ [Lucid.class_ "retry-icon"] retryIcon Lucid.span_ [Lucid.class_ "retry-attempt"] (Lucid.toHtml attemptText) when maxRetriesExceeded <| Lucid.span_ [Lucid.class_ "retry-warning-badge"] "Needs Human Intervention" Lucid.div_ [Lucid.class_ "retry-banner-details"] <| do Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do Lucid.span_ [Lucid.class_ "retry-label"] "Failure Reason:" Lucid.span_ [Lucid.class_ "retry-value"] (Lucid.toHtml (summarizeReason (TaskCore.retryReason ctx))) let commit = TaskCore.retryOriginalCommit ctx unless (Text.null commit) <| do Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do Lucid.span_ [Lucid.class_ "retry-label"] "Original Commit:" Lucid.code_ [Lucid.class_ "retry-commit"] (Lucid.toHtml (Text.take 8 commit)) let conflicts = TaskCore.retryConflictFiles ctx unless (null conflicts) <| do Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do Lucid.span_ [Lucid.class_ "retry-label"] "Conflict Files:" Lucid.ul_ [Lucid.class_ "retry-conflict-list"] <| traverse_ (Lucid.li_ <. Lucid.toHtml) conflicts when maxRetriesExceeded <| do Lucid.div_ [Lucid.class_ "retry-warning-message"] "This task has exceeded the maximum number of retries. A human must review the failure and either fix the issue manually or reset the retry count." Lucid.p_ [Lucid.class_ "retry-hint"] "Use comments below to provide guidance for retry." Lucid.div_ [Lucid.class_ "retry-reset-section"] <| do Lucid.h4_ "Reset Retries" Lucid.p_ [Lucid.class_ "notes-help"] "Clear retry context and give task a fresh start:" Lucid.form_ [Lucid.method_ "POST", Lucid.action_ ("/tasks/" <> tid <> "/reset-retries")] <| do Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "reset-btn"] "Reset Retries" where attempt = TaskCore.retryAttempt ctx maxRetriesExceeded = attempt >= 3 bannerClass = if maxRetriesExceeded then "retry-banner retry-banner-critical" else "retry-banner retry-banner-warning" retryIcon = if maxRetriesExceeded then "⚠" else "↻" attemptText = "Attempt " <> tshow attempt <> " of 3" summarizeReason :: Text -> Text summarizeReason reason | "rejected:" `Text.isPrefixOf` reason = "Rejected: " <> Text.strip (Text.drop 9 reason) | "Test failure:" `Text.isPrefixOf` reason = "Test failure (see details below)" | "MERGE CONFLICT" `Text.isPrefixOf` reason = "Merge conflict with concurrent changes" | otherwise = Text.take 100 reason <> if Text.length reason > 100 then "..." else "" -- * Markdown rendering renderMarkdown :: (Monad m) => Text -> Lucid.HtmlT m () renderMarkdown input = renderBlocks (parseBlocks (Text.lines input)) data MarkdownBlock = MdHeader Int Text | MdParagraph [Text] | MdCodeBlock [Text] | MdList [Text] deriving (Show, Eq) parseBlocks :: [Text] -> [MarkdownBlock] parseBlocks [] = [] parseBlocks lns = case lns of (l : rest) | "```" `Text.isPrefixOf` l -> let (codeLines, afterCode) = List.span (not <. Text.isPrefixOf "```") rest remaining = List.drop 1 afterCode in MdCodeBlock codeLines : parseBlocks remaining | "### " `Text.isPrefixOf` l -> MdHeader 3 (Text.drop 4 l) : parseBlocks rest | "## " `Text.isPrefixOf` l -> MdHeader 2 (Text.drop 3 l) : parseBlocks rest | "# " `Text.isPrefixOf` l -> MdHeader 1 (Text.drop 2 l) : parseBlocks rest | isListItem l -> let (listLines, afterList) = List.span isListItem lns in MdList (map stripListPrefix listLines) : parseBlocks afterList | Text.null (Text.strip l) -> parseBlocks rest | otherwise -> let (paraLines, afterPara) = List.span isParagraphLine lns in MdParagraph paraLines : parseBlocks afterPara where isListItem t = let stripped = Text.stripStart t in "- " `Text.isPrefixOf` stripped || "* " `Text.isPrefixOf` stripped stripListPrefix t = let stripped = Text.stripStart t in Text.drop 2 stripped isParagraphLine t = not (Text.null (Text.strip t)) && not ("```" `Text.isPrefixOf` t) && not ("#" `Text.isPrefixOf` t) && not (isListItem t) renderBlocks :: (Monad m) => [MarkdownBlock] -> Lucid.HtmlT m () renderBlocks = traverse_ renderBlock renderBlock :: (Monad m) => MarkdownBlock -> Lucid.HtmlT m () renderBlock block = case block of MdHeader 1 txt -> Lucid.h2_ [Lucid.class_ "md-h1"] (renderInline txt) MdHeader 2 txt -> Lucid.h3_ [Lucid.class_ "md-h2"] (renderInline txt) MdHeader 3 txt -> Lucid.h4_ [Lucid.class_ "md-h3"] (renderInline txt) MdHeader _ txt -> Lucid.h4_ (renderInline txt) MdParagraph lns -> Lucid.p_ [Lucid.class_ "md-para"] (renderInline (Text.unlines lns)) MdCodeBlock lns -> Lucid.pre_ [Lucid.class_ "md-code"] (Lucid.code_ (Lucid.toHtml (Text.unlines lns))) MdList items -> Lucid.ul_ [Lucid.class_ "md-list"] (traverse_ renderListItem items) renderListItem :: (Monad m) => Text -> Lucid.HtmlT m () renderListItem txt = Lucid.li_ (renderInline txt) renderInline :: (Monad m) => Text -> Lucid.HtmlT m () renderInline txt = renderInlineParts (parseInline txt) data InlinePart = PlainText Text | InlineCode Text | BoldText Text deriving (Show, Eq) parseInline :: Text -> [InlinePart] parseInline t | Text.null t = [] | otherwise = case Text.breakOn "`" t of (before, rest) | Text.null rest -> parseBold before | otherwise -> let afterTick = Text.drop 1 rest in case Text.breakOn "`" afterTick of (code, rest2) | Text.null rest2 -> parseBold before ++ [PlainText ("`" <> afterTick)] | otherwise -> parseBold before ++ [InlineCode code] ++ parseInline (Text.drop 1 rest2) parseBold :: Text -> [InlinePart] parseBold t | Text.null t = [] | otherwise = case Text.breakOn "**" t of (before, rest) | Text.null rest -> [PlainText before | not (Text.null before)] | otherwise -> let afterBold = Text.drop 2 rest in case Text.breakOn "**" afterBold of (boldText, rest2) | Text.null rest2 -> [PlainText before | not (Text.null before)] ++ [PlainText ("**" <> afterBold)] | otherwise -> [PlainText before | not (Text.null before)] ++ [BoldText boldText] ++ parseBold (Text.drop 2 rest2) renderInlineParts :: (Monad m) => [InlinePart] -> Lucid.HtmlT m () renderInlineParts = traverse_ renderInlinePart renderInlinePart :: (Monad m) => InlinePart -> Lucid.HtmlT m () renderInlinePart part = case part of PlainText txt -> Lucid.toHtml txt InlineCode txt -> Lucid.code_ [Lucid.class_ "md-inline-code"] (Lucid.toHtml txt) BoldText txt -> Lucid.strong_ (Lucid.toHtml txt) -- * Comment form commentForm :: (Monad m) => Text -> Lucid.HtmlT m () commentForm tid = Lucid.form_ [ Lucid.method_ "POST", Lucid.action_ ("/tasks/" <> tid <> "/comment"), Lucid.class_ "comment-form" ] <| do Lucid.textarea_ [ Lucid.name_ "comment", Lucid.placeholder_ "Add a comment...", Lucid.rows_ "3", Lucid.class_ "comment-textarea" ] "" Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Post Comment" -- * Live toggles renderLiveToggle :: (Monad m) => Lucid.HtmlT m () renderLiveToggle = Lucid.button_ [ Lucid.class_ "timeline-live-toggle", Lucid.id_ "live-toggle", Lucid.makeAttribute "onclick" "toggleLiveUpdates()", Lucid.title_ "Click to pause/resume live updates" ] " LIVE" renderAutoscrollToggle :: (Monad m) => Lucid.HtmlT m () renderAutoscrollToggle = Lucid.button_ [ Lucid.class_ "timeline-autoscroll-toggle", Lucid.id_ "autoscroll-toggle", Lucid.makeAttribute "onclick" "toggleAutoscroll()", Lucid.title_ "Toggle automatic scrolling to newest events" ] " ⬇ Auto-scroll" -- * Cost/Token metrics aggregateCostMetrics :: [TaskCore.StoredEvent] -> (Int, Int) aggregateCostMetrics events = let costEvents = filter (\e -> TaskCore.storedEventType e == "Cost") events aggregateOne (totalCents, totalTokens) event = case Aeson.decode (LBS.fromStrict (str (TaskCore.storedEventContent event))) of Just (Aeson.Object obj) -> let cents = case KeyMap.lookup "cents" obj of Just (Aeson.Number n) -> floor n _ -> 0 tokens = case KeyMap.lookup "tokens" obj of Just (Aeson.Number n) -> floor n _ -> 0 in (totalCents + cents, totalTokens + tokens) _ -> (totalCents, totalTokens) in foldl' aggregateOne (0, 0) costEvents formatCostHeader :: Int -> Text formatCostHeader cents = let dollars = fromIntegral cents / 100.0 :: Double in "$" <> Text.pack (showFFloat (Just 2) dollars "") formatTokensHeader :: Int -> Text formatTokensHeader t | t < 1000 = tshow t | t < 1000000 = Text.pack (showFFloat (Just 1) (fromIntegral t / 1000.0 :: Double) "") <> "K" | otherwise = Text.pack (showFFloat (Just 2) (fromIntegral t / 1000000.0 :: Double) "") <> "M" -- * Timeline renderUnifiedTimeline :: (Monad m) => Text -> [TaskCore.Comment] -> [TaskCore.StoredEvent] -> TaskCore.Status -> UTCTime -> Lucid.HtmlT m () renderUnifiedTimeline tid legacyComments events status now = do let isInProgress = status == TaskCore.InProgress pollAttrs = if isInProgress then [ Lucid.makeAttribute "hx-get" ("/partials/task/" <> tid <> "/events"), Lucid.makeAttribute "hx-trigger" "every 3s", Lucid.makeAttribute "hx-swap" "innerHTML", Lucid.makeAttribute "hx-on::before-request" "var log = this.querySelector('.timeline-events'); if(log) this.dataset.scroll = log.scrollTop", Lucid.makeAttribute "hx-on::after-swap" "var log = this.querySelector('.timeline-events'); if(log && this.dataset.scroll) log.scrollTop = this.dataset.scroll" ] else [] nonCostEvents = filter (\e -> TaskCore.storedEventType e /= "Cost") events eventCount = length nonCostEvents + length legacyComments (totalCents, totalTokens) = aggregateCostMetrics events Lucid.div_ ([Lucid.class_ "unified-timeline-section", Lucid.id_ "unified-timeline"] <> pollAttrs) <| do Lucid.h3_ <| do Lucid.toHtml ("Timeline (" <> tshow eventCount <> ")") when (totalCents > 0 || totalTokens > 0) <| do Lucid.span_ [Lucid.class_ "timeline-cost-summary"] <| do metaSep when (totalCents > 0) <| Lucid.toHtml (formatCostHeader totalCents) when (totalCents > 0 && totalTokens > 0) <| metaSep when (totalTokens > 0) <| Lucid.toHtml (formatTokensHeader totalTokens <> " tokens") when isInProgress <| do renderLiveToggle renderAutoscrollToggle if null nonCostEvents && null legacyComments then Lucid.p_ [Lucid.class_ "empty-msg"] "No activity yet." else do Lucid.div_ [Lucid.class_ "timeline-events"] <| do traverse_ (renderTimelineEvent now) nonCostEvents when isInProgress <| timelineScrollScript commentForm tid renderTimelineEvent :: (Monad m) => UTCTime -> TaskCore.StoredEvent -> Lucid.HtmlT m () renderTimelineEvent now event = let eventType = TaskCore.storedEventType event content = TaskCore.storedEventContent event timestamp = TaskCore.storedEventTimestamp event actor = TaskCore.storedEventActor event eventId = TaskCore.storedEventId event (icon, label) = eventTypeIconAndLabel eventType in Lucid.div_ [ Lucid.class_ ("timeline-event timeline-event-" <> eventType), Lucid.makeAttribute "data-event-id" (tshow eventId) ] <| do case eventType of "comment" -> renderCommentTimelineEvent content actor timestamp now "status_change" -> renderStatusChangeEvent content actor timestamp now "claim" -> renderActivityEvent icon label content actor timestamp now "running" -> renderActivityEvent icon label content actor timestamp now "reviewing" -> renderActivityEvent icon label content actor timestamp now "retrying" -> renderActivityEvent icon label content actor timestamp now "complete" -> renderActivityEvent icon label content actor timestamp now "error" -> renderErrorTimelineEvent content actor timestamp now "Assistant" -> renderAssistantTimelineEvent content actor timestamp now "ToolCall" -> renderToolCallTimelineEvent content actor timestamp now "ToolResult" -> renderToolResultTimelineEvent content actor timestamp now "Cost" -> pure () "Checkpoint" -> renderCheckpointEvent content actor timestamp now "Guardrail" -> renderGuardrailEvent content actor timestamp now _ -> renderGenericEvent eventType content actor timestamp now eventTypeIconAndLabel :: Text -> (Text, Text) eventTypeIconAndLabel "comment" = ("💬", "Comment") eventTypeIconAndLabel "status_change" = ("🔄", "Status") eventTypeIconAndLabel "claim" = ("🤖", "Claimed") eventTypeIconAndLabel "running" = ("▶️", "Running") eventTypeIconAndLabel "reviewing" = ("👀", "Reviewing") eventTypeIconAndLabel "retrying" = ("🔁", "Retrying") eventTypeIconAndLabel "complete" = ("✅", "Complete") eventTypeIconAndLabel "error" = ("❌", "Error") eventTypeIconAndLabel "Assistant" = ("💭", "Thought") eventTypeIconAndLabel "ToolCall" = ("🔧", "Tool") eventTypeIconAndLabel "ToolResult" = ("📄", "Result") eventTypeIconAndLabel "Cost" = ("💰", "Cost") eventTypeIconAndLabel "Checkpoint" = ("📍", "Checkpoint") eventTypeIconAndLabel "Guardrail" = ("⚠️", "Guardrail") eventTypeIconAndLabel t = ("📝", t) renderActorLabel :: (Monad m) => TaskCore.CommentAuthor -> Lucid.HtmlT m () renderActorLabel actor = let (cls, label) :: (Text, Text) = case actor of TaskCore.Human -> ("actor-human", "human") TaskCore.Junior -> ("actor-junior", "junior") TaskCore.System -> ("actor-system", "system") in Lucid.span_ [Lucid.class_ ("actor-label " <> cls)] (Lucid.toHtml ("[" <> label <> "]")) renderCommentTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m () renderCommentTimelineEvent content actor timestamp now = Lucid.div_ [Lucid.class_ "timeline-comment"] <| do Lucid.div_ [Lucid.class_ "event-header"] <| do Lucid.span_ [Lucid.class_ "event-icon"] "💬" renderActorLabel actor renderRelativeTimestamp now timestamp Lucid.div_ [Lucid.class_ "event-content comment-bubble markdown-content"] <| do renderMarkdown content renderStatusChangeEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m () renderStatusChangeEvent content actor timestamp now = Lucid.div_ [Lucid.class_ "timeline-status-change"] <| do Lucid.span_ [Lucid.class_ "event-icon"] "🔄" renderActorLabel actor Lucid.span_ [Lucid.class_ "status-change-text"] (Lucid.toHtml (parseStatusChange content)) renderRelativeTimestamp now timestamp parseStatusChange :: Text -> Text parseStatusChange content = case Aeson.decode (LBS.fromStrict (str content)) of Just (Aeson.Object obj) -> let fromStatus = case KeyMap.lookup "from" obj of Just (Aeson.String s) -> s _ -> "?" toStatus = case KeyMap.lookup "to" obj of Just (Aeson.String s) -> s _ -> "?" in fromStatus <> " → " <> toStatus _ -> content renderActivityEvent :: (Monad m) => Text -> Text -> Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m () renderActivityEvent icon label content actor timestamp now = Lucid.div_ [Lucid.class_ "timeline-activity"] <| do Lucid.span_ [Lucid.class_ "event-icon"] (Lucid.toHtml icon) Lucid.span_ [Lucid.class_ "event-label"] (Lucid.toHtml label) renderActorLabel actor unless (Text.null content) <| Lucid.span_ [Lucid.class_ "activity-detail"] (Lucid.toHtml content) renderRelativeTimestamp now timestamp renderErrorTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m () renderErrorTimelineEvent content actor timestamp now = Lucid.div_ [Lucid.class_ "timeline-error"] <| do Lucid.div_ [Lucid.class_ "event-header"] <| do Lucid.span_ [Lucid.class_ "event-icon"] "❌" Lucid.span_ [Lucid.class_ "event-label"] "Error" renderActorLabel actor renderRelativeTimestamp now timestamp Lucid.div_ [Lucid.class_ "event-content error-message"] (Lucid.toHtml content) renderAssistantTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m () renderAssistantTimelineEvent content _actor timestamp now = Lucid.div_ [Lucid.class_ "timeline-thought"] <| do Lucid.div_ [Lucid.class_ "event-header"] <| do Lucid.span_ [Lucid.class_ "event-icon"] "💭" Lucid.span_ [Lucid.class_ "event-label"] "Thought" renderActorLabel TaskCore.Junior renderRelativeTimestamp now timestamp Lucid.div_ [Lucid.class_ "event-content thought-bubble markdown-content"] <| do let truncated = Text.take 2000 content isTruncated = Text.length content > 2000 renderMarkdown truncated when isTruncated <| Lucid.span_ [Lucid.class_ "event-truncated"] "..." renderToolCallTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m () renderToolCallTimelineEvent content _actor timestamp now = let (toolName, args) = parseToolCallContent content summary = formatToolCallSummary toolName args in Lucid.details_ [Lucid.class_ "timeline-tool-call"] <| do Lucid.summary_ <| do Lucid.span_ [Lucid.class_ "event-icon"] "🔧" Lucid.span_ [Lucid.class_ "tool-name"] (Lucid.toHtml toolName) Lucid.span_ [Lucid.class_ "tool-summary"] (Lucid.toHtml summary) renderRelativeTimestamp now timestamp Lucid.div_ [Lucid.class_ "event-content tool-args"] <| do renderCollapsibleOutput args renderToolResultTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m () renderToolResultTimelineEvent content _actor timestamp now = let lineCount = length (Text.lines content) in Lucid.details_ [Lucid.class_ "timeline-tool-result"] <| do Lucid.summary_ <| do Lucid.span_ [Lucid.class_ "event-icon"] "📄" Lucid.span_ [Lucid.class_ "event-label"] "Result" when (lineCount > 1) <| Lucid.span_ [Lucid.class_ "line-count"] (Lucid.toHtml (tshow lineCount <> " lines")) renderRelativeTimestamp now timestamp Lucid.pre_ [Lucid.class_ "event-content tool-output"] (renderDecodedToolResult content) renderCheckpointEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m () renderCheckpointEvent content actor timestamp now = Lucid.div_ [Lucid.class_ "timeline-checkpoint"] <| do Lucid.div_ [Lucid.class_ "event-header"] <| do Lucid.span_ [Lucid.class_ "event-icon"] "📍" Lucid.span_ [Lucid.class_ "event-label"] "Checkpoint" renderActorLabel actor renderRelativeTimestamp now timestamp Lucid.div_ [Lucid.class_ "event-content checkpoint-content"] (Lucid.toHtml content) renderGuardrailEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m () renderGuardrailEvent content actor timestamp now = Lucid.div_ [Lucid.class_ "timeline-guardrail"] <| do Lucid.div_ [Lucid.class_ "event-header"] <| do Lucid.span_ [Lucid.class_ "event-icon"] "⚠️" Lucid.span_ [Lucid.class_ "event-label"] "Guardrail" renderActorLabel actor renderRelativeTimestamp now timestamp Lucid.div_ [Lucid.class_ "event-content guardrail-content"] (Lucid.toHtml content) renderGenericEvent :: (Monad m) => Text -> Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m () renderGenericEvent eventType content actor timestamp now = Lucid.div_ [Lucid.class_ "timeline-generic"] <| do Lucid.div_ [Lucid.class_ "event-header"] <| do Lucid.span_ [Lucid.class_ "event-icon"] "📝" Lucid.span_ [Lucid.class_ "event-label"] (Lucid.toHtml eventType) renderActorLabel actor renderRelativeTimestamp now timestamp unless (Text.null content) <| Lucid.div_ [Lucid.class_ "event-content"] (Lucid.toHtml content) parseToolCallContent :: Text -> (Text, Text) parseToolCallContent content = case Text.breakOn ":" content of (name, rest) | Text.null rest -> (content, "") | otherwise -> (Text.strip name, Text.strip (Text.drop 1 rest)) formatToolCallSummary :: Text -> Text -> Text formatToolCallSummary toolName argsJson = case Aeson.decode (LBS.fromStrict (str argsJson)) of Just (Aeson.Object obj) -> let keyArg = case toolName of "run_bash" -> KeyMap.lookup "command" obj "read_file" -> KeyMap.lookup "path" obj "edit_file" -> KeyMap.lookup "path" obj "write_file" -> KeyMap.lookup "path" obj "search_codebase" -> KeyMap.lookup "pattern" obj "glob_files" -> KeyMap.lookup "pattern" obj "list_directory" -> KeyMap.lookup "path" obj _ -> Nothing in case keyArg of Just (Aeson.String s) -> "`" <> Text.take 100 s <> "`" _ -> Text.take 80 argsJson _ -> Text.take 80 argsJson renderCollapsibleOutput :: (Monad m) => Text -> Lucid.HtmlT m () renderCollapsibleOutput content = let lineCount = length (Text.lines content) in if lineCount > 20 then Lucid.details_ [Lucid.class_ "output-collapsible"] <| do Lucid.summary_ (Lucid.toHtml (tshow lineCount <> " lines")) Lucid.pre_ [Lucid.class_ "tool-output-pre"] (Lucid.toHtml content) else Lucid.pre_ [Lucid.class_ "tool-output-pre"] (Lucid.toHtml content) renderDecodedToolResult :: (Monad m) => Text -> Lucid.HtmlT m () renderDecodedToolResult content = case Aeson.decode (LBS.fromStrict (str content)) of Just (Aeson.Object obj) -> case KeyMap.lookup "output" obj of Just (Aeson.String output) -> Lucid.toHtml output _ -> Lucid.toHtml content _ -> Lucid.toHtml content timelineScrollScript :: (Monad m) => Lucid.HtmlT m () timelineScrollScript = Lucid.script_ [ Lucid.type_ "text/javascript" ] ( Text.unlines [ "(function() {", " var log = document.querySelector('.timeline-events');", " if (log) {", " var isNearBottom = log.scrollHeight - log.scrollTop - log.clientHeight < 100;", " if (isNearBottom) {", " log.scrollTop = log.scrollHeight;", " }", " }", "})();" ] )