diff options
Diffstat (limited to 'Omni/Jr/Web/Components.hs')
| -rw-r--r-- | Omni/Jr/Web/Components.hs | 1751 |
1 files changed, 1751 insertions, 0 deletions
diff --git a/Omni/Jr/Web/Components.hs b/Omni/Jr/Web/Components.hs new file mode 100644 index 0000000..ac36131 --- /dev/null +++ b/Omni/Jr/Web/Components.hs @@ -0,0 +1,1751 @@ +{-# 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, + complexityDropdownJs, + liveToggleJs, + + -- * Breadcrumbs + Breadcrumb (..), + Breadcrumbs, + renderBreadcrumbs, + getAncestors, + taskBreadcrumbs, + + -- * Badges + statusBadge, + complexityBadge, + statusBadgeWithForm, + clickableBadge, + statusDropdownOptions, + statusOption, + priorityBadgeWithForm, + clickablePriorityBadge, + priorityDropdownOptions, + priorityOption, + complexityBadgeWithForm, + clickableComplexityBadge, + complexityDropdownOptions, + complexityOption, + + -- * Sorting + 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, + renderFormattedJson, + timelineScrollScript, + + -- * Tool rendering helpers + renderBashToolCall, + renderReadToolCall, + renderEditToolCall, + renderSearchToolCall, + renderSearchAndReadToolCall, + renderWriteToolCall, + renderGenericToolCall, + extractJsonField, + extractJsonFieldInt, + shortenPath, + DecodedToolResult (..), + decodeToolResult, + ) +where + +import Alpha +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as AesonKey +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 Omni.Jr.Web.Types (SortOrder (..), sortOrderLabel, sortOrderToParam) +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"] "·" + +-- * 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_ [] complexityDropdownJs + 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);", + " }", + " });", + "});" + ] + +complexityDropdownJs :: Text +complexityDropdownJs = + Text.unlines + [ "function toggleComplexityDropdown(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 closeComplexityDropdown(container) {", + " container.classList.remove('open');", + " var badge = container.querySelector('[role=\"button\"]');", + " if (badge) {", + " badge.setAttribute('aria-expanded', 'false');", + " badge.focus();", + " }", + "}", + "", + "function handleComplexityKeydown(event, el) {", + " if (event.key === 'Enter' || event.key === ' ') {", + " event.preventDefault();", + " toggleComplexityDropdown(el);", + " } else if (event.key === 'Escape') {", + " closeComplexityDropdown(el.parentElement);", + " } else if (event.key === 'ArrowDown') {", + " event.preventDefault();", + " var container = el.parentElement;", + " if (!container.classList.contains('open')) {", + " toggleComplexityDropdown(el);", + " } else {", + " var firstItem = container.querySelector('[role=\"menuitem\"]');", + " if (firstItem) firstItem.focus();", + " }", + " }", + "}", + "", + "function handleComplexityMenuItemKeydown(event) {", + " var container = event.target.closest('.complexity-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();", + " closeComplexityDropdown(container);", + " } else if (event.key === 'Tab') {", + " closeComplexityDropdown(container);", + " }", + "}", + "", + "document.addEventListener('click', function(e) {", + " var dropdowns = document.querySelectorAll('.complexity-badge-dropdown.open');", + " dropdowns.forEach(function(d) {", + " if (!d.contains(e.target)) {", + " closeComplexityDropdown(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) + +-- * Complexity badge with form + +complexityBadgeWithForm :: (Monad m) => Maybe Int -> Text -> Lucid.HtmlT m () +complexityBadgeWithForm complexity tid = + Lucid.div_ + [ Lucid.id_ "complexity-badge-container", + Lucid.class_ "complexity-badge-dropdown" + ] + <| do + clickableComplexityBadge complexity tid + complexityDropdownOptions complexity tid + +clickableComplexityBadge :: (Monad m) => Maybe Int -> Text -> Lucid.HtmlT m () +clickableComplexityBadge complexity _tid = + let (cls, label) = case complexity of + Nothing -> ("badge badge-complexity-none complexity-badge-clickable", "Set Complexity" :: Text) + Just 1 -> ("badge badge-complexity-1 complexity-badge-clickable", "ℂ 1") + Just 2 -> ("badge badge-complexity-2 complexity-badge-clickable", "ℂ 2") + Just 3 -> ("badge badge-complexity-3 complexity-badge-clickable", "ℂ 3") + Just 4 -> ("badge badge-complexity-4 complexity-badge-clickable", "ℂ 4") + Just 5 -> ("badge badge-complexity-5 complexity-badge-clickable", "ℂ 5") + Just _ -> ("badge badge-complexity-none complexity-badge-clickable", "Invalid") + 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" "toggleComplexityDropdown(this)", + Lucid.makeAttribute "onkeydown" "handleComplexityKeydown(event, this)" + ] + <| do + Lucid.toHtml label + Lucid.span_ [Lucid.class_ "dropdown-arrow", Lucid.makeAttribute "aria-hidden" "true"] " ▾" + +complexityDropdownOptions :: (Monad m) => Maybe Int -> Text -> Lucid.HtmlT m () +complexityDropdownOptions currentComplexity tid = + Lucid.div_ + [ Lucid.class_ "complexity-dropdown-menu", + Lucid.role_ "menu", + Lucid.makeAttribute "aria-label" "Change task complexity" + ] + <| do + complexityOption Nothing currentComplexity tid + complexityOption (Just 1) currentComplexity tid + complexityOption (Just 2) currentComplexity tid + complexityOption (Just 3) currentComplexity tid + complexityOption (Just 4) currentComplexity tid + complexityOption (Just 5) currentComplexity tid + +complexityOption :: (Monad m) => Maybe Int -> Maybe Int -> Text -> Lucid.HtmlT m () +complexityOption opt currentComplexity tid = + let (cls, label, val) = case opt of + Nothing -> ("badge badge-complexity-none", "None" :: Text, "none" :: Text) + Just 1 -> ("badge badge-complexity-1", "ℂ 1", "1") + Just 2 -> ("badge badge-complexity-2", "ℂ 2", "2") + Just 3 -> ("badge badge-complexity-3", "ℂ 3", "3") + Just 4 -> ("badge badge-complexity-4", "ℂ 4", "4") + Just 5 -> ("badge badge-complexity-5", "ℂ 5", "5") + Just _ -> ("badge badge-complexity-none", "Invalid", "none") + isSelected = opt == currentComplexity + optClass = cls <> " complexity-dropdown-option" <> if isSelected then " selected" else "" + in Lucid.form_ + [ Lucid.class_ "complexity-option-form", + Lucid.role_ "none", + Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/complexity"), + Lucid.makeAttribute "hx-target" "#complexity-badge-container", + Lucid.makeAttribute "hx-swap" "outerHTML" + ] + <| do + Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "complexity", Lucid.value_ val] + Lucid.button_ + [ Lucid.type_ "submit", + Lucid.class_ optClass, + Lucid.role_ "menuitem", + Lucid.tabindex_ "-1", + Lucid.makeAttribute "onkeydown" "handleComplexityMenuItemKeydown(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"] (renderFormattedJson 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, argsJson) = parseToolCallContent content + in case toolName of + "run_bash" -> renderBashToolCall argsJson + "read_file" -> renderReadToolCall argsJson + "edit_file" -> renderEditToolCall argsJson + "search_codebase" -> renderSearchToolCall argsJson + "search_and_read" -> renderSearchAndReadToolCall argsJson + "write_file" -> renderWriteToolCall argsJson + _ -> renderGenericToolCall toolName argsJson + +renderBashToolCall :: (Monad m) => Text -> Lucid.HtmlT m () +renderBashToolCall argsJson = + let cmd = extractJsonField "command" argsJson + in Lucid.div_ [Lucid.class_ "tool-bash"] <| do + Lucid.span_ [Lucid.class_ "tool-bash-prompt"] "ϟ" + Lucid.code_ [Lucid.class_ "tool-bash-cmd"] (Lucid.toHtml cmd) + +renderReadToolCall :: (Monad m) => Text -> Lucid.HtmlT m () +renderReadToolCall argsJson = + let path = extractJsonField "path" argsJson + startLine = extractJsonFieldInt "start_line" argsJson + endLine = extractJsonFieldInt "end_line" argsJson + lineRange = case (startLine, endLine) of + (Just s, Just e) -> " @" <> tshow s <> "-" <> tshow e + (Just s, Nothing) -> " @" <> tshow s <> "+" + _ -> "" + in Lucid.div_ [Lucid.class_ "tool-compact"] <| do + Lucid.span_ [Lucid.class_ "tool-check"] "✓" + Lucid.span_ [Lucid.class_ "tool-label"] "Read" + Lucid.code_ [Lucid.class_ "tool-path"] (Lucid.toHtml (shortenPath path <> lineRange)) + +renderEditToolCall :: (Monad m) => Text -> Lucid.HtmlT m () +renderEditToolCall argsJson = + let path = extractJsonField "path" argsJson + in Lucid.div_ [Lucid.class_ "tool-compact"] <| do + Lucid.span_ [Lucid.class_ "tool-check"] "✓" + Lucid.span_ [Lucid.class_ "tool-label"] "Edit" + Lucid.code_ [Lucid.class_ "tool-path"] (Lucid.toHtml (shortenPath path)) + +renderSearchToolCall :: (Monad m) => Text -> Lucid.HtmlT m () +renderSearchToolCall argsJson = + let searchPat = extractJsonField "pattern" argsJson + searchPath = extractJsonField "path" argsJson + pathSuffix = if Text.null searchPath || searchPath == "." then "" else " in " <> shortenPath searchPath + in Lucid.div_ [Lucid.class_ "tool-compact"] <| do + Lucid.span_ [Lucid.class_ "tool-check"] "✓" + Lucid.span_ [Lucid.class_ "tool-label"] "Grep" + Lucid.code_ [Lucid.class_ "tool-pattern"] (Lucid.toHtml searchPat) + unless (Text.null pathSuffix) + <| Lucid.span_ [Lucid.class_ "tool-path-suffix"] (Lucid.toHtml pathSuffix) + +renderWriteToolCall :: (Monad m) => Text -> Lucid.HtmlT m () +renderWriteToolCall argsJson = + let path = extractJsonField "path" argsJson + in Lucid.div_ [Lucid.class_ "tool-compact"] <| do + Lucid.span_ [Lucid.class_ "tool-check"] "✓" + Lucid.span_ [Lucid.class_ "tool-label"] "Write" + Lucid.code_ [Lucid.class_ "tool-path"] (Lucid.toHtml (shortenPath path)) + +renderSearchAndReadToolCall :: (Monad m) => Text -> Lucid.HtmlT m () +renderSearchAndReadToolCall argsJson = + let searchPat = extractJsonField "pattern" argsJson + searchPath = extractJsonField "path" argsJson + pathSuffix = if Text.null searchPath || searchPath == "." then "" else " in " <> shortenPath searchPath + in Lucid.div_ [Lucid.class_ "tool-compact"] <| do + Lucid.span_ [Lucid.class_ "tool-check"] "✓" + Lucid.span_ [Lucid.class_ "tool-label"] "Find" + Lucid.code_ [Lucid.class_ "tool-pattern"] (Lucid.toHtml searchPat) + unless (Text.null pathSuffix) + <| Lucid.span_ [Lucid.class_ "tool-path-suffix"] (Lucid.toHtml pathSuffix) + +renderGenericToolCall :: (Monad m) => Text -> Text -> Lucid.HtmlT m () +renderGenericToolCall toolName argsJson = + Lucid.details_ [Lucid.class_ "tool-generic"] <| do + Lucid.summary_ <| do + Lucid.span_ [Lucid.class_ "tool-check"] "✓" + Lucid.span_ [Lucid.class_ "tool-label"] (Lucid.toHtml toolName) + Lucid.pre_ [Lucid.class_ "tool-args-pre"] (Lucid.toHtml argsJson) + +extractJsonField :: Text -> Text -> Text +extractJsonField field jsonText = + case Aeson.decode (LBS.fromStrict (str jsonText)) of + Just (Aeson.Object obj) -> + case KeyMap.lookup (AesonKey.fromText field) obj of + Just (Aeson.String s) -> s + _ -> "" + _ -> "" + +extractJsonFieldInt :: Text -> Text -> Maybe Int +extractJsonFieldInt field jsonText = + case Aeson.decode (LBS.fromStrict (str jsonText)) of + Just (Aeson.Object obj) -> + case KeyMap.lookup (AesonKey.fromText field) obj of + Just (Aeson.Number n) -> Just (floor n) + _ -> Nothing + _ -> Nothing + +shortenPath :: Text -> Text +shortenPath path = + let parts = Text.splitOn "/" path + relevant = dropWhile (\p -> p `elem` ["", "home", "ben", "omni"]) parts + in Text.intercalate "/" relevant + +renderToolResultTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m () +renderToolResultTimelineEvent content _actor _timestamp _now = + let decoded = decodeToolResult content + isSuccess = toolResultIsSuccess decoded + output = toolResultOutput' decoded + lineCount = length (Text.lines output) + in if Text.null output || (isSuccess && lineCount <= 1) + then pure () + else + Lucid.div_ [Lucid.class_ "tool-result-output"] <| do + when (lineCount > 10) + <| Lucid.details_ [Lucid.class_ "result-collapsible"] + <| do + Lucid.summary_ (Lucid.toHtml (tshow lineCount <> " lines")) + Lucid.pre_ [Lucid.class_ "tool-output-pre"] (Lucid.toHtml output) + when (lineCount <= 10) + <| Lucid.pre_ [Lucid.class_ "tool-output-pre"] (Lucid.toHtml output) + +data DecodedToolResult = DecodedToolResult + { toolResultIsSuccess :: Bool, + toolResultOutput' :: Text, + toolResultError' :: Maybe Text + } + +decodeToolResult :: Text -> DecodedToolResult +decodeToolResult content = + case Aeson.decode (LBS.fromStrict (str content)) of + Just (Aeson.Object obj) -> + DecodedToolResult + { toolResultIsSuccess = case KeyMap.lookup "success" obj of + Just (Aeson.Bool b) -> b + _ -> True, + toolResultOutput' = case KeyMap.lookup "output" obj of + Just (Aeson.String s) -> s + _ -> "", + toolResultError' = case KeyMap.lookup "error" obj of + Just (Aeson.String s) -> Just s + _ -> Nothing + } + _ -> DecodedToolResult True content Nothing + +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"] (renderFormattedJson 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 + +-- | Format JSON content for human-readable display. +-- Tries to pretty-print JSON, falls back to raw text if not valid JSON. +renderFormattedJson :: (Monad m) => Text -> Lucid.HtmlT m () +renderFormattedJson content = + case Aeson.decode (LBS.fromStrict (str content)) of + Just (val :: Aeson.Value) -> + Lucid.pre_ [Lucid.class_ "formatted-json"] <| do + Lucid.toHtml (decodeUtf8 (LBS.toStrict (Aeson.encode val))) + Nothing -> Lucid.toHtml content + +timelineScrollScript :: (Monad m) => Lucid.HtmlT m () +timelineScrollScript = + Lucid.script_ + [ Lucid.type_ "text/javascript" + ] + ( Text.unlines + [ "(function() {", + " function scrollToBottom() {", + " if (typeof autoscrollEnabled !== 'undefined' && !autoscrollEnabled) return;", + " var log = document.querySelector('.timeline-events');", + " if (log) {", + " var isNearBottom = log.scrollHeight - log.scrollTop - log.clientHeight < 100;", + " if (isNearBottom) {", + " log.scrollTop = log.scrollHeight;", + " }", + " }", + " }", + " scrollToBottom();", + " document.body.addEventListener('htmx:afterSwap', function(e) {", + " if (e.target.closest('.timeline-events') || e.target.classList.contains('timeline-events')) {", + " scrollToBottom();", + " }", + " });", + "})();" + ] + ) |