The .timeline-cost events are too noisy - they render raw JSON like {"cents":21.11,"tokens":69501} for every cost update. This clutters the timeline and duplicates info already shown in Execution Details.
1. Remove individual Cost events from the timeline (filter out event_type='Cost')
2. Add a live-updating cost/token summary near the Timeline header, e.g.:
Timeline (34) · $0.21 · 69k tokens
3. Remove the Execution Details section entirely since its info will be in the timeline header
I'll start by examining the codebase to understand the current structure and locate the relevant files.
Let me check the current directory structure:
pwd && ls -la/home/ben/omni total 772 drwxr-xr-x 18 ben users 4096 Dec 1 14:29 . drwx------ 67 ben users 4096 Dec 1 14:33 .. drwxr-xr-x 10 ben users 4096 Dec 1 07:51 _ -rw-r--r-- 1 ben users 2609 Nov 29 23:08 AGENTS.md -rw-r--r-- 1 ben users 38933 Nov 22 12:59 all_tasks.json -rw-r--r-- 1 ben users 6409 Nov 14 20:53 Alpha.hs drwxr-xr-x 5 ben users 4096 Nov 21 06:13 Biz -rwxr-xr-x 1 ben users 1318 Nov 15 10:05 Biz.nix drwxr-xr-x 2 ben users 4096 May 21 2024 bs -rwxr-xr-x 1 ben users 2224 May 19 2025 BudgetReport.sh drwxr-xr-x 3 ben users 4096 Apr 10 2024 Control drwxr-xr-x 2 ben users 4096 Dec 21 2024 .ctags.d drwxr-xr-x 3 ben users 4096 Dec 21 2024 Data -rw-r--r-- 1 ben users 116 Jan 2 2025 default.nix drwxr-xr-x 3 ben users 4096 Dec 1 14:29 .direnv -rw-r--r-- 1 ben users 443 May 22 2025 .dir-locals.el -rw-r--r-- 1 ben users 244 Nov 11 2024 .editorconfig -rw-r--r-- 1 ben users 3356 Dec 1 14:29 .envrc -rw-r--r-- 1 ben users 1253 Nov 27 08:41 .envrc.local -rw-r--r-- 1 ben users 523 Nov 11 2024 .ghci drwxr-xr-x 10 ben users 4096 Dec 1 14:50 .git -rw-r--r-- 1 ben users 31 Nov 22 22:32 .gitattributes -rw-r--r-- 1 ben users 342 Nov 25 21:50 .gitignore -rw-r--r-- 1 ben users 95 Nov 22 12:59 .gitlint -rw-r--r-- 1 ben users 2431 Nov 11 2024 .hlint.yaml -rw-r--r-- 1 ben users 112 Nov 11 2024 .mailmap -rw-r--r-- 1 ben users 0 Nov 22 22:32 .merge_file_1mfrwM.lock drwxr-xr-x 3 ben users 4096 Nov 13 11:37 .mypy_cache drwxr-xr-x 3 ben users 4096 Nov 11 2024 Network drwxr-xr-x 5 ben users 4096 Nov 8 13:16 node_modules drwxr-xr-x 12 ben users 4096 Dec 1 03:59 Omni -rw-r--r-- 1 ben users 78 Nov 25 21:42 package.json -rw-r--r-- 1 ben users 7828 Nov 25 21:42 package-lock.json -rw-r--r-- 1 ben users 1828 Nov 22 22:33 pyproject.toml drwxr-xr-x 3 ben users 4096 Nov 12 21:22 .pytest_cache -rw-r--r-- 1 ben users 6463 Nov 22 22:32 README.md lrwxrwxrwx 1 ben users 51 Nov 30 20:19 result -> /nix/store/9xi9z7jsmayaf20ji201x2kfmg488ymd-omnidev drwxr-xr-x 9 ben users 4096 Nov 16 03:40 .ruff_cache -rw-r--r-- 1 ben users 73 Jan 2 2025 shell.nix -rw------- 1 ben users 12288 Dec 1 14:51 .swp drwxr-xr-x 3 ben users 4096 Apr 10 2024 System -rw-r--r-- 1 ben users 304173 Nov 27 18:11 tags -rw-r--r-- 1 ben users 238654 Nov 27 18:11 TAGS drwxr-xr-x 2 ben users 4096 Jan 2 2025 Urbit -rw-r--r-- 1 ben users 695 Dec 21 2024 .vimrc -rw-r--r-- 1 ben users 13960 May 21 2024 z.scm
Now let me look at the Omni/Jr.hs namespace to find the timeline-related code:
find Omni -name "*.hs" | grep -i jr | head -20Omni/Jr/Web.hs Omni/Jr/Web/Style.hs Omni/Jr.hs
Let me examine the main Jr.hs file:
Omni/Jr.hs1: #!/usr/bin/env run.sh
2: {-# LANGUAGE OverloadedStrings #-}
3: {-# LANGUAGE QuasiQuotes #-}
4: {-# LANGUAGE NoImplicitPrelude #-}
5:
6: -- : out jr
7: -- : dep sqlite-simple
8: -- : dep warp
9: -- : dep servant-server
10: -- : dep lucid
11: -- : dep servant-lucid
12: module Omni.Jr where
13:
14: import Alpha
15: import qualified Data.Aeson as Aeson
16: import qualified Data.ByteString.Lazy.Char8 as BLC
17: import qualified Data.List as List
18: import qualified Data.Text as Text
19: import qualified Omni.Agent.Core as AgentCore
20: import qualified Omni.Agent.Engine as Engine
21: import qualified Omni.Agent.Worker as AgentWorker
22: import qualified Omni.Cli as Cli
23: import qualified Omni.Fact as Fact
24: import qualified Omni.Jr.Web as Web
25: import qualified Omni.Task as Task
26: import qualified Omni.Task.Core as TaskCore
27: import qualified Omni.Test as Test
28: import qualified System.Console.Docopt as Docopt
29: import qualified System.Directory as Directory
30: import System.Environment (withArgs)
31: import qualified System.Environment as Env
32: import qualified System.Exit as Exit
33: import System.FilePath (takeFileName)
34: import qualified System.IO as IO
35: import qualified System.Process as Process
36:
37: main :: IO ()
38: main = Cli.main plan
39:
40: plan :: Cli.Plan ()
41: plan =
42: Cli.Plan
43: { Cli.help = help,
44: Cli.move = move,
45: Cli.test = test,
46: Cli.tidy = \_ -> pure ()
47: }
48:
49: help :: Cli.Docopt
50: help =
51: [Cli.docopt|
52: jr
53:
54: Usage:
55: jr task [<args>...]
56: jr work [<task-id>]
57: jr web [--port=PORT]
58: jr review [<task-id>] [--auto]
59: jr loop [--delay=SECONDS]
60: jr facts list [--project=PROJECT] [--json]
61: jr facts show <fact-id> [--json]
62: jr facts add <project> <content> [--files=FILES] [--task=TASK] [--confidence=CONF] [--json]
63: jr facts delete <fact-id> [--json]
64: jr test
65: jr (-h | --help)
66:
67: Commands:
68: task Manage tasks
69: work Start a worker agent on a task
70: web Start the web UI server
71: review Review a completed task (show diff, accept/reject)
72: loop Run autonomous work+review loop
73: facts Manage knowledge base facts
74:
75: Options:
76: -h --help Show this help
77: --port=PORT Port for web server [default: 8080]
78: --auto Auto-review: accept if tests pass, reject if they fail
79: --delay=SECONDS Delay between loop iterations [default: 5]
80: --project=PROJECT Filter facts by project
81: --files=FILES Comma-separated list of related files
82: --task=TASK Source task ID
83: --confidence=CONF Confidence level 0.0-1.0 [default: 0.8]
84: --json Output in JSON format
85: |]
86:
87: move :: Cli.Arguments -> IO ()
88: move args
89: | args `Cli.has` Cli.command "task" = do
90: let extraArgs = Cli.getAllArgs args (Cli.argument "args")
91: withArgs extraArgs Task.main
92: | args `Cli.has` Cli.command "web" = do
93: let port = case Cli.getArg args (Cli.longOption "port") of
94: Just p -> fromMaybe Web.defaultPort (readMaybe p)
95: Nothing -> Web.defaultPort
96: Web.run port
97: | args `Cli.has` Cli.command "work" = do
98: -- Always run in current directory
99: let path = "."
100:
101: -- Infer name from current directory
102: absPath <- Directory.getCurrentDirectory
103: let name = Text.pack (takeFileName absPath)
104:
105: let worker =
106: AgentCore.Worker
107: { AgentCore.workerName = name,
108: AgentCore.workerPid = Nothing,
109: AgentCore.workerStatus = AgentCore.Idle,
110: AgentCore.workerPath = path,
111: AgentCore.workerQuiet = False -- Show ANSI status bar for manual work
112: }
113:
114: let taskId = fmap Text.pack (Cli.getArg args (Cli.argument "task-id"))
115:
116: AgentWorker.start worker taskId
117: | args `Cli.has` Cli.command "review" = do
118: let autoMode = args `Cli.has` Cli.longOption "auto"
119: case Cli.getArg args (Cli.argument "task-id") of
120: Just tidStr -> reviewTask (Text.pack tidStr) autoMode
121: Nothing -> do
122: -- Find tasks in Review status
123: tasks <- TaskCore.loadTasks
124: let reviewTasks = filter (\t -> TaskCore.taskStatus t == TaskCore.Review) tasks
125: case reviewTasks of
126: [] -> putText "No tasks in Review status."
127: (t : _) -> reviewTask (TaskCore.taskId t) autoMode
128: | args `Cli.has` Cli.command "loop" = do
129: let delay = case Cli.getArg args (Cli.longOption "delay") of
130: Just d -> fromMaybe 5 (readMaybe d)
131: Nothing -> 5
132: runLoop delay
133: | args `Cli.has` Cli.command "facts" = handleFacts args
134: | otherwise = putText (str <| Docopt.usage help)
135:
136: -- | Run the autonomous loop: work -> review -> repeat
137: runLoop :: Int -> IO ()
138: runLoop delaySec = do
139: putText "[loop] Starting autonomous jr loop..."
140: putText ("[loop] Delay between iterations: " <> tshow delaySec <> "s")
141: go
142: where
143: go = do
144: -- First check for tasks to review (prioritize finishing work)
145: reviewResult <- reviewPending
146: if reviewResult
147: then do
148: -- Reviewed something, continue loop immediately
149: threadDelay (delaySec * 1000000)
150: go
151: else do
152: -- No reviews, check for ready work
153: readyTasks <- TaskCore.getReadyTasks
154: case readyTasks of
155: [] -> do
156: putText "[loop] No ready tasks, no pending reviews."
157: (task : _) -> do
158: putText ""
159: putText ("[loop] === Working on: " <> TaskCore.taskId task <> " ===")
160: -- Run worker (this blocks until the engine completes)
161: absPath <- Directory.getCurrentDirectory
162: let name = Text.pack (takeFileName absPath)
163: let worker =
164: AgentCore.Worker
165: { AgentCore.workerName = name,
166: AgentCore.workerPid = Nothing,
167: AgentCore.workerStatus = AgentCore.Idle,
168: AgentCore.workerPath = ".",
169: AgentCore.workerQuiet = True -- No ANSI status bar in loop mode
170: }
171: putText "[loop] Starting worker..."
172: AgentWorker.start worker (Just (TaskCore.taskId task))
173: putText "[loop] Worker finished."
174:
175: -- Delay and loop
176: putText ("[loop] Sleeping " <> tshow delaySec <> "s...")
177: threadDelay (delaySec * 1000000)
178: go
179:
180: -- Returns True if a task was reviewed, False otherwise
181: reviewPending :: IO Bool
182: reviewPending = do
183: tasks <- TaskCore.loadTasks
184: let reviewTasks = filter (\t -> TaskCore.taskStatus t == TaskCore.Review) tasks
185: case reviewTasks of
186: [] -> pure False
187: (t : _) -> do
188: putText ""
189: putText ("[loop] === Reviewing: " <> TaskCore.taskId t <> " ===")
190: tryAutoReview (TaskCore.taskId t)
191: pure True
192:
193: -- Auto-review that doesn't exit on missing commit
194: tryAutoReview :: Text -> IO ()
195: tryAutoReview tid = do
196: tasks <- TaskCore.loadTasks
197: case TaskCore.findTask tid tasks of
198: Nothing -> do
199: putText ("[review] Task " <> tid <> " not found.")
200: Just task -> do
201: let grepArg = "--grep=" <> Text.unpack tid
202: (code, shaOut, _) <-
203: Process.readProcessWithExitCode
204: "git"
205: ["log", "--pretty=format:%H", "-n", "1", grepArg]
206: ""
207:
208: if code /= Exit.ExitSuccess || null shaOut
209: then do
210: putText "[review] No commit found for this task."
211: putText "[review] Resetting to Open for retry."
212: TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.System
213: else do
214: let commitSha = case List.lines shaOut of
215: (x : _) -> x
216: [] -> ""
217:
218: -- Check for merge conflicts
219: conflictResult <- checkMergeConflict commitSha
220: case conflictResult of
221: Just conflictFiles -> do
222: putText "[review] MERGE CONFLICT DETECTED"
223: traverse_ (\f -> putText (" - " <> f)) conflictFiles
224: handleConflict tid conflictFiles commitSha
225: Nothing -> do
226: autoReview tid task commitSha
227:
228: -- | Handle merge conflict during review (Gerrit-style: provide rich context)
229: handleConflict :: Text -> [Text] -> String -> IO ()
230: handleConflict tid conflictFiles commitSha = do
231: maybeCtx <- TaskCore.getRetryContext tid
232: let attempt = maybe 1 (\c -> TaskCore.retryAttempt c + 1) maybeCtx
233:
234: let conflictComment = buildConflictComment commitSha conflictFiles attempt
235: _ <- TaskCore.addComment tid conflictComment TaskCore.Junior
236:
237: if attempt > 3
238: then do
239: putText "[review] Task has failed 3 times. Needs human intervention."
240: TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.System
241: else do
242: conflictDetails <- gatherConflictContext commitSha conflictFiles
243: maybeExistingCtx <- TaskCore.getRetryContext tid
244: let currentReason = "attempt " <> tshow attempt <> ":\n" <> conflictDetails
245: let accumulatedReason = case maybeExistingCtx of
246: Nothing -> currentReason
247: Just ctx -> TaskCore.retryReason ctx <> "\n\n" <> currentReason
248: TaskCore.setRetryContext
249: TaskCore.RetryContext
250: { TaskCore.retryTaskId = tid,
251: TaskCore.retryOriginalCommit = Text.pack commitSha,
252: TaskCore.retryConflictFiles = conflictFiles,
253: TaskCore.retryAttempt = attempt,
254: TaskCore.retryReason = accumulatedReason,
255: TaskCore.retryNotes = maybeExistingCtx +> TaskCore.retryNotes
256: }
257: TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.System
258: putText ("[review] Task " <> tid <> " returned to queue (attempt " <> tshow attempt <> "/3).")
259:
260: -- | Build a review comment for merge conflicts
261: buildConflictComment :: String -> [Text] -> Int -> Text
262: buildConflictComment commitSha conflictFiles attempt =
263: Text.unlines
264: [ "## Auto-Review: Merge Conflict",
265: "",
266: "**Commit:** " <> Text.pack (take 8 commitSha),
267: "**Result:** ✗ MERGE CONFLICT",
268: "**Attempt:** " <> tshow attempt <> "/3",
269: "",
270: "### Conflicting Files",
271: Text.unlines (map ("- " <>) conflictFiles),
272: "Task returned to queue for conflict resolution."
273: ]
274:
275: -- | Gather Gerrit-style conflict context for the coder
276: gatherConflictContext :: String -> [Text] -> IO Text
277: gatherConflictContext commitSha conflictFiles = do
278: commitInfo <- getCommitInfo commitSha
279: currentHeadInfo <- getCurrentHeadInfo
280: fileDiffs <- traverse (getFileConflictInfo commitSha <. Text.unpack) conflictFiles
281:
282: pure
283: <| Text.unlines
284: [ "MERGE CONFLICT - Your changes could not be cleanly applied",
285: "",
286: "== Your Commit ==",
287: commitInfo,
288: "",
289: "== Current HEAD ==",
290: currentHeadInfo,
291: "",
292: "== Conflicting Files ==",
293: Text.unlines fileDiffs,
294: "",
295: "== Resolution Instructions ==",
296: "1. The codebase has been updated since your work",
297: "2. Review the current state of conflicting files",
298: "3. Re-implement your changes on top of the current code",
299: "4. Ensure your changes still make sense given the updates"
300: ]
301:
302: -- | Get info about the commit that caused the conflict
303: getCommitInfo :: String -> IO Text
304: getCommitInfo sha = do
305: (_, out, _) <-
306: Process.readProcessWithExitCode
307: "git"
308: ["log", "-1", "--format=%h %s%n%b", sha]
309: ""
310: pure <| Text.pack out
311:
312: -- | Get info about current HEAD
313: getCurrentHeadInfo :: IO Text
314: getCurrentHeadInfo = do
315: (_, out, _) <-
316: Process.readProcessWithExitCode
317: "git"
318: ["log", "-1", "--format=%h %s (%cr)"]
319: ""
320: pure <| Text.pack out
321:
322: -- | Get file-level conflict context showing what changed in both branches
323: getFileConflictInfo :: String -> FilePath -> IO Text
324: getFileConflictInfo commitSha filePath = do
325: yourChanges <- getYourChangesToFile commitSha filePath
326: recentChanges <- getRecentChangesToFile filePath
327: pure
328: <| Text.unlines
329: [ "--- " <> Text.pack filePath <> " ---",
330: "",
331: "Your changes to this file:",
332: yourChanges,
333: "",
334: "Recent changes by others:",
335: recentChanges
336: ]
337:
338: -- | Get a summary of changes in a specific commit to a file
339: getYourChangesToFile :: String -> FilePath -> IO Text
340: getYourChangesToFile commitSha filePath = do
341: (code, out, _) <-
342: Process.readProcessWithExitCode
343: "git"
344: ["show", "--stat", commitSha, "--", filePath]
345: ""
346: case code of
347: Exit.ExitSuccess -> pure <| Text.pack (take 500 out)
348: Exit.ExitFailure _ -> pure "(unable to get diff)"
349:
350: -- | Get recent changes to a file (last few commits)
351: getRecentChangesToFile :: FilePath -> IO Text
352: getRecentChangesToFile filePath = do
353: (code, out, _) <-
354: Process.readProcessWithExitCode
355: "git"
356: ["log", "-3", "--oneline", "--", filePath]
357: ""
358: case code of
359: Exit.ExitSuccess -> pure <| Text.pack out
360: Exit.ExitFailure _ -> pure "(unable to get history)"
361:
362: -- | Interactive review command (jr review <task-id>)
363: reviewTask :: Text -> Bool -> IO ()
364: reviewTask tid autoMode = do
365: tasks <- TaskCore.loadTasks
366: case TaskCore.findTask tid tasks of
367: Nothing -> do
368: putText ("Task " <> tid <> " not found.")
369: Exit.exitFailure
370: Just task -> do
371: unless autoMode <| TaskCore.showTaskDetailed task
372:
373: let grepArg = "--grep=" <> Text.unpack tid
374: (code, shaOut, _) <-
375: Process.readProcessWithExitCode
376: "git"
377: ["log", "--pretty=format:%H", "-n", "1", grepArg]
378: ""
379:
380: when (code /= Exit.ExitSuccess || null shaOut) <| do
381: putText "\nNo commit found for this task."
382: putText "The worker may not have completed yet, or the commit message doesn't include the task ID."
383: Exit.exitFailure
384:
385: let commitSha = case List.lines shaOut of
386: (x : _) -> x
387: [] -> ""
388:
389: -- Check for merge conflicts before showing diff
390: conflictResult <- checkMergeConflict commitSha
391: case conflictResult of
392: Just conflictFiles -> do
393: putText "\n=== MERGE CONFLICT DETECTED ==="
394: traverse_ (\f -> putText (" - " <> f)) conflictFiles
395: handleConflict tid conflictFiles commitSha
396: Nothing -> do
397: if autoMode
398: then autoReview tid task commitSha
399: else interactiveReview tid task commitSha
400:
401: -- | Auto-review: run tests on namespace, accept if pass, reject if fail
402: autoReview :: Text -> TaskCore.Task -> String -> IO ()
403: autoReview tid task commitSha = do
404: putText "[review] Running automated review..."
405: putText ("[review] Commit: " <> Text.pack (take 8 commitSha))
406:
407: let namespace = fromMaybe "." (TaskCore.taskNamespace task)
408: let testTarget = Text.unpack namespace
409:
410: putText ("[review] Testing: " <> Text.pack testTarget)
411:
412: (testCode, testOut, testErr) <-
413: Process.readProcessWithExitCode
414: "bild"
415: ["--test", testTarget]
416: ""
417:
418: case testCode of
419: Exit.ExitSuccess -> do
420: putText "[review] ✓ Tests passed."
421: let reviewComment = buildReviewComment commitSha testTarget True testOut testErr
422: _ <- TaskCore.addComment tid reviewComment TaskCore.Junior
423: TaskCore.clearRetryContext tid
424: TaskCore.updateTaskStatusWithActor tid TaskCore.Done [] TaskCore.System
425: putText ("[review] Task " <> tid <> " -> Done")
426: addCompletionSummary tid commitSha
427: extractFacts tid commitSha
428: checkEpicCompletion task
429: Exit.ExitFailure code -> do
430: putText ("[review] ✗ Tests failed (exit " <> tshow code <> ")")
431: let reason = "Test failure:\n" <> Text.pack testOut <> Text.pack testErr
432:
433: maybeCtx <- TaskCore.getRetryContext tid
434: let attempt = maybe 1 (\ctx -> TaskCore.retryAttempt ctx + 1) maybeCtx
435:
436: let reviewComment = buildReviewComment commitSha testTarget False testOut testErr
437: _ <- TaskCore.addComment tid reviewComment TaskCore.Junior
438:
439: if attempt > 3
440: then do
441: putText "[review] Task has failed 3 times. Needs human intervention."
442: TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.System
443: else do
444: let currentReason = "attempt " <> tshow attempt <> ": " <> reason
445: let accumulatedReason = case maybeCtx of
446: Nothing -> currentReason
447: Just ctx -> TaskCore.retryReason ctx <> "\n" <> currentReason
448: TaskCore.setRetryContext
449: TaskCore.RetryContext
450: { TaskCore.retryTaskId = tid,
451: TaskCore.retryOriginalCommit = Text.pack commitSha,
452: TaskCore.retryConflictFiles = [],
453: TaskCore.retryAttempt = attempt,
454: TaskCore.retryReason = accumulatedReason,
455: TaskCore.retryNotes = maybeCtx +> TaskCore.retryNotes
456: }
457: TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.System
458: putText ("[review] Task " <> tid <> " reopened (attempt " <> tshow attempt <> "/3).")
459:
460: -- | Build a review comment summarizing what was tested and the result
461: buildReviewComment :: String -> String -> Bool -> String -> String -> Text
462: buildReviewComment commitSha testTarget passed testOut testErr =
463: Text.unlines
464: [ "## Auto-Review",
465: "",
466: "**Commit:** " <> Text.pack (take 8 commitSha),
467: "**Test target:** " <> Text.pack testTarget,
468: "**Result:** " <> if passed then "✓ PASSED" else "✗ FAILED",
469: "",
470: if passed
471: then "All tests passed. Task accepted."
472: else
473: Text.unlines
474: [ "### Test Output",
475: "```",
476: Text.pack (truncateOutput 1000 (testOut ++ testErr)),
477: "```",
478: "",
479: "Task rejected and returned to queue for retry."
480: ]
481: ]
482:
483: -- | Truncate output to a maximum number of characters
484: truncateOutput :: Int -> String -> String
485: truncateOutput maxLen s
486: | length s <= maxLen = s
487: | otherwise = take maxLen s ++ "\n... (truncated)"
488:
489: -- | Interactive review with user prompts
490: interactiveReview :: Text -> TaskCore.Task -> String -> IO ()
491: interactiveReview tid task commitSha = do
492: putText "\n=== Diff for this task ===\n"
493: _ <- Process.rawSystem "git" ["show", commitSha]
494:
495: putText "\n[a]ccept / [r]eject / [s]kip? "
496: IO.hFlush IO.stdout
497: choice <- getLine
498:
499: case Text.toLower choice of
500: c
501: | "a" `Text.isPrefixOf` c -> do
502: let acceptComment = buildHumanReviewComment commitSha True Nothing
503: _ <- TaskCore.addComment tid acceptComment TaskCore.Human
504: TaskCore.clearRetryContext tid
505: TaskCore.updateTaskStatusWithActor tid TaskCore.Done [] TaskCore.Human
506: putText ("Task " <> tid <> " marked as Done.")
507: addCompletionSummary tid commitSha
508: extractFacts tid commitSha
509: checkEpicCompletion task
510: | "r" `Text.isPrefixOf` c -> do
511: putText "Enter rejection reason: "
512: IO.hFlush IO.stdout
513: reason <- getLine
514: let rejectComment = buildHumanReviewComment commitSha False (Just reason)
515: _ <- TaskCore.addComment tid rejectComment TaskCore.Human
516: maybeCtx <- TaskCore.getRetryContext tid
517: let attempt = maybe 1 (\ctx -> TaskCore.retryAttempt ctx + 1) maybeCtx
518: let currentReason = "attempt " <> tshow attempt <> ": rejected: " <> reason
519: let accumulatedReason = case maybeCtx of
520: Nothing -> currentReason
521: Just ctx -> TaskCore.retryReason ctx <> "\n" <> currentReason
522: TaskCore.setRetryContext
523: TaskCore.RetryContext
524: { TaskCore.retryTaskId = tid,
525: TaskCore.retryOriginalCommit = Text.pack commitSha,
526: TaskCore.retryConflictFiles = [],
527: TaskCore.retryAttempt = attempt,
528: TaskCore.retryReason = accumulatedReason,
529: TaskCore.retryNotes = maybeCtx +> TaskCore.retryNotes
530: }
531: TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.Human
532: putText ("Task " <> tid <> " reopened (attempt " <> tshow attempt <> "/3).")
533: | otherwise -> putText "Skipped; no status change."
534:
535: -- | Build a human review comment
536: buildHumanReviewComment :: String -> Bool -> Maybe Text -> Text
537: buildHumanReviewComment commitSha accepted maybeReason =
538: Text.unlines
539: [ "## Human Review",
540: "",
541: "**Commit:** " <> Text.pack (take 8 commitSha),
542: "**Result:** " <> if accepted then "✓ ACCEPTED" else "✗ REJECTED",
543: case maybeReason of
544: Just reason -> "**Reason:** " <> reason
545: Nothing -> ""
546: ]
547:
548: -- | Check if a commit can be cleanly cherry-picked onto live
549: -- Returns Nothing if clean, Just [conflicting files] if conflict
550: checkMergeConflict :: String -> IO (Maybe [Text])
551: checkMergeConflict commitSha = do
552: -- Save current state
553: (_, _, _) <- Process.readProcessWithExitCode "git" ["branch", "--show-current"] ""
554: (_, origHead, _) <- Process.readProcessWithExitCode "git" ["rev-parse", "HEAD"] ""
555:
556: -- Try cherry-pick
557: (cpCode, _, cpErr) <-
558: Process.readProcessWithExitCode
559: "git"
560: ["cherry-pick", "--no-commit", commitSha]
561: ""
562:
563: -- Always abort/reset regardless of result
564: _ <- Process.readProcessWithExitCode "git" ["cherry-pick", "--abort"] ""
565: _ <- Process.readProcessWithExitCode "git" ["reset", "--hard", List.head (List.lines origHead)] ""
566:
567: case cpCode of
568: Exit.ExitSuccess -> pure Nothing
569: Exit.ExitFailure _ -> do
570: -- Parse conflict files from error message
571: let errLines = Text.lines (Text.pack cpErr)
572: conflictLines = filter (Text.isPrefixOf "CONFLICT") errLines
573: -- Extract file names (rough parsing)
574: files = mapMaybe extractConflictFile conflictLines
575: pure (Just (if null files then ["(unknown files)"] else files))
576:
577: extractConflictFile :: Text -> Maybe Text
578: extractConflictFile line =
579: -- CONFLICT (content): Merge conflict in path/to/file.hs
580: case Text.breakOn "Merge conflict in " line of
581: (_, rest)
582: | not (Text.null rest) -> Just (Text.strip (Text.drop 18 rest))
583: _ -> case Text.breakOn "in " line of
584: (_, rest)
585: | not (Text.null rest) -> Just (Text.strip (Text.drop 3 rest))
586: _ -> Nothing
587:
588: -- | Generate and add a completion summary comment for a task
589: addCompletionSummary :: Text -> String -> IO ()
590: addCompletionSummary tid commitSha = do
591: -- Get the diff and commit message for this commit
592: (diffCode, diffOut, _) <- Process.readProcessWithExitCode "git" ["show", "--stat", commitSha] ""
593: (msgCode, msgOut, _) <- Process.readProcessWithExitCode "git" ["log", "-1", "--format=%B", commitSha] ""
594:
595: when (diffCode == Exit.ExitSuccess && msgCode == Exit.ExitSuccess) <| do
596: -- Get list of modified files
597: (filesCode, filesOut, _) <- Process.readProcessWithExitCode "git" ["diff-tree", "--no-commit-id", "--name-only", "-r", commitSha] ""
598:
599: let files = if filesCode == Exit.ExitSuccess then List.lines filesOut else []
600: commitMessage = Text.pack msgOut
601: diffSummary = Text.pack diffOut
602:
603: -- Build prompt for llm
604: let prompt = buildCompletionPrompt tid commitMessage diffSummary files
605:
606: -- Try to get API key
607: maybeApiKey <- Env.lookupEnv "OPENROUTER_API_KEY"
608: case maybeApiKey of
609: Nothing -> do
610: putText "[review] Warning: OPENROUTER_API_KEY not set, skipping completion summary"
611: Just apiKey -> do
612: -- Call LLM via Engine.chat
613: let llm = Engine.defaultLLM {Engine.llmApiKey = Text.pack apiKey}
614: messages = [Engine.Message Engine.User prompt Nothing Nothing]
615:
616: result <- Engine.chat llm [] messages
617: case result of
618: Left err -> do
619: putText ("[review] Failed to generate completion summary: " <> err)
620: Right msg -> do
621: let summary = Text.strip (Engine.msgContent msg)
622: unless (Text.null summary) <| do
623: _ <- TaskCore.addComment tid ("## Completion Summary\n\n" <> summary) TaskCore.Junior
624: putText "[review] Added completion summary comment"
625:
626: -- | Build prompt for LLM to generate completion summary
627: buildCompletionPrompt :: Text -> Text -> Text -> [String] -> Text
628: buildCompletionPrompt tid commitMessage diffSummary files =
629: Text.unlines
630: [ "Generate a concise completion summary for this task. The summary should be 2-4 sentences.",
631: "",
632: "Task ID: " <> tid,
633: "",
634: "Commit Message:",
635: commitMessage,
636: "",
637: "Files Modified (" <> tshow (length files) <> "):",
638: Text.unlines (map Text.pack (take 10 files)),
639: if length files > 10 then "... and " <> tshow (length files - 10) <> " more files" else "",
640: "",
641: "Diff Summary:",
642: diffSummary,
643: "",
644: "Write a brief summary that includes:",
645: "- What was accomplished (from the commit message and changes)",
646: "- Key files that were modified (mention 2-3 most important ones)",
647: "",
648: "Keep it professional and concise. Do NOT include markdown headers or formatting.",
649: "Just return the plain summary text."
650: ]
651:
652: -- | Extract facts from completed task
653: extractFacts :: Text -> String -> IO ()
654: extractFacts tid commitSha = do
655: -- Get the diff for this commit
656: (_, diffOut, _) <- Process.readProcessWithExitCode "git" ["show", "--stat", commitSha] ""
657:
658: -- Get task context
659: tasks <- TaskCore.loadTasks
660: case TaskCore.findTask tid tasks of
661: Nothing -> pure ()
662: Just task -> do
663: let prompt = buildFactExtractionPrompt task diffOut
664:
665: -- Try to get API key
666: maybeApiKey <- Env.lookupEnv "OPENROUTER_API_KEY"
667: case maybeApiKey of
668: Nothing -> do
669: putText "[facts] Warning: OPENROUTER_API_KEY not set, skipping fact extraction"
670: Just apiKey -> do
671: -- Call LLM via Engine.chat
672: let llm = Engine.defaultLLM {Engine.llmApiKey = Text.pack apiKey}
673: messages = [Engine.Message Engine.User prompt Nothing Nothing]
674:
675: result <- Engine.chat llm [] messages
676: case result of
677: Left err -> do
678: putText ("[facts] Failed to extract facts: " <> err)
679: Right msg -> do
680: parseFacts tid (Text.unpack (Engine.msgContent msg))
681:
682: -- | Build prompt for LLM to extract facts from completed task
683: buildFactExtractionPrompt :: TaskCore.Task -> String -> Text
684: buildFactExtractionPrompt task diffSummary =
685: Text.unlines
686: [ "You just completed the following task:",
687: "",
688: "Task: " <> TaskCore.taskId task,
689: "Title: " <> TaskCore.taskTitle task,
690: "Description: " <> TaskCore.taskDescription task,
691: "",
692: "Diff summary:",
693: Text.pack diffSummary,
694: "",
695: "List any facts you learned about this codebase that would be useful for future tasks.",
696: "Each fact should be on its own line, starting with 'FACT: '.",
697: "Include the relevant file paths in brackets after each fact.",
698: "Example: FACT: The Alpha module re-exports common Prelude functions [Alpha.hs]",
699: "If you didn't learn anything notable, respond with 'NO_FACTS'."
700: ]
701:
702: -- | Parse facts from LLM output and add them to the knowledge base
703: parseFacts :: Text -> String -> IO ()
704: parseFacts tid output = do
705: let outputLines = Text.lines (Text.pack output)
706: factLines = filter (Text.isPrefixOf "FACT: ") outputLines
707: traverse_ (addFactFromLine tid) factLines
708:
709: -- | Parse a single fact line and add it to the knowledge base
710: addFactFromLine :: Text -> Text -> IO ()
711: addFactFromLine tid line = do
712: let content = Text.drop 6 line -- Remove "FACT: "
713: (factText, filesRaw) = Text.breakOn " [" content
714: files = parseFiles filesRaw
715: _ <- Fact.createFact "Omni" factText files (Just tid) 0.7 -- Lower initial confidence
716: putText ("[facts] Added: " <> factText)
717:
718: -- | Parse file list from brackets [file1, file2, ...]
719: parseFiles :: Text -> [Text]
720: parseFiles raw
721: | Text.null raw = []
722: | not ("[" `Text.isInfixOf` raw) = []
723: | otherwise =
724: let stripped = Text.strip (Text.dropWhile (/= '[') raw)
725: inner = Text.dropEnd 1 (Text.drop 1 stripped) -- Remove [ and ]
726: trimmed = Text.strip inner
727: in if Text.null trimmed
728: then []
729: else map Text.strip (Text.splitOn "," inner)
730:
731: -- | Generate a summary comment for an epic when all children are complete
732: generateEpicSummary :: Text -> TaskCore.Task -> [TaskCore.Task] -> IO ()
733: generateEpicSummary epicId epic children = do
734: putText "[epic] Generating summary for completed epic..."
735:
736: -- Try to get API key
737: maybeApiKey <- Env.lookupEnv "OPENROUTER_API_KEY"
738: case maybeApiKey of
739: Nothing -> do
740: putText "[epic] Warning: OPENROUTER_API_KEY not set, skipping summary generation"
741: pure ()
742: Just apiKey -> do
743: -- Build the prompt for LLM
744: prompt <- buildEpicSummaryPrompt epic children
745:
746: -- Call LLM
747: let llm = Engine.defaultLLM {Engine.llmApiKey = Text.pack apiKey}
748: messages = [Engine.Message Engine.User prompt Nothing Nothing]
749:
750: result <- Engine.chat llm [] messages
751: case result of
752: Left err -> do
753: putText ("[epic] Failed to generate summary: " <> err)
754: Right msg -> do
755: let summary = Engine.msgContent msg
756: _ <- TaskCore.addComment epicId summary TaskCore.Junior
757: putText "[epic] Summary comment added to epic"
758:
759: -- | Build a prompt for the LLM to summarize an epic
760: buildEpicSummaryPrompt :: TaskCore.Task -> [TaskCore.Task] -> IO Text
761: buildEpicSummaryPrompt epic children = do
762: -- Get commit info for each child task
763: childSummaries <- traverse summarizeChildTask children
764:
765: pure
766: <| Text.unlines
767: [ "Generate a concise summary comment for this completed epic.",
768: "",
769: "## Epic Information",
770: "**Title:** " <> TaskCore.taskTitle epic,
771: "**Description:**",
772: TaskCore.taskDescription epic,
773: "",
774: "## Completed Child Tasks (" <> tshow (length children) <> ")",
775: Text.unlines childSummaries,
776: "",
777: "## Instructions",
778: "Create a markdown summary that includes:",
779: "1. A brief overview of what was accomplished",
780: "2. List of completed tasks with their titles",
781: "3. Key changes or files modified (if mentioned in task descriptions)",
782: "4. Any notable patterns or themes across the work",
783: "",
784: "Format the summary as a markdown comment starting with '## Epic Summary'.",
785: "Keep it concise but informative."
786: ]
787:
788: -- | Summarize a single child task for the epic summary
789: summarizeChildTask :: TaskCore.Task -> IO Text
790: summarizeChildTask task = do
791: -- Try to get commit info
792: let grepArg = "--grep=" <> Text.unpack (TaskCore.taskId task)
793: (code, shaOut, _) <-
794: Process.readProcessWithExitCode
795: "git"
796: ["log", "--pretty=format:%h %s", "-n", "1", grepArg]
797: ""
798:
799: let commitInfo =
800: if code == Exit.ExitSuccess && not (null shaOut)
801: then " [" <> Text.pack (take 80 shaOut) <> "]"
802: else ""
803:
804: -- Get files changed in the commit
805: filesInfo <- getCommitFiles (TaskCore.taskId task)
806:
807: pure <| "- **" <> TaskCore.taskId task <> "**: " <> TaskCore.taskTitle task <> commitInfo <> filesInfo
808:
809: -- | Get files modified in a commit for a task
810: getCommitFiles :: Text -> IO Text
811: getCommitFiles taskId = do
812: let grepArg = "--grep=" <> Text.unpack taskId
813: (code, shaOut, _) <-
814: Process.readProcessWithExitCode
815: "git"
816: ["log", "--pretty=format:%H", "-n", "1", grepArg]
817: ""
818:
819: if code /= Exit.ExitSuccess || null shaOut
820: then pure ""
821: else do
822: let sha = List.head (List.lines shaOut)
823: (fileCode, filesOut, _) <-
824: Process.readProcessWithExitCode
825: "git"
826: ["diff-tree", "--no-commit-id", "--name-only", "-r", sha]
827: ""
828: if fileCode /= Exit.ExitSuccess || null filesOut
829: then pure ""
830: else do
831: let files = List.lines filesOut
832: fileList = List.take 3 files -- Limit to first 3 files
833: moreCount = length files - 3
834: filesText = Text.intercalate ", " (map Text.pack fileList)
835: suffix = if moreCount > 0 then " (+" <> tshow moreCount <> " more)" else ""
836: pure <| if null files then "" else " — " <> filesText <> suffix
837:
838: -- | Check if all children of an epic are Done, and if so, transition epic to Review
839: checkEpicCompletion :: TaskCore.Task -> IO ()
840: checkEpicCompletion task =
841: case TaskCore.taskParent task of
842: Nothing -> pure ()
843: Just parentId -> do
844: tasks <- TaskCore.loadTasks
845: case TaskCore.findTask parentId tasks of
846: Nothing -> pure ()
847: Just parentTask ->
848: when (TaskCore.taskType parentTask == TaskCore.Epic) <| do
849: let children = filter (hasParent parentId) tasks
850: allDone = all (\t -> TaskCore.taskStatus t == TaskCore.Done) children
851: when (allDone && not (null children)) <| do
852: putText ("[review] All children of epic " <> parentId <> " are Done.")
853: TaskCore.updateTaskStatusWithActor parentId TaskCore.Review [] TaskCore.System
854: putText ("[review] Epic " <> parentId <> " -> Review")
855: -- Generate summary comment for the epic
856: generateEpicSummary parentId parentTask children
857: where
858: hasParent pid t = maybe False (TaskCore.matchesId pid) (TaskCore.taskParent t)
859:
860: -- | Handle facts subcommands
861: handleFacts :: Cli.Arguments -> IO ()
862: handleFacts args
863: | args `Cli.has` Cli.command "list" = do
864: let maybeProject = Text.pack </ Cli.getArg args (Cli.longOption "project")
865: jsonMode = args `Cli.has` Cli.longOption "json"
866: facts <- maybe Fact.getAllFacts Fact.getFactsByProject maybeProject
867: if jsonMode
868: then BLC.putStrLn (Aeson.encode facts)
869: else traverse_ printFact facts
870: | args `Cli.has` Cli.command "show" = do
871: let jsonMode = args `Cli.has` Cli.longOption "json"
872: case Cli.getArg args (Cli.argument "fact-id") of
873: Nothing -> putText "fact-id required"
874: Just fidStr -> case readMaybe fidStr of
875: Nothing -> putText "Invalid fact ID (must be integer)"
876: Just fid -> do
877: maybeFact <- Fact.getFact fid
878: case maybeFact of
879: Nothing -> putText "Fact not found"
880: Just fact ->
881: if jsonMode
882: then BLC.putStrLn (Aeson.encode fact)
883: else printFactDetailed fact
884: | args `Cli.has` Cli.command "add" = do
885: let jsonMode = args `Cli.has` Cli.longOption "json"
886: case (Cli.getArg args (Cli.argument "project"), Cli.getArg args (Cli.argument "content")) of
887: (Just proj, Just content) -> do
888: let files = case Cli.getArg args (Cli.longOption "files") of
889: Just f -> Text.splitOn "," (Text.pack f)
890: Nothing -> []
891: sourceTask = Text.pack </ Cli.getArg args (Cli.longOption "task")
892: confidence = case Cli.getArg args (Cli.longOption "confidence") of
893: Just c -> fromMaybe 0.8 (readMaybe c)
894: Nothing -> 0.8
895: factId <- Fact.createFact (Text.pack proj) (Text.pack content) files sourceTask confidence
896: if jsonMode
897: then BLC.putStrLn (Aeson.encode (Aeson.object ["id" Aeson..= factId, "success" Aeson..= True]))
898: else putText ("Created fact: " <> tshow factId)
899: _ -> putText "project and content required"
900: | args `Cli.has` Cli.command "delete" = do
901: let jsonMode = args `Cli.has` Cli.longOption "json"
902: case Cli.getArg args (Cli.argument "fact-id") of
903: Nothing -> putText "fact-id required"
904: Just fidStr -> case readMaybe fidStr of
905: Nothing -> putText "Invalid fact ID (must be integer)"
906: Just fid -> do
907: Fact.deleteFact fid
908: if jsonMode
909: then BLC.putStrLn (Aeson.encode (Aeson.object ["success" Aeson..= True, "message" Aeson..= ("Deleted fact " <> tshow fid)]))
910: else putText ("Deleted fact: " <> tshow fid)
911: | otherwise = putText "Unknown facts subcommand. Use: list, show, add, or delete"
912:
913: -- | Print a fact in a compact format
914: printFact :: TaskCore.Fact -> IO ()
915: printFact fact = do
916: let fid = maybe "?" tshow (TaskCore.factId fact)
917: proj = TaskCore.factProject fact
918: content = Text.take 60 (TaskCore.factContent fact)
919: suffix = if Text.length (TaskCore.factContent fact) > 60 then "..." else ""
920: putText (fid <> "\t" <> proj <> "\t" <> content <> suffix)
921:
922: -- | Print a fact in detailed format
923: printFactDetailed :: TaskCore.Fact -> IO ()
924: printFactDetailed fact = do
925: putText ("ID: " <> maybe "?" tshow (TaskCore.factId fact))
926: putText ("Project: " <> TaskCore.factProject fact)
927: putText ("Content: " <> TaskCore.factContent fact)
928: putText ("Files: " <> Text.intercalate ", " (TaskCore.factRelatedFiles fact))
929: putText ("Source: " <> fromMaybe "-" (TaskCore.factSourceTask fact))
930: putText ("Confidence: " <> tshow (TaskCore.factConfidence fact))
931: putText ("Created: " <> tshow (TaskCore.factCreatedAt fact))
932:
933: test :: Test.Tree
934: test =
935: Test.group
936: "Omni.Jr"
937: [ Test.unit "can run tests" <| True Test.@?= True,
938: Test.unit "can parse task command" <| do
939: let result = Docopt.parseArgs help ["task"]
940: case result of
941: Left err -> Test.assertFailure <| "Failed to parse 'task': " <> show err
942: Right args -> args `Cli.has` Cli.command "task" Test.@?= True,
943: Test.unit "can parse task command with args" <| do
944: let result = Docopt.parseArgs help ["task", "list", "--json"]
945: case result of
946: Left err -> Test.assertFailure <| "Failed to parse 'task list --json': " <> show err
947: Right args -> do
948: args `Cli.has` Cli.command "task" Test.@?= True
949: Cli.getAllArgs args (Cli.argument "args") Test.@?= ["list", "--json"],
950: Test.unit "can parse work command" <| do
951: let result = Docopt.parseArgs help ["work"]
952: case result of
953: Left err -> Test.assertFailure <| "Failed to parse 'work': " <> show err
954: Right args -> args `Cli.has` Cli.command "work" Test.@?= True,
955: Test.unit "can parse work command with task id" <| do
956: let result = Docopt.parseArgs help ["work", "t-123"]
957: case result of
958: Left err -> Test.assertFailure <| "Failed to parse 'work t-123': " <> show err
959: Right args -> do
960: args `Cli.has` Cli.command "work" Test.@?= True
961: Cli.getArg args (Cli.argument "task-id") Test.@?= Just "t-123",
962: Test.unit "can parse facts list command" <| do
963: let result = Docopt.parseArgs help ["facts", "list"]
964: case result of
965: Left err -> Test.assertFailure <| "Failed to parse 'facts list': " <> show err
966: Right args -> do
967: args `Cli.has` Cli.command "facts" Test.@?= True
968: args `Cli.has` Cli.command "list" Test.@?= True,
969: Test.unit "can parse facts list with --project" <| do
970: let result = Docopt.parseArgs help ["facts", "list", "--project=myproj"]
971: case result of
972: Left err -> Test.assertFailure <| "Failed to parse 'facts list --project': " <> show err
973: Right args -> do
974: args `Cli.has` Cli.command "facts" Test.@?= True
975: args `Cli.has` Cli.command "list" Test.@?= True
976: Cli.getArg args (Cli.longOption "project") Test.@?= Just "myproj",
977: Test.unit "can parse facts list with --json" <| do
978: let result = Docopt.parseArgs help ["facts", "list", "--json"]
979: case result of
980: Left err -> Test.assertFailure <| "Failed to parse 'facts list --json': " <> show err
981: Right args -> do
982: args `Cli.has` Cli.command "facts" Test.@?= True
983: args `Cli.has` Cli.command "list" Test.@?= True
984: args `Cli.has` Cli.longOption "json" Test.@?= True,
985: Test.unit "can parse facts show command" <| do
986: let result = Docopt.parseArgs help ["facts", "show", "42"]
987: case result of
988: Left err -> Test.assertFailure <| "Failed to parse 'facts show 42': " <> show err
989: Right args -> do
990: args `Cli.has` Cli.command "facts" Test.@?= True
991: args `Cli.has` Cli.command "show" Test.@?= True
992: Cli.getArg args (Cli.argument "fact-id") Test.@?= Just "42",
993: Test.unit "can parse facts add command" <| do
994: let result = Docopt.parseArgs help ["facts", "add", "myproj", "This is a fact"]
995: case result of
996: Left err -> Test.assertFailure <| "Failed to parse 'facts add': " <> show err
997: Right args -> do
998: args `Cli.has` Cli.command "facts" Test.@?= True
999: args `Cli.has` Cli.command "add" Test.@?= True
1000: Cli.getArg args (Cli.argument "project") Test.@?= Just "myproj"
1001: Cli.getArg args (Cli.argument "content") Test.@?= Just "This is a fact",
1002: Test.unit "can parse facts add with options" <| do
1003: let result = Docopt.parseArgs help ["facts", "add", "myproj", "fact", "--files=a.hs,b.hs", "--task=t-123", "--confidence=0.9"]
1004: case result of
1005: Left err -> Test.assertFailure <| "Failed to parse 'facts add' with options: " <> show err
1006: Right args -> do
1007: args `Cli.has` Cli.command "facts" Test.@?= True
1008: args `Cli.has` Cli.command "add" Test.@?= True
1009: Cli.getArg args (Cli.longOption "files") Test.@?= Just "a.hs,b.hs"
1010: Cli.getArg args (Cli.longOption "task") Test.@?= Just "t-123"
1011: Cli.getArg args (Cli.longOption "confidence") Test.@?= Just "0.9",
1012: Test.unit "can parse facts delete command" <| do
1013: let result = Docopt.parseArgs help ["facts", "delete", "42"]
1014: case result of
1015: Left err -> Test.assertFailure <| "Failed to parse 'facts delete 42': " <> show err
1016: Right args -> do
1017: args `Cli.has` Cli.command "facts" Test.@?= True
1018: args `Cli.has` Cli.command "delete" Test.@?= True
1019: Cli.getArg args (Cli.argument "fact-id") Test.@?= Just "42"
1020: ]
Now let me check the Web.hs file where the timeline rendering is likely to be:
Omni/Jr/Web.hs1: {-# LANGUAGE DataKinds #-}
2: {-# LANGUAGE OverloadedStrings #-}
3: {-# LANGUAGE TypeOperators #-}
4: {-# LANGUAGE NoImplicitPrelude #-}
5:
6: -- : dep warp
7: -- : dep servant-server
8: -- : dep lucid
9: -- : dep servant-lucid
10: -- : dep http-api-data
11: -- : dep process
12: -- : dep clay
13: module Omni.Jr.Web
14: ( run,
15: defaultPort,
16: )
17: where
18:
19: import Alpha
20: import qualified Control.Concurrent as Concurrent
21: import qualified Data.Aeson as Aeson
22: import qualified Data.Aeson.KeyMap as KeyMap
23: import qualified Data.ByteString.Lazy as LBS
24: import qualified Data.List as List
25: import qualified Data.Text as Text
26: import qualified Data.Text.Lazy as LazyText
27: import qualified Data.Text.Lazy.Encoding as LazyText
28: import Data.Time (Day, NominalDiffTime, UTCTime (..), dayOfWeek, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime, toGregorian)
29: import Data.Time.Calendar (DayOfWeek (..))
30: import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
31: import qualified Lucid
32: import qualified Lucid.Base as Lucid
33: import qualified Network.Wai.Handler.Warp as Warp
34: import Numeric (showFFloat)
35: import qualified Omni.Fact as Fact
36: import qualified Omni.Jr.Web.Style as Style
37: import qualified Omni.Task.Core as TaskCore
38: import Servant
39: import qualified Servant.HTML.Lucid as Lucid
40: import qualified Servant.Types.SourceT as Source
41: import qualified System.Exit as Exit
42: import qualified System.Process as Process
43: import Web.FormUrlEncoded (FromForm (..), lookupUnique, parseUnique)
44:
45: type PostRedirect = Verb 'POST 303 '[Lucid.HTML] (Headers '[Header "Location" Text] NoContent)
46:
47: defaultPort :: Warp.Port
48: defaultPort = 8080
49:
50: formatRelativeTime :: UTCTime -> UTCTime -> Text
51: formatRelativeTime now timestamp =
52: let delta = diffUTCTime now timestamp
53: in relativeText delta
54:
55: relativeText :: NominalDiffTime -> Text
56: relativeText delta
57: | delta < 60 = "just now"
58: | delta < 3600 = tshow (round (delta / 60) :: Int) <> " minutes ago"
59: | delta < 7200 = "1 hour ago"
60: | delta < 86400 = tshow (round (delta / 3600) :: Int) <> " hours ago"
61: | delta < 172800 = "yesterday"
62: | delta < 604800 = tshow (round (delta / 86400) :: Int) <> " days ago"
63: | delta < 1209600 = "1 week ago"
64: | delta < 2592000 = tshow (round (delta / 604800) :: Int) <> " weeks ago"
65: | delta < 5184000 = "1 month ago"
66: | delta < 31536000 = tshow (round (delta / 2592000) :: Int) <> " months ago"
67: | otherwise = tshow (round (delta / 31536000) :: Int) <> " years ago"
68:
69: formatExactTimestamp :: UTCTime -> Text
70: formatExactTimestamp = Text.pack <. formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S UTC"
71:
72: renderRelativeTimestamp :: (Monad m) => UTCTime -> UTCTime -> Lucid.HtmlT m ()
73: renderRelativeTimestamp now timestamp =
74: Lucid.span_
75: [ Lucid.class_ "relative-time",
76: Lucid.title_ (formatExactTimestamp timestamp)
77: ]
78: (Lucid.toHtml (formatRelativeTime now timestamp))
79:
80: metaSep :: (Monad m) => Lucid.HtmlT m ()
81: metaSep = Lucid.span_ [Lucid.class_ "meta-sep"] "·"
82:
83: data TaskFilters = TaskFilters
84: { filterStatus :: Maybe TaskCore.Status,
85: filterPriority :: Maybe TaskCore.Priority,
86: filterNamespace :: Maybe Text,
87: filterType :: Maybe TaskCore.TaskType
88: }
89: deriving (Show, Eq)
90:
91: data TimeRange = Today | Week | Month | AllTime
92: deriving (Show, Eq)
93:
94: data SortOrder
95: = SortNewest
96: | SortOldest
97: | SortUpdated
98: | SortPriorityHigh
99: | SortPriorityLow
100: deriving (Show, Eq)
101:
102: parseSortOrder :: Maybe Text -> SortOrder
103: parseSortOrder (Just "oldest") = SortOldest
104: parseSortOrder (Just "updated") = SortUpdated
105: parseSortOrder (Just "priority-high") = SortPriorityHigh
106: parseSortOrder (Just "priority-low") = SortPriorityLow
107: parseSortOrder _ = SortNewest
108:
109: sortOrderToParam :: SortOrder -> Text
110: sortOrderToParam SortNewest = "newest"
111: sortOrderToParam SortOldest = "oldest"
112: sortOrderToParam SortUpdated = "updated"
113: sortOrderToParam SortPriorityHigh = "priority-high"
114: sortOrderToParam SortPriorityLow = "priority-low"
115:
116: sortOrderLabel :: SortOrder -> Text
117: sortOrderLabel SortNewest = "Newest First"
118: sortOrderLabel SortOldest = "Oldest First"
119: sortOrderLabel SortUpdated = "Recently Updated"
120: sortOrderLabel SortPriorityHigh = "Priority (High to Low)"
121: sortOrderLabel SortPriorityLow = "Priority (Low to High)"
122:
123: sortTasks :: SortOrder -> [TaskCore.Task] -> [TaskCore.Task]
124: sortTasks SortNewest = List.sortBy (comparing (Down <. TaskCore.taskCreatedAt))
125: sortTasks SortOldest = List.sortBy (comparing TaskCore.taskCreatedAt)
126: sortTasks SortUpdated = List.sortBy (comparing (Down <. TaskCore.taskUpdatedAt))
127: sortTasks SortPriorityHigh = List.sortBy (comparing TaskCore.taskPriority)
128: sortTasks SortPriorityLow = List.sortBy (comparing (Down <. TaskCore.taskPriority))
129:
130: parseTimeRange :: Maybe Text -> TimeRange
131: parseTimeRange (Just "today") = Today
132: parseTimeRange (Just "week") = Week
133: parseTimeRange (Just "month") = Month
134: parseTimeRange _ = AllTime
135:
136: timeRangeToParam :: TimeRange -> Text
137: timeRangeToParam Today = "today"
138: timeRangeToParam Week = "week"
139: timeRangeToParam Month = "month"
140: timeRangeToParam AllTime = "all"
141:
142: getTimeRangeStart :: TimeRange -> UTCTime -> Maybe UTCTime
143: getTimeRangeStart AllTime _ = Nothing
144: getTimeRangeStart Today now = Just (startOfDay now)
145: getTimeRangeStart Week now = Just (startOfWeek now)
146: getTimeRangeStart Month now = Just (startOfMonth now)
147:
148: startOfDay :: UTCTime -> UTCTime
149: startOfDay t = UTCTime (utctDay t) 0
150:
151: startOfWeek :: UTCTime -> UTCTime
152: startOfWeek t =
153: let day = utctDay t
154: dow = dayOfWeek day
155: daysBack = case dow of
156: Monday -> 0
157: Tuesday -> 1
158: Wednesday -> 2
159: Thursday -> 3
160: Friday -> 4
161: Saturday -> 5
162: Sunday -> 6
163: in UTCTime (addDays (negate daysBack) day) 0
164:
165: addDays :: Integer -> Day -> Day
166: addDays n d =
167: let (y, m, dayNum) = toGregorian d
168: in fromGregorian y m (dayNum + fromInteger n)
169:
170: fromGregorian :: Integer -> Int -> Int -> Day
171: fromGregorian y m d = toEnum (fromInteger (daysSinceEpoch y m d))
172:
173: daysSinceEpoch :: Integer -> Int -> Int -> Integer
174: daysSinceEpoch y m d =
175: let a = (14 - m) `div` 12
176: y' = y + 4800 - toInteger a
177: m' = m + 12 * a - 3
178: jdn = d + (153 * m' + 2) `div` 5 + 365 * fromInteger y' + fromInteger y' `div` 4 - fromInteger y' `div` 100 + fromInteger y' `div` 400 - 32045
179: in toInteger jdn - 2440588
180:
181: startOfMonth :: UTCTime -> UTCTime
182: startOfMonth t =
183: let day = utctDay t
184: (y, m, _) = toGregorian day
185: in UTCTime (fromGregorian y m 1) 0
186:
187: computeMetricsFromActivities :: [TaskCore.Task] -> [TaskCore.TaskActivity] -> TaskCore.AggregatedMetrics
188: computeMetricsFromActivities tasks activities =
189: let completedCount = length [t | t <- tasks, TaskCore.taskStatus t == TaskCore.Done]
190: totalCost = sum [c | act <- activities, Just c <- [TaskCore.activityCostCents act]]
191: totalTokens = sum [t | act <- activities, Just t <- [TaskCore.activityTokensUsed act]]
192: totalDuration = sum [calcDuration act | act <- activities]
193: in TaskCore.AggregatedMetrics
194: { TaskCore.aggTotalCostCents = totalCost,
195: TaskCore.aggTotalDurationSeconds = totalDuration,
196: TaskCore.aggCompletedTasks = completedCount,
197: TaskCore.aggTotalTokens = totalTokens
198: }
199: where
200: calcDuration act = case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of
201: (Just start, Just end) -> floor (diffUTCTime end start)
202: _ -> 0
203:
204: type API =
205: QueryParam "range" Text :> Get '[Lucid.HTML] HomePage
206: :<|> "style.css" :> Get '[CSS] LazyText.Text
207: :<|> "ready" :> QueryParam "sort" Text :> Get '[Lucid.HTML] ReadyQueuePage
208: :<|> "blocked" :> QueryParam "sort" Text :> Get '[Lucid.HTML] BlockedPage
209: :<|> "intervention" :> QueryParam "sort" Text :> Get '[Lucid.HTML] InterventionPage
210: :<|> "stats" :> QueryParam "epic" Text :> Get '[Lucid.HTML] StatsPage
211: :<|> "tasks"
212: :> QueryParam "status" Text
213: :> QueryParam "priority" Text
214: :> QueryParam "namespace" Text
215: :> QueryParam "type" Text
216: :> QueryParam "sort" Text
217: :> Get '[Lucid.HTML] TaskListPage
218: :<|> "kb" :> Get '[Lucid.HTML] KBPage
219: :<|> "kb" :> "create" :> ReqBody '[FormUrlEncoded] FactCreateForm :> PostRedirect
220: :<|> "kb" :> Capture "id" Int :> Get '[Lucid.HTML] FactDetailPage
221: :<|> "kb" :> Capture "id" Int :> "edit" :> ReqBody '[FormUrlEncoded] FactEditForm :> PostRedirect
222: :<|> "kb" :> Capture "id" Int :> "delete" :> PostRedirect
223: :<|> "epics" :> QueryParam "sort" Text :> Get '[Lucid.HTML] EpicsPage
224: :<|> "tasks" :> Capture "id" Text :> Get '[Lucid.HTML] TaskDetailPage
225: :<|> "tasks" :> Capture "id" Text :> "status" :> ReqBody '[FormUrlEncoded] StatusForm :> Post '[Lucid.HTML] StatusBadgePartial
226: :<|> "tasks" :> Capture "id" Text :> "priority" :> ReqBody '[FormUrlEncoded] PriorityForm :> Post '[Lucid.HTML] PriorityBadgePartial
227: :<|> "tasks" :> Capture "id" Text :> "description" :> "view" :> Get '[Lucid.HTML] DescriptionViewPartial
228: :<|> "tasks" :> Capture "id" Text :> "description" :> "edit" :> Get '[Lucid.HTML] DescriptionEditPartial
229: :<|> "tasks" :> Capture "id" Text :> "description" :> ReqBody '[FormUrlEncoded] DescriptionForm :> Post '[Lucid.HTML] DescriptionViewPartial
230: :<|> "tasks" :> Capture "id" Text :> "notes" :> ReqBody '[FormUrlEncoded] NotesForm :> PostRedirect
231: :<|> "tasks" :> Capture "id" Text :> "comment" :> ReqBody '[FormUrlEncoded] CommentForm :> PostRedirect
232: :<|> "tasks" :> Capture "id" Text :> "review" :> Get '[Lucid.HTML] TaskReviewPage
233: :<|> "tasks" :> Capture "id" Text :> "diff" :> Capture "commit" Text :> Get '[Lucid.HTML] TaskDiffPage
234: :<|> "tasks" :> Capture "id" Text :> "accept" :> PostRedirect
235: :<|> "tasks" :> Capture "id" Text :> "reject" :> ReqBody '[FormUrlEncoded] RejectForm :> PostRedirect
236: :<|> "tasks" :> Capture "id" Text :> "reset-retries" :> PostRedirect
237: :<|> "partials" :> "recent-activity-new" :> QueryParam "since" Int :> Get '[Lucid.HTML] RecentActivityNewPartial
238: :<|> "partials" :> "recent-activity-more" :> QueryParam "offset" Int :> Get '[Lucid.HTML] RecentActivityMorePartial
239: :<|> "partials" :> "ready-count" :> Get '[Lucid.HTML] ReadyCountPartial
240: :<|> "partials"
241: :> "task-list"
242: :> QueryParam "status" Text
243: :> QueryParam "priority" Text
244: :> QueryParam "namespace" Text
245: :> QueryParam "type" Text
246: :> QueryParam "sort" Text
247: :> Get '[Lucid.HTML] TaskListPartial
248: :<|> "partials" :> "task" :> Capture "id" Text :> "metrics" :> Get '[Lucid.HTML] TaskMetricsPartial
249: :<|> "partials" :> "task" :> Capture "id" Text :> "events" :> QueryParam "since" Int :> Get '[Lucid.HTML] AgentEventsPartial
250: :<|> "tasks" :> Capture "id" Text :> "events" :> "stream" :> StreamGet NoFraming SSE (SourceIO ByteString)
251:
252: data CSS
253:
254: instance Accept CSS where
255: contentType _ = "text/css"
256:
257: instance MimeRender CSS LazyText.Text where
258: mimeRender _ = LazyText.encodeUtf8
259:
260: data SSE
261:
262: instance Accept SSE where
263: contentType _ = "text/event-stream"
264:
265: instance MimeRender SSE ByteString where
266: mimeRender _ = LBS.fromStrict
267:
268: data HomePage = HomePage TaskCore.TaskStats [TaskCore.Task] [TaskCore.Task] Bool TaskCore.AggregatedMetrics TimeRange UTCTime
269:
270: data ReadyQueuePage = ReadyQueuePage [TaskCore.Task] SortOrder UTCTime
271:
272: data BlockedPage = BlockedPage [(TaskCore.Task, Int)] SortOrder UTCTime
273:
274: data InterventionPage = InterventionPage TaskCore.HumanActionItems SortOrder UTCTime
275:
276: data TaskListPage = TaskListPage [TaskCore.Task] TaskFilters SortOrder UTCTime
277:
278: data TaskDetailPage
279: = TaskDetailFound TaskCore.Task [TaskCore.Task] [TaskCore.TaskActivity] (Maybe TaskCore.RetryContext) [GitCommit] (Maybe TaskCore.AggregatedMetrics) [TaskCore.StoredEvent] UTCTime
280: | TaskDetailNotFound Text
281:
282: data GitCommit = GitCommit
283: { commitHash :: Text,
284: commitShortHash :: Text,
285: commitSummary :: Text,
286: commitAuthor :: Text,
287: commitRelativeDate :: Text,
288: commitFilesChanged :: Int
289: }
290: deriving (Show, Eq)
291:
292: data TaskReviewPage
293: = ReviewPageFound TaskCore.Task ReviewInfo
294: | ReviewPageNotFound Text
295:
296: data ReviewInfo
297: = ReviewNoCommit
298: | ReviewMergeConflict Text [Text]
299: | ReviewReady Text Text
300:
301: data TaskDiffPage
302: = DiffPageFound Text Text Text
303: | DiffPageNotFound Text Text
304:
305: data StatsPage = StatsPage TaskCore.TaskStats (Maybe Text)
306:
307: newtype KBPage = KBPage [TaskCore.Fact]
308:
309: data FactDetailPage
310: = FactDetailFound TaskCore.Fact UTCTime
311: | FactDetailNotFound Int
312:
313: data FactEditForm = FactEditForm Text Text Text
314:
315: instance FromForm FactEditForm where
316: fromForm form = do
317: content <- parseUnique "content" form
318: let files = fromRight "" (lookupUnique "files" form)
319: let confidence = fromRight "0.8" (lookupUnique "confidence" form)
320: Right (FactEditForm content files confidence)
321:
322: data FactCreateForm = FactCreateForm Text Text Text Text
323:
324: instance FromForm FactCreateForm where
325: fromForm form = do
326: project <- parseUnique "project" form
327: content <- parseUnique "content" form
328: let files = fromRight "" (lookupUnique "files" form)
329: let confidence = fromRight "0.8" (lookupUnique "confidence" form)
330: Right (FactCreateForm project content files confidence)
331:
332: data EpicsPage = EpicsPage [TaskCore.Task] [TaskCore.Task] SortOrder
333:
334: data RecentActivityNewPartial = RecentActivityNewPartial [TaskCore.Task] (Maybe Int)
335:
336: data RecentActivityMorePartial = RecentActivityMorePartial [TaskCore.Task] Int Bool
337:
338: newtype ReadyCountPartial = ReadyCountPartial Int
339:
340: data StatusBadgePartial = StatusBadgePartial TaskCore.Status Text
341:
342: data PriorityBadgePartial = PriorityBadgePartial TaskCore.Priority Text
343:
344: newtype TaskListPartial = TaskListPartial [TaskCore.Task]
345:
346: data TaskMetricsPartial = TaskMetricsPartial Text [TaskCore.TaskActivity] (Maybe TaskCore.RetryContext) UTCTime
347:
348: data AgentEventsPartial = AgentEventsPartial [TaskCore.StoredEvent] Bool UTCTime
349:
350: data DescriptionViewPartial = DescriptionViewPartial Text Text Bool
351:
352: data DescriptionEditPartial = DescriptionEditPartial Text Text Bool
353:
354: newtype RejectForm = RejectForm (Maybe Text)
355:
356: instance FromForm RejectForm where
357: fromForm form = Right (RejectForm (either (const Nothing) Just (lookupUnique "notes" form)))
358:
359: newtype StatusForm = StatusForm TaskCore.Status
360:
361: instance FromForm StatusForm where
362: fromForm form = do
363: statusText <- parseUnique "status" form
364: case readMaybe (Text.unpack statusText) of
365: Just s -> Right (StatusForm s)
366: Nothing -> Left "Invalid status"
367:
368: newtype PriorityForm = PriorityForm TaskCore.Priority
369:
370: instance FromForm PriorityForm where
371: fromForm form = do
372: priorityText <- parseUnique "priority" form
373: case readMaybe (Text.unpack priorityText) of
374: Just p -> Right (PriorityForm p)
375: Nothing -> Left "Invalid priority"
376:
377: newtype DescriptionForm = DescriptionForm Text
378:
379: instance FromForm DescriptionForm where
380: fromForm form = do
381: desc <- parseUnique "description" form
382: Right (DescriptionForm desc)
383:
384: newtype NotesForm = NotesForm Text
385:
386: instance FromForm NotesForm where
387: fromForm form = do
388: notes <- parseUnique "notes" form
389: Right (NotesForm notes)
390:
391: newtype CommentForm = CommentForm Text
392:
393: instance FromForm CommentForm where
394: fromForm form = do
395: commentText <- parseUnique "comment" form
396: Right (CommentForm commentText)
397:
398: pageHead :: (Monad m) => Text -> Lucid.HtmlT m ()
399: pageHead title =
400: Lucid.head_ <| do
401: Lucid.title_ (Lucid.toHtml title)
402: Lucid.meta_ [Lucid.charset_ "utf-8"]
403: Lucid.meta_
404: [ Lucid.name_ "viewport",
405: Lucid.content_ "width=device-width, initial-scale=1"
406: ]
407: Lucid.link_ [Lucid.rel_ "stylesheet", Lucid.href_ "/style.css"]
408: Lucid.script_
409: [ Lucid.src_ "https://unpkg.com/htmx.org@2.0.4",
410: Lucid.integrity_ "sha384-HGfztofotfshcF7+8n44JQL2oJmowVChPTg48S+jvZoztPfvwD79OC/LTtG6dMp+",
411: Lucid.crossorigin_ "anonymous"
412: ]
413: ("" :: Text)
414: Lucid.script_ [] statusDropdownJs
415: Lucid.script_ [] priorityDropdownJs
416: Lucid.script_ [] navbarDropdownJs
417: Lucid.script_ [] liveToggleJs
418:
419: navbarDropdownJs :: Text
420: navbarDropdownJs =
421: Text.unlines
422: [ "document.addEventListener('DOMContentLoaded', function() {",
423: " document.querySelectorAll('.navbar-dropdown-btn').forEach(function(btn) {",
424: " btn.addEventListener('click', function(e) {",
425: " e.preventDefault();",
426: " var dropdown = btn.closest('.navbar-dropdown');",
427: " var isOpen = dropdown.classList.contains('open');",
428: " document.querySelectorAll('.navbar-dropdown.open').forEach(function(d) {",
429: " d.classList.remove('open');",
430: " });",
431: " if (!isOpen) {",
432: " dropdown.classList.add('open');",
433: " }",
434: " });",
435: " });",
436: " document.addEventListener('click', function(e) {",
437: " if (!e.target.closest('.navbar-dropdown')) {",
438: " document.querySelectorAll('.navbar-dropdown.open').forEach(function(d) {",
439: " d.classList.remove('open');",
440: " });",
441: " }",
442: " });",
443: "});"
444: ]
445:
446: statusDropdownJs :: Text
447: statusDropdownJs =
448: Text.unlines
449: [ "function toggleStatusDropdown(el) {",
450: " var container = el.parentElement;",
451: " var isOpen = container.classList.toggle('open');",
452: " el.setAttribute('aria-expanded', isOpen);",
453: " if (isOpen) {",
454: " var firstItem = container.querySelector('[role=\"menuitem\"]');",
455: " if (firstItem) firstItem.focus();",
456: " }",
457: "}",
458: "",
459: "function closeStatusDropdown(container) {",
460: " container.classList.remove('open');",
461: " var badge = container.querySelector('[role=\"button\"]');",
462: " if (badge) {",
463: " badge.setAttribute('aria-expanded', 'false');",
464: " badge.focus();",
465: " }",
466: "}",
467: "",
468: "function handleStatusKeydown(event, el) {",
469: " if (event.key === 'Enter' || event.key === ' ') {",
470: " event.preventDefault();",
471: " toggleStatusDropdown(el);",
472: " } else if (event.key === 'Escape') {",
473: " closeStatusDropdown(el.parentElement);",
474: " } else if (event.key === 'ArrowDown') {",
475: " event.preventDefault();",
476: " var container = el.parentElement;",
477: " if (!container.classList.contains('open')) {",
478: " toggleStatusDropdown(el);",
479: " } else {",
480: " var firstItem = container.querySelector('[role=\"menuitem\"]');",
481: " if (firstItem) firstItem.focus();",
482: " }",
483: " }",
484: "}",
485: "",
486: "function handleMenuItemKeydown(event) {",
487: " var container = event.target.closest('.status-badge-dropdown');",
488: " var items = container.querySelectorAll('[role=\"menuitem\"]');",
489: " var currentIndex = Array.from(items).indexOf(event.target);",
490: " ",
491: " if (event.key === 'ArrowDown') {",
492: " event.preventDefault();",
493: " var next = (currentIndex + 1) % items.length;",
494: " items[next].focus();",
495: " } else if (event.key === 'ArrowUp') {",
496: " event.preventDefault();",
497: " var prev = (currentIndex - 1 + items.length) % items.length;",
498: " items[prev].focus();",
499: " } else if (event.key === 'Escape') {",
500: " event.preventDefault();",
501: " closeStatusDropdown(container);",
502: " } else if (event.key === 'Tab') {",
503: " closeStatusDropdown(container);",
504: " }",
505: "}",
506: "",
507: "document.addEventListener('click', function(e) {",
508: " var dropdowns = document.querySelectorAll('.status-badge-dropdown.open');",
509: " dropdowns.forEach(function(d) {",
510: " if (!d.contains(e.target)) {",
511: " closeStatusDropdown(d);",
512: " }",
513: " });",
514: "});"
515: ]
516:
517: priorityDropdownJs :: Text
518: priorityDropdownJs =
519: Text.unlines
520: [ "function togglePriorityDropdown(el) {",
521: " var container = el.parentElement;",
522: " var isOpen = container.classList.toggle('open');",
523: " el.setAttribute('aria-expanded', isOpen);",
524: " if (isOpen) {",
525: " var firstItem = container.querySelector('[role=\"menuitem\"]');",
526: " if (firstItem) firstItem.focus();",
527: " }",
528: "}",
529: "",
530: "function closePriorityDropdown(container) {",
531: " container.classList.remove('open');",
532: " var badge = container.querySelector('[role=\"button\"]');",
533: " if (badge) {",
534: " badge.setAttribute('aria-expanded', 'false');",
535: " badge.focus();",
536: " }",
537: "}",
538: "",
539: "function handlePriorityKeydown(event, el) {",
540: " if (event.key === 'Enter' || event.key === ' ') {",
541: " event.preventDefault();",
542: " togglePriorityDropdown(el);",
543: " } else if (event.key === 'Escape') {",
544: " closePriorityDropdown(el.parentElement);",
545: " } else if (event.key === 'ArrowDown') {",
546: " event.preventDefault();",
547: " var container = el.parentElement;",
548: " if (!container.classList.contains('open')) {",
549: " togglePriorityDropdown(el);",
550: " } else {",
551: " var firstItem = container.querySelector('[role=\"menuitem\"]');",
552: " if (firstItem) firstItem.focus();",
553: " }",
554: " }",
555: "}",
556: "",
557: "function handlePriorityMenuItemKeydown(event) {",
558: " var container = event.target.closest('.priority-badge-dropdown');",
559: " var items = container.querySelectorAll('[role=\"menuitem\"]');",
560: " var currentIndex = Array.from(items).indexOf(event.target);",
561: " ",
562: " if (event.key === 'ArrowDown') {",
563: " event.preventDefault();",
564: " var next = (currentIndex + 1) % items.length;",
565: " items[next].focus();",
566: " } else if (event.key === 'ArrowUp') {",
567: " event.preventDefault();",
568: " var prev = (currentIndex - 1 + items.length) % items.length;",
569: " items[prev].focus();",
570: " } else if (event.key === 'Escape') {",
571: " event.preventDefault();",
572: " closePriorityDropdown(container);",
573: " } else if (event.key === 'Tab') {",
574: " closePriorityDropdown(container);",
575: " }",
576: "}",
577: "",
578: "document.addEventListener('click', function(e) {",
579: " var dropdowns = document.querySelectorAll('.priority-badge-dropdown.open');",
580: " dropdowns.forEach(function(d) {",
581: " if (!d.contains(e.target)) {",
582: " closePriorityDropdown(d);",
583: " }",
584: " });",
585: "});"
586: ]
587:
588: pageBody :: (Monad m) => Lucid.HtmlT m () -> Lucid.HtmlT m ()
589: pageBody content =
590: Lucid.body_ [Lucid.makeAttribute "hx-boost" "true"] <| do
591: navbar
592: content
593:
594: data Breadcrumb = Breadcrumb
595: { _crumbLabel :: Text,
596: _crumbHref :: Maybe Text
597: }
598:
599: type Breadcrumbs = [Breadcrumb]
600:
601: pageBodyWithCrumbs :: (Monad m) => Breadcrumbs -> Lucid.HtmlT m () -> Lucid.HtmlT m ()
602: pageBodyWithCrumbs crumbs content =
603: Lucid.body_ [Lucid.makeAttribute "hx-boost" "true"] <| do
604: navbar
605: unless (null crumbs) <| do
606: Lucid.div_ [Lucid.class_ "breadcrumb-container"] <| do
607: Lucid.div_ [Lucid.class_ "container"] <| renderBreadcrumbs crumbs
608: content
609:
610: renderBreadcrumbs :: (Monad m) => Breadcrumbs -> Lucid.HtmlT m ()
611: renderBreadcrumbs [] = pure ()
612: renderBreadcrumbs crumbs =
613: Lucid.nav_ [Lucid.class_ "breadcrumbs", Lucid.makeAttribute "aria-label" "Breadcrumb"] <| do
614: Lucid.ol_ [Lucid.class_ "breadcrumb-list"] <| do
615: traverse_ renderCrumb (zip [0 ..] crumbs)
616: where
617: renderCrumb :: (Monad m') => (Int, Breadcrumb) -> Lucid.HtmlT m' ()
618: renderCrumb (idx, Breadcrumb label mHref) = do
619: Lucid.li_ [Lucid.class_ "breadcrumb-item"] <| do
620: when (idx > 0) <| Lucid.span_ [Lucid.class_ "breadcrumb-sep"] ">"
621: case mHref of
622: Just href -> Lucid.a_ [Lucid.href_ href] (Lucid.toHtml label)
623: Nothing -> Lucid.span_ [Lucid.class_ "breadcrumb-current"] (Lucid.toHtml label)
624:
625: getAncestors :: [TaskCore.Task] -> TaskCore.Task -> [TaskCore.Task]
626: getAncestors allTasks task =
627: case TaskCore.taskParent task of
628: Nothing -> [task]
629: Just pid -> case TaskCore.findTask pid allTasks of
630: Nothing -> [task]
631: Just parent -> getAncestors allTasks parent ++ [task]
632:
633: taskBreadcrumbs :: [TaskCore.Task] -> TaskCore.Task -> Breadcrumbs
634: taskBreadcrumbs allTasks task =
635: let ancestors = getAncestors allTasks task
636: taskCrumbs = [Breadcrumb (TaskCore.taskId t) (Just ("/tasks/" <> TaskCore.taskId t)) | t <- List.init ancestors]
637: currentCrumb = Breadcrumb (TaskCore.taskId task) Nothing
638: in [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks")]
639: ++ taskCrumbs
640: ++ [currentCrumb]
641:
642: navbar :: (Monad m) => Lucid.HtmlT m ()
643: navbar =
644: Lucid.nav_ [Lucid.class_ "navbar"] <| do
645: Lucid.a_ [Lucid.href_ "/", Lucid.class_ "navbar-brand"] "Junior"
646: Lucid.input_
647: [ Lucid.type_ "checkbox",
648: Lucid.id_ "navbar-toggle",
649: Lucid.class_ "navbar-toggle-checkbox"
650: ]
651: Lucid.label_
652: [ Lucid.for_ "navbar-toggle",
653: Lucid.class_ "navbar-hamburger"
654: ]
655: <| do
656: Lucid.span_ [Lucid.class_ "hamburger-line"] ""
657: Lucid.span_ [Lucid.class_ "hamburger-line"] ""
658: Lucid.span_ [Lucid.class_ "hamburger-line"] ""
659: Lucid.div_ [Lucid.class_ "navbar-links"] <| do
660: Lucid.a_ [Lucid.href_ "/", Lucid.class_ "navbar-link"] "Dashboard"
661: Lucid.div_ [Lucid.class_ "navbar-dropdown"] <| do
662: Lucid.button_ [Lucid.class_ "navbar-dropdown-btn"] "Tasks ▾"
663: Lucid.div_ [Lucid.class_ "navbar-dropdown-content"] <| do
664: Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "navbar-dropdown-item"] "Ready"
665: Lucid.a_ [Lucid.href_ "/blocked", Lucid.class_ "navbar-dropdown-item"] "Blocked"
666: Lucid.a_ [Lucid.href_ "/intervention", Lucid.class_ "navbar-dropdown-item"] "Human Action"
667: Lucid.a_ [Lucid.href_ "/tasks", Lucid.class_ "navbar-dropdown-item"] "All"
668: Lucid.div_ [Lucid.class_ "navbar-dropdown"] <| do
669: Lucid.button_ [Lucid.class_ "navbar-dropdown-btn"] "Plans ▾"
670: Lucid.div_ [Lucid.class_ "navbar-dropdown-content"] <| do
671: Lucid.a_ [Lucid.href_ "/epics", Lucid.class_ "navbar-dropdown-item"] "Epics"
672: Lucid.a_ [Lucid.href_ "/kb", Lucid.class_ "navbar-dropdown-item"] "KB"
673: Lucid.a_ [Lucid.href_ "/stats", Lucid.class_ "navbar-link"] "Stats"
674:
675: statusBadge :: (Monad m) => TaskCore.Status -> Lucid.HtmlT m ()
676: statusBadge status =
677: let (cls, label) = case status of
678: TaskCore.Draft -> ("badge badge-draft", "Draft")
679: TaskCore.Open -> ("badge badge-open", "Open")
680: TaskCore.InProgress -> ("badge badge-inprogress", "In Progress")
681: TaskCore.Review -> ("badge badge-review", "Review")
682: TaskCore.Approved -> ("badge badge-approved", "Approved")
683: TaskCore.Done -> ("badge badge-done", "Done")
684: TaskCore.NeedsHelp -> ("badge badge-needshelp", "Needs Help")
685: in Lucid.span_ [Lucid.class_ cls] label
686:
687: complexityBadge :: (Monad m) => Int -> Lucid.HtmlT m ()
688: complexityBadge complexity =
689: let cls = "badge badge-complexity badge-complexity-" <> tshow complexity
690: label = "ℂ " <> tshow complexity
691: in Lucid.span_ [Lucid.class_ cls, Lucid.title_ "Task Complexity (1-5)"] (Lucid.toHtml label)
692:
693: sortDropdown :: (Monad m) => Text -> SortOrder -> Lucid.HtmlT m ()
694: sortDropdown basePath currentSort =
695: Lucid.div_ [Lucid.class_ "sort-dropdown"] <| do
696: Lucid.span_ [Lucid.class_ "sort-label"] "Sort:"
697: Lucid.div_ [Lucid.class_ "sort-dropdown-wrapper navbar-dropdown"] <| do
698: Lucid.button_ [Lucid.class_ "sort-dropdown-btn navbar-dropdown-btn"]
699: <| Lucid.toHtml (sortOrderLabel currentSort <> " ▾")
700: Lucid.div_ [Lucid.class_ "sort-dropdown-content navbar-dropdown-content"] <| do
701: sortOption basePath SortNewest currentSort
702: sortOption basePath SortOldest currentSort
703: sortOption basePath SortUpdated currentSort
704: sortOption basePath SortPriorityHigh currentSort
705: sortOption basePath SortPriorityLow currentSort
706:
707: sortOption :: (Monad m) => Text -> SortOrder -> SortOrder -> Lucid.HtmlT m ()
708: sortOption basePath option currentSort =
709: let cls = "sort-dropdown-item navbar-dropdown-item" <> if option == currentSort then " active" else ""
710: href = basePath <> "?sort=" <> sortOrderToParam option
711: in Lucid.a_ [Lucid.href_ href, Lucid.class_ cls] (Lucid.toHtml (sortOrderLabel option))
712:
713: multiColorProgressBar :: (Monad m) => TaskCore.TaskStats -> Lucid.HtmlT m ()
714: multiColorProgressBar stats =
715: let total = TaskCore.totalTasks stats
716: doneCount = TaskCore.doneTasks stats
717: inProgressCount = TaskCore.inProgressTasks stats
718: openCount = TaskCore.openTasks stats + TaskCore.reviewTasks stats + TaskCore.approvedTasks stats
719: donePct = if total == 0 then 0 else (doneCount * 100) `div` total
720: inProgressPct = if total == 0 then 0 else (inProgressCount * 100) `div` total
721: openPct = if total == 0 then 0 else (openCount * 100) `div` total
722: in Lucid.div_ [Lucid.class_ "multi-progress-container"] <| do
723: Lucid.div_ [Lucid.class_ "multi-progress-bar"] <| do
724: when (donePct > 0)
725: <| Lucid.div_
726: [ Lucid.class_ "multi-progress-segment progress-done",
727: Lucid.style_ ("width: " <> tshow donePct <> "%"),
728: Lucid.title_ (tshow doneCount <> " done")
729: ]
730: ""
731: when (inProgressPct > 0)
732: <| Lucid.div_
733: [ Lucid.class_ "multi-progress-segment progress-inprogress",
734: Lucid.style_ ("width: " <> tshow inProgressPct <> "%"),
735: Lucid.title_ (tshow inProgressCount <> " in progress")
736: ]
737: ""
738: when (openPct > 0)
739: <| Lucid.div_
740: [ Lucid.class_ "multi-progress-segment progress-open",
741: Lucid.style_ ("width: " <> tshow openPct <> "%"),
742: Lucid.title_ (tshow openCount <> " open")
743: ]
744: ""
745: Lucid.div_ [Lucid.class_ "progress-legend"] <| do
746: Lucid.span_ [Lucid.class_ "legend-item"] <| do
747: Lucid.span_ [Lucid.class_ "legend-dot legend-done"] ""
748: Lucid.toHtml ("Done " <> tshow doneCount)
749: Lucid.span_ [Lucid.class_ "legend-item"] <| do
750: Lucid.span_ [Lucid.class_ "legend-dot legend-inprogress"] ""
751: Lucid.toHtml ("In Progress " <> tshow inProgressCount)
752: Lucid.span_ [Lucid.class_ "legend-item"] <| do
753: Lucid.span_ [Lucid.class_ "legend-dot legend-open"] ""
754: Lucid.toHtml ("Open " <> tshow openCount)
755:
756: statusBadgeWithForm :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m ()
757: statusBadgeWithForm status tid =
758: Lucid.div_
759: [ Lucid.id_ "status-badge-container",
760: Lucid.class_ "status-badge-dropdown"
761: ]
762: <| do
763: clickableBadge status tid
764: statusDropdownOptions status tid
765:
766: clickableBadge :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m ()
767: clickableBadge status _tid =
768: let (cls, label) = case status of
769: TaskCore.Draft -> ("badge badge-draft status-badge-clickable", "Draft" :: Text)
770: TaskCore.Open -> ("badge badge-open status-badge-clickable", "Open")
771: TaskCore.InProgress -> ("badge badge-inprogress status-badge-clickable", "In Progress")
772: TaskCore.Review -> ("badge badge-review status-badge-clickable", "Review")
773: TaskCore.Approved -> ("badge badge-approved status-badge-clickable", "Approved")
774: TaskCore.Done -> ("badge badge-done status-badge-clickable", "Done")
775: TaskCore.NeedsHelp -> ("badge badge-needshelp status-badge-clickable", "Needs Help")
776: in Lucid.span_
777: [ Lucid.class_ cls,
778: Lucid.tabindex_ "0",
779: Lucid.role_ "button",
780: Lucid.makeAttribute "aria-haspopup" "true",
781: Lucid.makeAttribute "aria-expanded" "false",
782: Lucid.makeAttribute "onclick" "toggleStatusDropdown(this)",
783: Lucid.makeAttribute "onkeydown" "handleStatusKeydown(event, this)"
784: ]
785: <| do
786: Lucid.toHtml label
787: Lucid.span_ [Lucid.class_ "dropdown-arrow", Lucid.makeAttribute "aria-hidden" "true"] " ▾"
788:
789: statusDropdownOptions :: (Monad m) => TaskCore.Status -> Text -> Lucid.HtmlT m ()
790: statusDropdownOptions currentStatus tid =
791: Lucid.div_
792: [ Lucid.class_ "status-dropdown-menu",
793: Lucid.role_ "menu",
794: Lucid.makeAttribute "aria-label" "Change task status"
795: ]
796: <| do
797: statusOption TaskCore.Draft currentStatus tid
798: statusOption TaskCore.Open currentStatus tid
799: statusOption TaskCore.InProgress currentStatus tid
800: statusOption TaskCore.Review currentStatus tid
801: statusOption TaskCore.Approved currentStatus tid
802: statusOption TaskCore.Done currentStatus tid
803: statusOption TaskCore.NeedsHelp currentStatus tid
804:
805: statusOption :: (Monad m) => TaskCore.Status -> TaskCore.Status -> Text -> Lucid.HtmlT m ()
806: statusOption opt currentStatus tid =
807: let (cls, label) = case opt of
808: TaskCore.Draft -> ("badge badge-draft", "Draft" :: Text)
809: TaskCore.Open -> ("badge badge-open", "Open")
810: TaskCore.InProgress -> ("badge badge-inprogress", "In Progress")
811: TaskCore.Review -> ("badge badge-review", "Review")
812: TaskCore.Approved -> ("badge badge-approved", "Approved")
813: TaskCore.Done -> ("badge badge-done", "Done")
814: TaskCore.NeedsHelp -> ("badge badge-needshelp", "Needs Help")
815: isSelected = opt == currentStatus
816: optClass = cls <> " status-dropdown-option" <> if isSelected then " selected" else ""
817: in Lucid.form_
818: [ Lucid.class_ "status-option-form",
819: Lucid.role_ "none",
820: Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/status"),
821: Lucid.makeAttribute "hx-target" "#status-badge-container",
822: Lucid.makeAttribute "hx-swap" "outerHTML"
823: ]
824: <| do
825: Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "status", Lucid.value_ (tshow opt)]
826: Lucid.button_
827: [ Lucid.type_ "submit",
828: Lucid.class_ optClass,
829: Lucid.role_ "menuitem",
830: Lucid.tabindex_ "-1",
831: Lucid.makeAttribute "onkeydown" "handleMenuItemKeydown(event)"
832: ]
833: (Lucid.toHtml label)
834:
835: priorityBadgeWithForm :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m ()
836: priorityBadgeWithForm priority tid =
837: Lucid.div_
838: [ Lucid.id_ "priority-badge-container",
839: Lucid.class_ "priority-badge-dropdown"
840: ]
841: <| do
842: clickablePriorityBadge priority tid
843: priorityDropdownOptions priority tid
844:
845: clickablePriorityBadge :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m ()
846: clickablePriorityBadge priority _tid =
847: let (cls, label) = case priority of
848: TaskCore.P0 -> ("badge badge-p0 priority-badge-clickable", "P0 Critical" :: Text)
849: TaskCore.P1 -> ("badge badge-p1 priority-badge-clickable", "P1 High")
850: TaskCore.P2 -> ("badge badge-p2 priority-badge-clickable", "P2 Normal")
851: TaskCore.P3 -> ("badge badge-p3 priority-badge-clickable", "P3 Low")
852: TaskCore.P4 -> ("badge badge-p4 priority-badge-clickable", "P4 Defer")
853: in Lucid.span_
854: [ Lucid.class_ cls,
855: Lucid.tabindex_ "0",
856: Lucid.role_ "button",
857: Lucid.makeAttribute "aria-haspopup" "true",
858: Lucid.makeAttribute "aria-expanded" "false",
859: Lucid.makeAttribute "onclick" "togglePriorityDropdown(this)",
860: Lucid.makeAttribute "onkeydown" "handlePriorityKeydown(event, this)"
861: ]
862: <| do
863: Lucid.toHtml label
864: Lucid.span_ [Lucid.class_ "dropdown-arrow", Lucid.makeAttribute "aria-hidden" "true"] " ▾"
865:
866: priorityDropdownOptions :: (Monad m) => TaskCore.Priority -> Text -> Lucid.HtmlT m ()
867: priorityDropdownOptions currentPriority tid =
868: Lucid.div_
869: [ Lucid.class_ "priority-dropdown-menu",
870: Lucid.role_ "menu",
871: Lucid.makeAttribute "aria-label" "Change task priority"
872: ]
873: <| do
874: priorityOption TaskCore.P0 currentPriority tid
875: priorityOption TaskCore.P1 currentPriority tid
876: priorityOption TaskCore.P2 currentPriority tid
877: priorityOption TaskCore.P3 currentPriority tid
878: priorityOption TaskCore.P4 currentPriority tid
879:
880: priorityOption :: (Monad m) => TaskCore.Priority -> TaskCore.Priority -> Text -> Lucid.HtmlT m ()
881: priorityOption opt currentPriority tid =
882: let (cls, label) = case opt of
883: TaskCore.P0 -> ("badge badge-p0", "P0 Critical" :: Text)
884: TaskCore.P1 -> ("badge badge-p1", "P1 High")
885: TaskCore.P2 -> ("badge badge-p2", "P2 Normal")
886: TaskCore.P3 -> ("badge badge-p3", "P3 Low")
887: TaskCore.P4 -> ("badge badge-p4", "P4 Defer")
888: isSelected = opt == currentPriority
889: optClass = cls <> " priority-dropdown-option" <> if isSelected then " selected" else ""
890: in Lucid.form_
891: [ Lucid.class_ "priority-option-form",
892: Lucid.role_ "none",
893: Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/priority"),
894: Lucid.makeAttribute "hx-target" "#priority-badge-container",
895: Lucid.makeAttribute "hx-swap" "outerHTML"
896: ]
897: <| do
898: Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "priority", Lucid.value_ (tshow opt)]
899: Lucid.button_
900: [ Lucid.type_ "submit",
901: Lucid.class_ optClass,
902: Lucid.role_ "menuitem",
903: Lucid.tabindex_ "-1",
904: Lucid.makeAttribute "onkeydown" "handlePriorityMenuItemKeydown(event)"
905: ]
906: (Lucid.toHtml label)
907:
908: renderTaskCard :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m ()
909: renderTaskCard t =
910: Lucid.a_
911: [ Lucid.class_ "task-card task-card-link",
912: Lucid.href_ ("/tasks/" <> TaskCore.taskId t)
913: ]
914: <| do
915: Lucid.div_ [Lucid.class_ "task-header"] <| do
916: Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (TaskCore.taskId t))
917: statusBadge (TaskCore.taskStatus t)
918: Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
919: Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t))
920:
921: renderBlockedTaskCard :: (Monad m) => (TaskCore.Task, Int) -> Lucid.HtmlT m ()
922: renderBlockedTaskCard (t, impact) =
923: Lucid.a_
924: [ Lucid.class_ "task-card task-card-link",
925: Lucid.href_ ("/tasks/" <> TaskCore.taskId t)
926: ]
927: <| do
928: Lucid.div_ [Lucid.class_ "task-header"] <| do
929: Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (TaskCore.taskId t))
930: statusBadge (TaskCore.taskStatus t)
931: Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
932: when (impact > 0)
933: <| Lucid.span_ [Lucid.class_ "blocking-impact"] (Lucid.toHtml ("Blocks " <> tshow impact))
934: Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t))
935:
936: renderListGroupItem :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m ()
937: renderListGroupItem t =
938: Lucid.a_
939: [ Lucid.class_ "list-group-item",
940: Lucid.href_ ("/tasks/" <> TaskCore.taskId t),
941: Lucid.makeAttribute "hx-boost" "true",
942: Lucid.makeAttribute "hx-target" "body",
943: Lucid.makeAttribute "hx-swap" "innerHTML"
944: ]
945: <| do
946: Lucid.div_ [Lucid.class_ "list-group-item-content"] <| do
947: Lucid.span_ [Lucid.class_ "list-group-item-id"] (Lucid.toHtml (TaskCore.taskId t))
948: Lucid.span_ [Lucid.class_ "list-group-item-title"] (Lucid.toHtml (TaskCore.taskTitle t))
949: Lucid.div_ [Lucid.class_ "list-group-item-meta"] <| do
950: statusBadge (TaskCore.taskStatus t)
951: Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
952:
953: instance Lucid.ToHtml HomePage where
954: toHtmlRaw = Lucid.toHtml
955: toHtml (HomePage stats readyTasks recentTasks hasMoreRecent globalMetrics currentRange _now) =
956: Lucid.doctypehtml_ <| do
957: pageHead "Jr Dashboard"
958: pageBody <| do
959: Lucid.div_ [Lucid.class_ "container"] <| do
960: Lucid.h2_ "Task Status"
961: Lucid.div_ [Lucid.class_ "time-filter"] <| do
962: timeFilterBtn "Today" Today currentRange
963: timeFilterBtn "This Week" Week currentRange
964: timeFilterBtn "This Month" Month currentRange
965: timeFilterBtn "All Time" AllTime currentRange
966: Lucid.div_ [Lucid.class_ "stats-grid"] <| do
967: statCard "Open" (TaskCore.openTasks stats) "badge-open" "/tasks?status=Open"
968: statCard "In Progress" (TaskCore.inProgressTasks stats) "badge-inprogress" "/tasks?status=InProgress"
969: statCard "Review" (TaskCore.reviewTasks stats) "badge-review" "/tasks?status=Review"
970: statCard "Approved" (TaskCore.approvedTasks stats) "badge-approved" "/tasks?status=Approved"
971: statCard "Done" (TaskCore.doneTasks stats) "badge-done" "/tasks?status=Done"
972: metricCard "Cost" (formatCost (TaskCore.aggTotalCostCents globalMetrics))
973: metricCard "Duration" (formatDuration (TaskCore.aggTotalDurationSeconds globalMetrics))
974:
975: Lucid.h2_ <| do
976: "Ready Queue "
977: Lucid.span_
978: [ Lucid.class_ "ready-count",
979: Lucid.makeAttribute "hx-get" "/partials/ready-count",
980: Lucid.makeAttribute "hx-trigger" "every 5s"
981: ]
982: <| do
983: Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "ready-link"]
984: <| Lucid.toHtml ("(" <> tshow (length readyTasks) <> " tasks)")
985: if null readyTasks
986: then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks ready for work."
987: else
988: Lucid.div_ [Lucid.class_ "list-group"]
989: <| traverse_ renderListGroupItem (take 5 readyTasks)
990:
991: Lucid.h2_ "Recent Activity"
992: let newestTimestamp = maybe 0 taskToUnixTs (head recentTasks)
993: Lucid.div_
994: [ Lucid.class_ "recent-activity",
995: Lucid.id_ "recent-activity",
996: Lucid.makeAttribute "data-newest-ts" (tshow newestTimestamp),
997: Lucid.makeAttribute "hx-get" "/partials/recent-activity-new",
998: Lucid.makeAttribute "hx-trigger" "every 10s",
999: Lucid.makeAttribute "hx-vals" "js:{since: document.getElementById('recent-activity')?.dataset?.newestTs || 0}",
1000: Lucid.makeAttribute "hx-target" "#activity-list",
1001: Lucid.makeAttribute "hx-swap" "afterbegin"
1002: ]
1003: <| do
1004: Lucid.div_ [Lucid.id_ "activity-list", Lucid.class_ "list-group"]
1005: <| traverse_ renderListGroupItem recentTasks
1006: when hasMoreRecent
1007: <| Lucid.button_
1008: [ Lucid.id_ "activity-load-more",
1009: Lucid.class_ "btn btn-secondary load-more-btn",
1010: Lucid.makeAttribute "hx-get" "/partials/recent-activity-more?offset=5",
1011: Lucid.makeAttribute "hx-target" "#activity-list",
1012: Lucid.makeAttribute "hx-swap" "beforeend"
1013: ]
1014: "Load More"
1015: where
1016: statCard :: (Monad m) => Text -> Int -> Text -> Text -> Lucid.HtmlT m ()
1017: statCard label count badgeClass href =
1018: Lucid.a_ [Lucid.href_ href, Lucid.class_ ("stat-card " <> badgeClass)] <| do
1019: Lucid.div_ [Lucid.class_ "stat-count"] (Lucid.toHtml (tshow count))
1020: Lucid.div_ [Lucid.class_ "stat-label"] (Lucid.toHtml label)
1021:
1022: metricCard :: (Monad m) => Text -> Text -> Lucid.HtmlT m ()
1023: metricCard label value =
1024: Lucid.div_ [Lucid.class_ "stat-card badge-neutral"] <| do
1025: Lucid.div_ [Lucid.class_ "stat-count"] (Lucid.toHtml value)
1026: Lucid.div_ [Lucid.class_ "stat-label"] (Lucid.toHtml label)
1027:
1028: formatCost :: Int -> Text
1029: formatCost cents =
1030: let dollars = fromIntegral cents / 100.0 :: Double
1031: in Text.pack ("$" <> showFFloat (Just 2) dollars "")
1032:
1033: formatDuration :: Int -> Text
1034: formatDuration totalSeconds
1035: | totalSeconds < 60 = tshow totalSeconds <> "s"
1036: | totalSeconds < 3600 =
1037: let mins = totalSeconds `div` 60
1038: in tshow mins <> "m"
1039: | otherwise =
1040: let hours = totalSeconds `div` 3600
1041: mins = (totalSeconds `mod` 3600) `div` 60
1042: in tshow hours <> "h " <> tshow mins <> "m"
1043:
1044: timeFilterBtn :: (Monad m) => Text -> TimeRange -> TimeRange -> Lucid.HtmlT m ()
1045: timeFilterBtn label range current =
1046: let activeClass = if range == current then " active" else ""
1047: href = "/?" <> "range=" <> timeRangeToParam range
1048: in Lucid.a_
1049: [ Lucid.href_ href,
1050: Lucid.class_ ("time-filter-btn" <> activeClass)
1051: ]
1052: (Lucid.toHtml label)
1053:
1054: instance Lucid.ToHtml ReadyQueuePage where
1055: toHtmlRaw = Lucid.toHtml
1056: toHtml (ReadyQueuePage tasks currentSort _now) =
1057: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Ready Queue" Nothing]
1058: in Lucid.doctypehtml_ <| do
1059: pageHead "Ready Queue - Jr"
1060: pageBodyWithCrumbs crumbs <| do
1061: Lucid.div_ [Lucid.class_ "container"] <| do
1062: Lucid.div_ [Lucid.class_ "page-header-row"] <| do
1063: Lucid.h1_ <| Lucid.toHtml ("Ready Queue (" <> tshow (length tasks) <> " tasks)")
1064: sortDropdown "/ready" currentSort
1065: if null tasks
1066: then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks are ready for work."
1067: else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard tasks
1068:
1069: instance Lucid.ToHtml BlockedPage where
1070: toHtmlRaw = Lucid.toHtml
1071: toHtml (BlockedPage tasksWithImpact currentSort _now) =
1072: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Blocked" Nothing]
1073: in Lucid.doctypehtml_ <| do
1074: pageHead "Blocked Tasks - Jr"
1075: pageBodyWithCrumbs crumbs <| do
1076: Lucid.div_ [Lucid.class_ "container"] <| do
1077: Lucid.div_ [Lucid.class_ "page-header-row"] <| do
1078: Lucid.h1_ <| Lucid.toHtml ("Blocked Tasks (" <> tshow (length tasksWithImpact) <> " tasks)")
1079: sortDropdown "/blocked" currentSort
1080: Lucid.p_ [Lucid.class_ "info-msg"] "Tasks with unmet blocking dependencies, sorted by blocking impact."
1081: if null tasksWithImpact
1082: then Lucid.p_ [Lucid.class_ "empty-msg"] "No blocked tasks."
1083: else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderBlockedTaskCard tasksWithImpact
1084:
1085: instance Lucid.ToHtml InterventionPage where
1086: toHtmlRaw = Lucid.toHtml
1087: toHtml (InterventionPage actionItems currentSort _now) =
1088: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Needs Human Action" Nothing]
1089: failed = TaskCore.failedTasks actionItems
1090: epicsReady = TaskCore.epicsInReview actionItems
1091: needsHelp = TaskCore.tasksNeedingHelp actionItems
1092: totalCount = length failed + length epicsReady + length needsHelp
1093: in Lucid.doctypehtml_ <| do
1094: pageHead "Needs Human Action - Jr"
1095: pageBodyWithCrumbs crumbs <| do
1096: Lucid.div_ [Lucid.class_ "container"] <| do
1097: Lucid.div_ [Lucid.class_ "page-header-row"] <| do
1098: Lucid.h1_ <| Lucid.toHtml ("Needs Human Action (" <> tshow totalCount <> " items)")
1099: sortDropdown "/intervention" currentSort
1100: if totalCount == 0
1101: then Lucid.p_ [Lucid.class_ "empty-msg"] "No items need human action."
1102: else do
1103: unless (null failed) <| do
1104: Lucid.h2_ [Lucid.class_ "section-header"] <| Lucid.toHtml ("Failed Tasks (" <> tshow (length failed) <> ")")
1105: Lucid.p_ [Lucid.class_ "info-msg"] "Tasks that have failed 3+ times and need human help."
1106: Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard (sortTasks currentSort failed)
1107: unless (null epicsReady) <| do
1108: Lucid.h2_ [Lucid.class_ "section-header"] <| Lucid.toHtml ("Epics Ready for Review (" <> tshow (length epicsReady) <> ")")
1109: Lucid.p_ [Lucid.class_ "info-msg"] "Epics with all children completed. Verify before closing."
1110: Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderEpicReviewCard epicsReady
1111: unless (null needsHelp) <| do
1112: Lucid.h2_ [Lucid.class_ "section-header"] <| Lucid.toHtml ("Needs Help (" <> tshow (length needsHelp) <> ")")
1113: Lucid.p_ [Lucid.class_ "info-msg"] "Tasks where Jr needs human guidance or decisions."
1114: Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderTaskCard (sortTasks currentSort needsHelp)
1115:
1116: renderEpicReviewCard :: (Monad m) => TaskCore.EpicForReview -> Lucid.HtmlT m ()
1117: renderEpicReviewCard epicReview = do
1118: let task = TaskCore.epicTask epicReview
1119: total = TaskCore.epicTotal epicReview
1120: completed = TaskCore.epicCompleted epicReview
1121: progressText = tshow completed <> "/" <> tshow total <> " subtasks done"
1122: Lucid.div_ [Lucid.class_ "task-card"] <| do
1123: Lucid.div_ [Lucid.class_ "task-card-header"] <| do
1124: Lucid.div_ [Lucid.class_ "task-title-row"] <| do
1125: Lucid.a_
1126: [Lucid.href_ ("/tasks/" <> TaskCore.taskId task), Lucid.class_ "task-link"]
1127: <| Lucid.toHtml (TaskCore.taskTitle task)
1128: Lucid.span_ [Lucid.class_ "badge badge-epic"] "Epic"
1129: Lucid.span_ [Lucid.class_ "task-id"] <| Lucid.toHtml (TaskCore.taskId task)
1130: Lucid.div_ [Lucid.class_ "task-card-body"] <| do
1131: Lucid.div_ [Lucid.class_ "progress-info"] <| do
1132: Lucid.span_ [Lucid.class_ "badge badge-success"] <| Lucid.toHtml progressText
1133: Lucid.div_ [Lucid.class_ "epic-actions"] <| do
1134: Lucid.form_
1135: [ Lucid.method_ "POST",
1136: Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/status"),
1137: Lucid.class_ "inline-form"
1138: ]
1139: <| do
1140: Lucid.input_ [Lucid.type_ "hidden", Lucid.name_ "status", Lucid.value_ "done"]
1141: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-success btn-sm"] "Approve & Close"
1142:
1143: instance Lucid.ToHtml KBPage where
1144: toHtmlRaw = Lucid.toHtml
1145: toHtml (KBPage facts) =
1146: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Knowledge Base" Nothing]
1147: in Lucid.doctypehtml_ <| do
1148: pageHead "Knowledge Base - Jr"
1149: pageBodyWithCrumbs crumbs <| do
1150: Lucid.div_ [Lucid.class_ "container"] <| do
1151: Lucid.h1_ "Knowledge Base"
1152: Lucid.p_ [Lucid.class_ "info-msg"] "Facts learned during task execution."
1153:
1154: Lucid.details_ [Lucid.class_ "create-fact-section"] <| do
1155: Lucid.summary_ [Lucid.class_ "btn btn-primary create-fact-toggle"] "Create New Fact"
1156: Lucid.form_
1157: [ Lucid.method_ "POST",
1158: Lucid.action_ "/kb/create",
1159: Lucid.class_ "fact-create-form"
1160: ]
1161: <| do
1162: Lucid.div_ [Lucid.class_ "form-group"] <| do
1163: Lucid.label_ [Lucid.for_ "project"] "Project:"
1164: Lucid.input_
1165: [ Lucid.type_ "text",
1166: Lucid.name_ "project",
1167: Lucid.id_ "project",
1168: Lucid.class_ "form-input",
1169: Lucid.required_ "required",
1170: Lucid.placeholder_ "e.g., Omni/Jr"
1171: ]
1172: Lucid.div_ [Lucid.class_ "form-group"] <| do
1173: Lucid.label_ [Lucid.for_ "content"] "Fact Content:"
1174: Lucid.textarea_
1175: [ Lucid.name_ "content",
1176: Lucid.id_ "content",
1177: Lucid.class_ "form-textarea",
1178: Lucid.rows_ "4",
1179: Lucid.required_ "required",
1180: Lucid.placeholder_ "Describe the fact or knowledge..."
1181: ]
1182: ""
1183: Lucid.div_ [Lucid.class_ "form-group"] <| do
1184: Lucid.label_ [Lucid.for_ "files"] "Related Files (comma-separated):"
1185: Lucid.input_
1186: [ Lucid.type_ "text",
1187: Lucid.name_ "files",
1188: Lucid.id_ "files",
1189: Lucid.class_ "form-input",
1190: Lucid.placeholder_ "path/to/file1.hs, path/to/file2.hs"
1191: ]
1192: Lucid.div_ [Lucid.class_ "form-group"] <| do
1193: Lucid.label_ [Lucid.for_ "confidence"] "Confidence (0.0 - 1.0):"
1194: Lucid.input_
1195: [ Lucid.type_ "number",
1196: Lucid.name_ "confidence",
1197: Lucid.id_ "confidence",
1198: Lucid.class_ "form-input",
1199: Lucid.step_ "0.1",
1200: Lucid.min_ "0",
1201: Lucid.max_ "1",
1202: Lucid.value_ "0.8"
1203: ]
1204: Lucid.div_ [Lucid.class_ "form-actions"] <| do
1205: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Create Fact"
1206:
1207: if null facts
1208: then Lucid.p_ [Lucid.class_ "empty-msg"] "No facts recorded yet."
1209: else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ renderFactCard facts
1210: where
1211: renderFactCard :: (Monad m) => TaskCore.Fact -> Lucid.HtmlT m ()
1212: renderFactCard f =
1213: let factUrl = "/kb/" <> maybe "-" tshow (TaskCore.factId f)
1214: in Lucid.a_
1215: [ Lucid.class_ "task-card task-card-link",
1216: Lucid.href_ factUrl
1217: ]
1218: <| do
1219: Lucid.div_ [Lucid.class_ "task-header"] <| do
1220: Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (maybe "-" tshow (TaskCore.factId f)))
1221: confidenceBadge (TaskCore.factConfidence f)
1222: Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (TaskCore.factProject f))
1223: Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (Text.take 80 (TaskCore.factContent f) <> if Text.length (TaskCore.factContent f) > 80 then "..." else ""))
1224: unless (null (TaskCore.factRelatedFiles f)) <| do
1225: Lucid.p_ [Lucid.class_ "kb-files"] <| do
1226: Lucid.span_ [Lucid.class_ "files-label"] "Files: "
1227: Lucid.toHtml (Text.intercalate ", " (take 3 (TaskCore.factRelatedFiles f)))
1228: when (length (TaskCore.factRelatedFiles f) > 3) <| do
1229: Lucid.toHtml (" +" <> tshow (length (TaskCore.factRelatedFiles f) - 3) <> " more")
1230:
1231: confidenceBadge :: (Monad m) => Double -> Lucid.HtmlT m ()
1232: confidenceBadge conf =
1233: let pct = floor (conf * 100) :: Int
1234: cls
1235: | conf >= 0.8 = "badge badge-done"
1236: | conf >= 0.5 = "badge badge-inprogress"
1237: | otherwise = "badge badge-open"
1238: in Lucid.span_ [Lucid.class_ cls] (Lucid.toHtml (tshow pct <> "%"))
1239:
1240: instance Lucid.ToHtml FactDetailPage where
1241: toHtmlRaw = Lucid.toHtml
1242: toHtml (FactDetailNotFound fid) =
1243: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Knowledge Base" (Just "/kb"), Breadcrumb ("Fact #" <> tshow fid) Nothing]
1244: in Lucid.doctypehtml_ <| do
1245: pageHead "Fact Not Found - Jr"
1246: pageBodyWithCrumbs crumbs <| do
1247: Lucid.div_ [Lucid.class_ "container"] <| do
1248: Lucid.h1_ "Fact Not Found"
1249: Lucid.p_ [Lucid.class_ "error-msg"] (Lucid.toHtml ("Fact with ID " <> tshow fid <> " not found."))
1250: Lucid.a_ [Lucid.href_ "/kb", Lucid.class_ "btn btn-secondary"] "Back to Knowledge Base"
1251: toHtml (FactDetailFound fact now) =
1252: let fid' = maybe "-" tshow (TaskCore.factId fact)
1253: crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Knowledge Base" (Just "/kb"), Breadcrumb ("Fact #" <> fid') Nothing]
1254: in Lucid.doctypehtml_ <| do
1255: pageHead "Fact Detail - Jr"
1256: pageBodyWithCrumbs crumbs <| do
1257: Lucid.div_ [Lucid.class_ "container"] <| do
1258: Lucid.div_ [Lucid.class_ "task-detail-header"] <| do
1259: Lucid.h1_ <| do
1260: Lucid.span_ [Lucid.class_ "detail-id"] (Lucid.toHtml ("Fact #" <> maybe "-" tshow (TaskCore.factId fact)))
1261: Lucid.div_ [Lucid.class_ "task-meta-row"] <| do
1262: Lucid.span_ [Lucid.class_ "meta-label"] "Project:"
1263: Lucid.span_ [Lucid.class_ "meta-value"] (Lucid.toHtml (TaskCore.factProject fact))
1264: Lucid.span_ [Lucid.class_ "meta-label"] "Confidence:"
1265: confidenceBadgeDetail (TaskCore.factConfidence fact)
1266: Lucid.span_ [Lucid.class_ "meta-label"] "Created:"
1267: Lucid.span_ [Lucid.class_ "meta-value"] (renderRelativeTimestamp now (TaskCore.factCreatedAt fact))
1268:
1269: Lucid.div_ [Lucid.class_ "detail-section"] <| do
1270: Lucid.h2_ "Content"
1271: Lucid.form_
1272: [ Lucid.method_ "POST",
1273: Lucid.action_ ("/kb/" <> maybe "-" tshow (TaskCore.factId fact) <> "/edit"),
1274: Lucid.class_ "fact-edit-form"
1275: ]
1276: <| do
1277: Lucid.div_ [Lucid.class_ "form-group"] <| do
1278: Lucid.label_ [Lucid.for_ "content"] "Fact Content:"
1279: Lucid.textarea_
1280: [ Lucid.name_ "content",
1281: Lucid.id_ "content",
1282: Lucid.class_ "form-textarea",
1283: Lucid.rows_ "6"
1284: ]
1285: (Lucid.toHtml (TaskCore.factContent fact))
1286:
1287: Lucid.div_ [Lucid.class_ "form-group"] <| do
1288: Lucid.label_ [Lucid.for_ "files"] "Related Files (comma-separated):"
1289: Lucid.input_
1290: [ Lucid.type_ "text",
1291: Lucid.name_ "files",
1292: Lucid.id_ "files",
1293: Lucid.class_ "form-input",
1294: Lucid.value_ (Text.intercalate ", " (TaskCore.factRelatedFiles fact))
1295: ]
1296:
1297: Lucid.div_ [Lucid.class_ "form-group"] <| do
1298: Lucid.label_ [Lucid.for_ "confidence"] "Confidence (0.0 - 1.0):"
1299: Lucid.input_
1300: [ Lucid.type_ "number",
1301: Lucid.name_ "confidence",
1302: Lucid.id_ "confidence",
1303: Lucid.class_ "form-input",
1304: Lucid.step_ "0.1",
1305: Lucid.min_ "0",
1306: Lucid.max_ "1",
1307: Lucid.value_ (tshow (TaskCore.factConfidence fact))
1308: ]
1309:
1310: Lucid.div_ [Lucid.class_ "form-actions"] <| do
1311: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Save Changes"
1312:
1313: case TaskCore.factSourceTask fact of
1314: Nothing -> pure ()
1315: Just tid -> do
1316: Lucid.div_ [Lucid.class_ "detail-section"] <| do
1317: Lucid.h2_ "Source Task"
1318: Lucid.a_ [Lucid.href_ ("/tasks/" <> tid), Lucid.class_ "task-link"] (Lucid.toHtml tid)
1319:
1320: Lucid.div_ [Lucid.class_ "detail-section danger-zone"] <| do
1321: Lucid.h2_ "Danger Zone"
1322: Lucid.form_
1323: [ Lucid.method_ "POST",
1324: Lucid.action_ ("/kb/" <> maybe "-" tshow (TaskCore.factId fact) <> "/delete"),
1325: Lucid.class_ "delete-form",
1326: Lucid.makeAttribute "onsubmit" "return confirm('Are you sure you want to delete this fact?');"
1327: ]
1328: <| do
1329: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-danger"] "Delete Fact"
1330:
1331: Lucid.div_ [Lucid.class_ "back-link"] <| do
1332: Lucid.a_ [Lucid.href_ "/kb"] "← Back to Knowledge Base"
1333: where
1334: confidenceBadgeDetail :: (Monad m) => Double -> Lucid.HtmlT m ()
1335: confidenceBadgeDetail conf =
1336: let pct = floor (conf * 100) :: Int
1337: cls
1338: | conf >= 0.8 = "badge badge-done"
1339: | conf >= 0.5 = "badge badge-inprogress"
1340: | otherwise = "badge badge-open"
1341: in Lucid.span_ [Lucid.class_ cls] (Lucid.toHtml (tshow pct <> "%"))
1342:
1343: instance Lucid.ToHtml EpicsPage where
1344: toHtmlRaw = Lucid.toHtml
1345: toHtml (EpicsPage epics allTasks currentSort) =
1346: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Epics" Nothing]
1347: in Lucid.doctypehtml_ <| do
1348: pageHead "Epics - Jr"
1349: pageBodyWithCrumbs crumbs <| do
1350: Lucid.div_ [Lucid.class_ "container"] <| do
1351: Lucid.div_ [Lucid.class_ "page-header-row"] <| do
1352: Lucid.h1_ <| Lucid.toHtml ("Epics (" <> tshow (length epics) <> ")")
1353: sortDropdown "/epics" currentSort
1354: Lucid.p_ [Lucid.class_ "info-msg"] "All epics (large, multi-task projects)."
1355: if null epics
1356: then Lucid.p_ [Lucid.class_ "empty-msg"] "No epics found."
1357: else Lucid.div_ [Lucid.class_ "task-list"] <| traverse_ (renderEpicCardWithStats allTasks) epics
1358:
1359: epicProgressBar :: (Monad m) => Int -> Int -> Int -> Int -> Lucid.HtmlT m ()
1360: epicProgressBar doneCount inProgressCount openCount totalCount =
1361: let donePct = if totalCount == 0 then 0 else (doneCount * 100) `div` totalCount
1362: inProgressPct = if totalCount == 0 then 0 else (inProgressCount * 100) `div` totalCount
1363: openPct = if totalCount == 0 then 0 else (openCount * 100) `div` totalCount
1364: in Lucid.div_ [Lucid.class_ "multi-progress-container epic-progress"] <| do
1365: Lucid.div_ [Lucid.class_ "multi-progress-bar"] <| do
1366: when (donePct > 0)
1367: <| Lucid.div_
1368: [ Lucid.class_ "multi-progress-segment progress-done",
1369: Lucid.style_ ("width: " <> tshow donePct <> "%"),
1370: Lucid.title_ (tshow doneCount <> " done")
1371: ]
1372: ""
1373: when (inProgressPct > 0)
1374: <| Lucid.div_
1375: [ Lucid.class_ "multi-progress-segment progress-inprogress",
1376: Lucid.style_ ("width: " <> tshow inProgressPct <> "%"),
1377: Lucid.title_ (tshow inProgressCount <> " in progress")
1378: ]
1379: ""
1380: when (openPct > 0)
1381: <| Lucid.div_
1382: [ Lucid.class_ "multi-progress-segment progress-open",
1383: Lucid.style_ ("width: " <> tshow openPct <> "%"),
1384: Lucid.title_ (tshow openCount <> " open")
1385: ]
1386: ""
1387: Lucid.div_ [Lucid.class_ "progress-legend"] <| do
1388: Lucid.span_ [Lucid.class_ "legend-item"] <| do
1389: Lucid.span_ [Lucid.class_ "legend-dot legend-done"] ""
1390: Lucid.toHtml (tshow doneCount)
1391: Lucid.span_ [Lucid.class_ "legend-item"] <| do
1392: Lucid.span_ [Lucid.class_ "legend-dot legend-inprogress"] ""
1393: Lucid.toHtml (tshow inProgressCount)
1394: Lucid.span_ [Lucid.class_ "legend-item"] <| do
1395: Lucid.span_ [Lucid.class_ "legend-dot legend-open"] ""
1396: Lucid.toHtml (tshow openCount)
1397:
1398: renderEpicCardWithStats :: (Monad m) => [TaskCore.Task] -> TaskCore.Task -> Lucid.HtmlT m ()
1399: renderEpicCardWithStats allTasks t =
1400: let children = getDescendants allTasks (TaskCore.taskId t)
1401: openCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Open]
1402: inProgressCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.InProgress]
1403: reviewCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Review]
1404: doneCount = length [c | c <- children, TaskCore.taskStatus c == TaskCore.Done]
1405: totalCount = length children
1406: openAndReview = openCount + reviewCount
1407: in Lucid.a_
1408: [ Lucid.class_ "task-card task-card-link",
1409: Lucid.href_ ("/tasks/" <> TaskCore.taskId t)
1410: ]
1411: <| do
1412: Lucid.div_ [Lucid.class_ "task-header"] <| do
1413: Lucid.span_ [Lucid.class_ "task-id"] (Lucid.toHtml (TaskCore.taskId t))
1414: statusBadge (TaskCore.taskStatus t)
1415: Lucid.span_ [Lucid.class_ "priority"] (Lucid.toHtml (tshow (TaskCore.taskPriority t)))
1416: Lucid.p_ [Lucid.class_ "task-title"] (Lucid.toHtml (TaskCore.taskTitle t))
1417: when (totalCount > 0) <| epicProgressBar doneCount inProgressCount openAndReview totalCount
1418: unless (Text.null (TaskCore.taskDescription t))
1419: <| Lucid.p_ [Lucid.class_ "kb-preview"] (Lucid.toHtml (Text.take 200 (TaskCore.taskDescription t) <> "..."))
1420:
1421: getDescendants :: [TaskCore.Task] -> Text -> [TaskCore.Task]
1422: getDescendants allTasks parentId =
1423: let children = [c | c <- allTasks, maybe False (TaskCore.matchesId parentId) (TaskCore.taskParent c)]
1424: in children ++ concatMap (getDescendants allTasks <. TaskCore.taskId) children
1425:
1426: instance Lucid.ToHtml TaskListPage where
1427: toHtmlRaw = Lucid.toHtml
1428: toHtml (TaskListPage tasks filters currentSort _now) =
1429: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" Nothing]
1430: in Lucid.doctypehtml_ <| do
1431: pageHead "Tasks - Jr"
1432: pageBodyWithCrumbs crumbs <| do
1433: Lucid.div_ [Lucid.class_ "container"] <| do
1434: Lucid.div_ [Lucid.class_ "page-header-row"] <| do
1435: Lucid.h1_ <| Lucid.toHtml ("Tasks (" <> tshow (length tasks) <> ")")
1436: sortDropdown "/tasks" currentSort
1437:
1438: Lucid.div_ [Lucid.class_ "filter-form"] <| do
1439: Lucid.form_
1440: [ Lucid.method_ "GET",
1441: Lucid.action_ "/tasks",
1442: Lucid.makeAttribute "hx-get" "/partials/task-list",
1443: Lucid.makeAttribute "hx-target" "#task-list",
1444: Lucid.makeAttribute "hx-push-url" "/tasks",
1445: Lucid.makeAttribute "hx-trigger" "submit, change from:select"
1446: ]
1447: <| do
1448: Lucid.div_ [Lucid.class_ "filter-row"] <| do
1449: Lucid.div_ [Lucid.class_ "filter-group"] <| do
1450: Lucid.label_ [Lucid.for_ "status"] "Status:"
1451: Lucid.select_ [Lucid.name_ "status", Lucid.id_ "status", Lucid.class_ "filter-select"] <| do
1452: Lucid.option_ ([Lucid.value_ ""] <> maybeSelected Nothing (filterStatus filters)) "All"
1453: statusFilterOption TaskCore.Open (filterStatus filters)
1454: statusFilterOption TaskCore.InProgress (filterStatus filters)
1455: statusFilterOption TaskCore.Review (filterStatus filters)
1456: statusFilterOption TaskCore.Approved (filterStatus filters)
1457: statusFilterOption TaskCore.Done (filterStatus filters)
1458:
1459: Lucid.div_ [Lucid.class_ "filter-group"] <| do
1460: Lucid.label_ [Lucid.for_ "priority"] "Priority:"
1461: Lucid.select_ [Lucid.name_ "priority", Lucid.id_ "priority", Lucid.class_ "filter-select"] <| do
1462: Lucid.option_ ([Lucid.value_ ""] <> maybeSelected Nothing (filterPriority filters)) "All"
1463: priorityFilterOption TaskCore.P0 (filterPriority filters)
1464: priorityFilterOption TaskCore.P1 (filterPriority filters)
1465: priorityFilterOption TaskCore.P2 (filterPriority filters)
1466: priorityFilterOption TaskCore.P3 (filterPriority filters)
1467: priorityFilterOption TaskCore.P4 (filterPriority filters)
1468:
1469: Lucid.div_ [Lucid.class_ "filter-group"] <| do
1470: Lucid.label_ [Lucid.for_ "namespace"] "Namespace:"
1471: Lucid.input_
1472: [ Lucid.type_ "text",
1473: Lucid.name_ "namespace",
1474: Lucid.id_ "namespace",
1475: Lucid.class_ "filter-input",
1476: Lucid.placeholder_ "e.g. Omni/Jr",
1477: Lucid.value_ (fromMaybe "" (filterNamespace filters))
1478: ]
1479:
1480: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "filter-btn"] "Filter"
1481: Lucid.a_
1482: [ Lucid.href_ "/tasks",
1483: Lucid.class_ "clear-btn",
1484: Lucid.makeAttribute "hx-get" "/partials/task-list",
1485: Lucid.makeAttribute "hx-target" "#task-list",
1486: Lucid.makeAttribute "hx-push-url" "/tasks"
1487: ]
1488: "Clear"
1489:
1490: Lucid.div_ [Lucid.id_ "task-list"] <| do
1491: if null tasks
1492: then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks match the current filters."
1493: else Lucid.div_ [Lucid.class_ "list-group"] <| traverse_ renderListGroupItem tasks
1494: where
1495: maybeSelected :: (Eq a) => Maybe a -> Maybe a -> [Lucid.Attribute]
1496: maybeSelected opt current = [Lucid.selected_ "selected" | opt == current]
1497:
1498: statusFilterOption :: (Monad m) => TaskCore.Status -> Maybe TaskCore.Status -> Lucid.HtmlT m ()
1499: statusFilterOption s current =
1500: let attrs = [Lucid.value_ (tshow s)] <> [Lucid.selected_ "selected" | Just s == current]
1501: in Lucid.option_ attrs (Lucid.toHtml (tshow s))
1502:
1503: priorityFilterOption :: (Monad m) => TaskCore.Priority -> Maybe TaskCore.Priority -> Lucid.HtmlT m ()
1504: priorityFilterOption p current =
1505: let attrs = [Lucid.value_ (tshow p)] <> [Lucid.selected_ "selected" | Just p == current]
1506: in Lucid.option_ attrs (Lucid.toHtml (tshow p))
1507:
1508: instance Lucid.ToHtml TaskDetailPage where
1509: toHtmlRaw = Lucid.toHtml
1510: toHtml (TaskDetailNotFound tid) =
1511: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid Nothing]
1512: in Lucid.doctypehtml_ <| do
1513: pageHead "Task Not Found - Jr"
1514: pageBodyWithCrumbs crumbs <| do
1515: Lucid.div_ [Lucid.class_ "container"] <| do
1516: Lucid.h1_ "Task Not Found"
1517: Lucid.p_ <| do
1518: "The task "
1519: Lucid.code_ (Lucid.toHtml tid)
1520: " could not be found."
1521: toHtml (TaskDetailFound task allTasks activities maybeRetry commits maybeAggMetrics agentEvents now) =
1522: let crumbs = taskBreadcrumbs allTasks task
1523: in Lucid.doctypehtml_ <| do
1524: pageHead (TaskCore.taskId task <> " - Jr")
1525: pageBodyWithCrumbs crumbs <| do
1526: Lucid.div_ [Lucid.class_ "container"] <| do
1527: Lucid.h1_ <| Lucid.toHtml (TaskCore.taskTitle task)
1528:
1529: renderRetryContextBanner (TaskCore.taskId task) maybeRetry
1530:
1531: Lucid.div_ [Lucid.class_ "task-detail"] <| do
1532: Lucid.div_ [Lucid.class_ "task-meta"] <| do
1533: Lucid.div_ [Lucid.class_ "task-meta-primary"] <| do
1534: Lucid.code_ [Lucid.class_ "task-meta-id"] (Lucid.toHtml (TaskCore.taskId task))
1535: metaSep
1536: Lucid.span_ [Lucid.class_ "task-meta-type"] (Lucid.toHtml (tshow (TaskCore.taskType task)))
1537: metaSep
1538: statusBadgeWithForm (TaskCore.taskStatus task) (TaskCore.taskId task)
1539: metaSep
1540: priorityBadgeWithForm (TaskCore.taskPriority task) (TaskCore.taskId task)
1541: case TaskCore.taskComplexity task of
1542: Nothing -> pure ()
1543: Just c -> do
1544: metaSep
1545: complexityBadge c
1546: case TaskCore.taskNamespace task of
1547: Nothing -> pure ()
1548: Just ns -> do
1549: metaSep
1550: Lucid.span_ [Lucid.class_ "task-meta-ns"] (Lucid.toHtml ns)
1551:
1552: Lucid.div_ [Lucid.class_ "task-meta-secondary"] <| do
1553: case TaskCore.taskParent task of
1554: Nothing -> pure ()
1555: Just pid -> do
1556: Lucid.span_ [Lucid.class_ "task-meta-label"] "Parent:"
1557: Lucid.a_ [Lucid.href_ ("/tasks/" <> pid), Lucid.class_ "task-link"] (Lucid.toHtml pid)
1558: metaSep
1559: Lucid.span_ [Lucid.class_ "task-meta-label"] "Created"
1560: renderRelativeTimestamp now (TaskCore.taskCreatedAt task)
1561: metaSep
1562: Lucid.span_ [Lucid.class_ "task-meta-label"] "Updated"
1563: renderRelativeTimestamp now (TaskCore.taskUpdatedAt task)
1564:
1565: let deps = TaskCore.taskDependencies task
1566: unless (null deps) <| do
1567: Lucid.div_ [Lucid.class_ "detail-section"] <| do
1568: Lucid.h3_ "Dependencies"
1569: Lucid.ul_ [Lucid.class_ "dep-list"] <| do
1570: traverse_ renderDependency deps
1571:
1572: when (TaskCore.taskType task == TaskCore.Epic) <| do
1573: for_ maybeAggMetrics (renderAggregatedMetrics allTasks task)
1574:
1575: Lucid.div_ [Lucid.class_ "detail-section"] <| do
1576: Lucid.toHtml (DescriptionViewPartial (TaskCore.taskId task) (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic))
1577:
1578: let children = filter (maybe False (TaskCore.matchesId (TaskCore.taskId task)) <. TaskCore.taskParent) allTasks
1579: unless (null children) <| do
1580: Lucid.div_ [Lucid.class_ "detail-section"] <| do
1581: Lucid.h3_ "Child Tasks"
1582: Lucid.ul_ [Lucid.class_ "child-list"] <| do
1583: traverse_ renderChild children
1584:
1585: unless (null commits) <| do
1586: Lucid.div_ [Lucid.class_ "detail-section"] <| do
1587: Lucid.h3_ "Git Commits"
1588: Lucid.div_ [Lucid.class_ "commit-list"] <| do
1589: traverse_ (renderCommit (TaskCore.taskId task)) commits
1590:
1591: let hasRunningActivity = any (\a -> TaskCore.activityStage a == TaskCore.Running) activities
1592: when hasRunningActivity <| do
1593: let isInProgress = TaskCore.taskStatus task == TaskCore.InProgress
1594: htmxAttrs =
1595: [ Lucid.makeAttribute "hx-get" ("/partials/task/" <> TaskCore.taskId task <> "/metrics"),
1596: Lucid.makeAttribute "hx-trigger" "every 5s",
1597: Lucid.makeAttribute "hx-swap" "innerHTML"
1598: ]
1599: innerAttrs =
1600: [Lucid.id_ "execution-details-inner"]
1601: <> [attr | isInProgress, attr <- htmxAttrs]
1602: Lucid.div_ [Lucid.class_ "execution-section"] <| do
1603: Lucid.h3_ "Execution Details"
1604: Lucid.div_ innerAttrs <| renderExecutionDetails (TaskCore.taskId task) activities maybeRetry
1605:
1606: when (TaskCore.taskStatus task == TaskCore.Review) <| do
1607: Lucid.div_ [Lucid.class_ "review-link-section"] <| do
1608: Lucid.a_
1609: [ Lucid.href_ ("/tasks/" <> TaskCore.taskId task <> "/review"),
1610: Lucid.class_ "review-link-btn"
1611: ]
1612: "Review This Task"
1613:
1614: renderUnifiedTimeline (TaskCore.taskId task) (TaskCore.taskComments task) agentEvents (TaskCore.taskStatus task) now
1615: where
1616: renderDependency :: (Monad m) => TaskCore.Dependency -> Lucid.HtmlT m ()
1617: renderDependency dep =
1618: Lucid.li_ <| do
1619: Lucid.a_ [Lucid.href_ ("/tasks/" <> TaskCore.depId dep), Lucid.class_ "task-link"] (Lucid.toHtml (TaskCore.depId dep))
1620: Lucid.span_ [Lucid.class_ "dep-type"] <| Lucid.toHtml (" [" <> tshow (TaskCore.depType dep) <> "]")
1621:
1622: renderChild :: (Monad m) => TaskCore.Task -> Lucid.HtmlT m ()
1623: renderChild child =
1624: Lucid.li_ <| do
1625: Lucid.a_ [Lucid.href_ ("/tasks/" <> TaskCore.taskId child), Lucid.class_ "task-link"] (Lucid.toHtml (TaskCore.taskId child))
1626: Lucid.span_ [Lucid.class_ "child-title"] <| Lucid.toHtml (" - " <> TaskCore.taskTitle child)
1627: Lucid.span_ [Lucid.class_ "child-status"] <| Lucid.toHtml (" [" <> tshow (TaskCore.taskStatus child) <> "]")
1628:
1629: renderCommit :: (Monad m) => Text -> GitCommit -> Lucid.HtmlT m ()
1630: renderCommit tid c =
1631: Lucid.div_ [Lucid.class_ "commit-item"] <| do
1632: Lucid.div_ [Lucid.class_ "commit-header"] <| do
1633: Lucid.a_
1634: [ Lucid.href_ ("/tasks/" <> tid <> "/diff/" <> commitHash c),
1635: Lucid.class_ "commit-hash"
1636: ]
1637: (Lucid.toHtml (commitShortHash c))
1638: Lucid.span_ [Lucid.class_ "commit-summary"] (Lucid.toHtml (commitSummary c))
1639: Lucid.div_ [Lucid.class_ "commit-meta"] <| do
1640: Lucid.span_ [Lucid.class_ "commit-author"] (Lucid.toHtml (commitAuthor c))
1641: Lucid.span_ [Lucid.class_ "commit-date"] (Lucid.toHtml (commitRelativeDate c))
1642: Lucid.span_ [Lucid.class_ "commit-files"] (Lucid.toHtml (tshow (commitFilesChanged c) <> " files"))
1643:
1644: renderExecutionDetails :: (Monad m) => Text -> [TaskCore.TaskActivity] -> Maybe TaskCore.RetryContext -> Lucid.HtmlT m ()
1645: renderExecutionDetails _ acts retryCtx =
1646: let runningActs = filter (\a -> TaskCore.activityStage a == TaskCore.Running) acts
1647: in if null runningActs
1648: then Lucid.p_ [Lucid.class_ "empty-msg"] "No worker execution data available."
1649: else
1650: Lucid.div_ [Lucid.class_ "execution-details"] <| do
1651: let totalCost = sum [c | act <- runningActs, Just c <- [TaskCore.activityCostCents act]]
1652: totalDuration = sum [calcDurSecs act | act <- runningActs]
1653: attemptCount = length runningActs
1654:
1655: case retryCtx of
1656: Nothing -> pure ()
1657: Just ctx ->
1658: Lucid.div_ [Lucid.class_ "metric-row"] <| do
1659: Lucid.span_ [Lucid.class_ "metric-label"] "Retry Attempt:"
1660: Lucid.span_ [Lucid.class_ "metric-value retry-count"] (Lucid.toHtml (tshow (TaskCore.retryAttempt ctx) <> "/3"))
1661:
1662: when (attemptCount > 1) <| do
1663: Lucid.div_ [Lucid.class_ "metric-row"] <| do
1664: Lucid.span_ [Lucid.class_ "metric-label"] "Total Attempts:"
1665: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (tshow attemptCount))
1666: Lucid.div_ [Lucid.class_ "metric-row"] <| do
1667: Lucid.span_ [Lucid.class_ "metric-label"] "Total Duration:"
1668: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDurSecs totalDuration))
1669: when (totalCost > 0)
1670: <| Lucid.div_ [Lucid.class_ "metric-row"]
1671: <| do
1672: Lucid.span_ [Lucid.class_ "metric-label"] "Total Cost:"
1673: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCostVal totalCost))
1674: Lucid.hr_ [Lucid.class_ "attempts-divider"]
1675:
1676: traverse_ (renderAttempt attemptCount) (zip [1 ..] (reverse runningActs))
1677: where
1678: calcDurSecs :: TaskCore.TaskActivity -> Int
1679: calcDurSecs act = case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of
1680: (Just start, Just end) -> floor (diffUTCTime end start)
1681: _ -> 0
1682:
1683: formatDurSecs :: Int -> Text
1684: formatDurSecs secs
1685: | secs < 60 = tshow secs <> "s"
1686: | secs < 3600 = tshow (secs `div` 60) <> "m " <> tshow (secs `mod` 60) <> "s"
1687: | otherwise = tshow (secs `div` 3600) <> "h " <> tshow ((secs `mod` 3600) `div` 60) <> "m"
1688:
1689: renderAttempt :: (Monad m) => Int -> (Int, TaskCore.TaskActivity) -> Lucid.HtmlT m ()
1690: renderAttempt totalAttempts (attemptNum, act) = do
1691: when (totalAttempts > 1)
1692: <| Lucid.div_ [Lucid.class_ "attempt-header"] (Lucid.toHtml ("Attempt " <> tshow attemptNum :: Text))
1693: case TaskCore.activityThreadUrl act of
1694: Nothing -> pure ()
1695: Just url ->
1696: Lucid.div_ [Lucid.class_ "metric-row"] <| do
1697: Lucid.span_ [Lucid.class_ "metric-label"] "Session:"
1698: Lucid.a_ [Lucid.href_ url, Lucid.target_ "_blank", Lucid.class_ "amp-thread-btn"] "View in Amp ↗"
1699:
1700: case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of
1701: (Just start, Just end) ->
1702: Lucid.div_ [Lucid.class_ "metric-row"] <| do
1703: Lucid.span_ [Lucid.class_ "metric-label"] "Duration:"
1704: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDur start end))
1705: (Just start, Nothing) ->
1706: Lucid.div_ [Lucid.class_ "metric-row"] <| do
1707: Lucid.span_ [Lucid.class_ "metric-label"] "Started:"
1708: Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp now start)
1709: _ -> pure ()
1710:
1711: case TaskCore.activityCostCents act of
1712: Nothing -> pure ()
1713: Just cents ->
1714: Lucid.div_ [Lucid.class_ "metric-row"] <| do
1715: Lucid.span_ [Lucid.class_ "metric-label"] "Cost:"
1716: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCostVal cents))
1717:
1718: Lucid.div_ [Lucid.class_ "metric-row"] <| do
1719: Lucid.span_ [Lucid.class_ "metric-label"] "Timestamp:"
1720: Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp now (TaskCore.activityTimestamp act))
1721:
1722: formatDur :: UTCTime -> UTCTime -> Text
1723: formatDur start end =
1724: let diffSecs = floor (diffUTCTime end start) :: Int
1725: mins = diffSecs `div` 60
1726: secs = diffSecs `mod` 60
1727: in if mins > 0
1728: then tshow mins <> "m " <> tshow secs <> "s"
1729: else tshow secs <> "s"
1730:
1731: formatCostVal :: Int -> Text
1732: formatCostVal cents =
1733: let dollars = fromIntegral cents / 100.0 :: Double
1734: in "$" <> Text.pack (showFFloat (Just 2) dollars "")
1735:
1736: renderAggregatedMetrics :: (Monad m) => [TaskCore.Task] -> TaskCore.Task -> TaskCore.AggregatedMetrics -> Lucid.HtmlT m ()
1737: renderAggregatedMetrics allTasks task metrics =
1738: let descendants = getDescendants allTasks (TaskCore.taskId task)
1739: totalCount = length descendants
1740: costCents = TaskCore.aggTotalCostCents metrics
1741: durationSecs = TaskCore.aggTotalDurationSeconds metrics
1742: completedCount = TaskCore.aggCompletedTasks metrics
1743: tokensUsed = TaskCore.aggTotalTokens metrics
1744: in Lucid.div_ [Lucid.class_ "detail-section aggregated-metrics"] <| do
1745: Lucid.h3_ "Execution Summary"
1746: Lucid.div_ [Lucid.class_ "metrics-grid"] <| do
1747: Lucid.div_ [Lucid.class_ "metric-card"] <| do
1748: Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (tshow completedCount <> "/" <> tshow totalCount))
1749: Lucid.div_ [Lucid.class_ "metric-label"] "Tasks Completed"
1750: Lucid.div_ [Lucid.class_ "metric-card"] <| do
1751: Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCost costCents))
1752: Lucid.div_ [Lucid.class_ "metric-label"] "Total Cost"
1753: Lucid.div_ [Lucid.class_ "metric-card"] <| do
1754: Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDuration durationSecs))
1755: Lucid.div_ [Lucid.class_ "metric-label"] "Total Time"
1756: when (tokensUsed > 0) <| do
1757: Lucid.div_ [Lucid.class_ "metric-card"] <| do
1758: Lucid.div_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatTokens tokensUsed))
1759: Lucid.div_ [Lucid.class_ "metric-label"] "Tokens Used"
1760: where
1761: formatCost :: Int -> Text
1762: formatCost cents =
1763: let dollars = fromIntegral cents / 100.0 :: Double
1764: in "$" <> Text.pack (showFFloat (Just 2) dollars "")
1765:
1766: formatDuration :: Int -> Text
1767: formatDuration secs
1768: | secs < 60 = tshow secs <> "s"
1769: | secs < 3600 =
1770: let mins = secs `div` 60
1771: remSecs = secs `mod` 60
1772: in tshow mins <> "m " <> tshow remSecs <> "s"
1773: | otherwise =
1774: let hrs = secs `div` 3600
1775: mins = (secs `mod` 3600) `div` 60
1776: in tshow hrs <> "h " <> tshow mins <> "m"
1777:
1778: formatTokens :: Int -> Text
1779: formatTokens t
1780: | t < 1000 = tshow t
1781: | t < 1000000 = Text.pack (showFFloat (Just 1) (fromIntegral t / 1000.0 :: Double) "") <> "K"
1782: | otherwise = Text.pack (showFFloat (Just 2) (fromIntegral t / 1000000.0 :: Double) "") <> "M"
1783:
1784: renderRetryContextBanner :: (Monad m) => Text -> Maybe TaskCore.RetryContext -> Lucid.HtmlT m ()
1785: renderRetryContextBanner _ Nothing = pure ()
1786: renderRetryContextBanner tid (Just ctx) =
1787: Lucid.div_ [Lucid.class_ bannerClass] <| do
1788: Lucid.div_ [Lucid.class_ "retry-banner-header"] <| do
1789: Lucid.span_ [Lucid.class_ "retry-icon"] retryIcon
1790: Lucid.span_ [Lucid.class_ "retry-attempt"] (Lucid.toHtml attemptText)
1791: when maxRetriesExceeded
1792: <| Lucid.span_ [Lucid.class_ "retry-warning-badge"] "Needs Human Intervention"
1793:
1794: Lucid.div_ [Lucid.class_ "retry-banner-details"] <| do
1795: Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do
1796: Lucid.span_ [Lucid.class_ "retry-label"] "Failure Reason:"
1797: Lucid.span_ [Lucid.class_ "retry-value"] (Lucid.toHtml (summarizeReason (TaskCore.retryReason ctx)))
1798:
1799: let commit = TaskCore.retryOriginalCommit ctx
1800: unless (Text.null commit) <| do
1801: Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do
1802: Lucid.span_ [Lucid.class_ "retry-label"] "Original Commit:"
1803: Lucid.code_ [Lucid.class_ "retry-commit"] (Lucid.toHtml (Text.take 8 commit))
1804:
1805: let conflicts = TaskCore.retryConflictFiles ctx
1806: unless (null conflicts) <| do
1807: Lucid.div_ [Lucid.class_ "retry-detail-row"] <| do
1808: Lucid.span_ [Lucid.class_ "retry-label"] "Conflict Files:"
1809: Lucid.ul_ [Lucid.class_ "retry-conflict-list"]
1810: <| traverse_ (Lucid.li_ <. Lucid.toHtml) conflicts
1811:
1812: when maxRetriesExceeded <| do
1813: Lucid.div_
1814: [Lucid.class_ "retry-warning-message"]
1815: "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."
1816:
1817: Lucid.p_ [Lucid.class_ "retry-hint"] "Use comments below to provide guidance for retry."
1818:
1819: Lucid.div_ [Lucid.class_ "retry-reset-section"] <| do
1820: Lucid.h4_ "Reset Retries"
1821: Lucid.p_ [Lucid.class_ "notes-help"] "Clear retry context and give task a fresh start:"
1822: Lucid.form_ [Lucid.method_ "POST", Lucid.action_ ("/tasks/" <> tid <> "/reset-retries")] <| do
1823: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "reset-btn"] "Reset Retries"
1824: where
1825: attempt = TaskCore.retryAttempt ctx
1826: maxRetriesExceeded = attempt >= 3
1827: bannerClass = if maxRetriesExceeded then "retry-banner retry-banner-critical" else "retry-banner retry-banner-warning"
1828: retryIcon = if maxRetriesExceeded then "⚠" else "↻"
1829: attemptText = "Attempt " <> tshow attempt <> " of 3"
1830:
1831: summarizeReason :: Text -> Text
1832: summarizeReason reason
1833: | "rejected:" `Text.isPrefixOf` reason = "Rejected: " <> Text.strip (Text.drop 9 reason)
1834: | "Test failure:" `Text.isPrefixOf` reason = "Test failure (see details below)"
1835: | "MERGE CONFLICT" `Text.isPrefixOf` reason = "Merge conflict with concurrent changes"
1836: | otherwise = Text.take 100 reason <> if Text.length reason > 100 then "..." else ""
1837:
1838: instance Lucid.ToHtml TaskReviewPage where
1839: toHtmlRaw = Lucid.toHtml
1840: toHtml (ReviewPageNotFound tid) =
1841: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb "Review" Nothing]
1842: in Lucid.doctypehtml_ <| do
1843: pageHead "Task Not Found - Jr Review"
1844: pageBodyWithCrumbs crumbs <| do
1845: Lucid.div_ [Lucid.class_ "container"] <| do
1846: Lucid.h1_ "Task Not Found"
1847: Lucid.p_ <| do
1848: "The task "
1849: Lucid.code_ (Lucid.toHtml tid)
1850: " could not be found."
1851: toHtml (ReviewPageFound task reviewInfo) =
1852: let tid = TaskCore.taskId task
1853: crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb "Review" Nothing]
1854: in Lucid.doctypehtml_ <| do
1855: pageHead ("Review: " <> TaskCore.taskId task <> " - Jr")
1856: pageBodyWithCrumbs crumbs <| do
1857: Lucid.div_ [Lucid.class_ "container"] <| do
1858: Lucid.h1_ "Review Task"
1859:
1860: Lucid.div_ [Lucid.class_ "task-summary"] <| do
1861: Lucid.div_ [Lucid.class_ "detail-row"] <| do
1862: Lucid.span_ [Lucid.class_ "detail-label"] "ID:"
1863: Lucid.code_ [Lucid.class_ "detail-value"] (Lucid.toHtml (TaskCore.taskId task))
1864: Lucid.div_ [Lucid.class_ "detail-row"] <| do
1865: Lucid.span_ [Lucid.class_ "detail-label"] "Title:"
1866: Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (TaskCore.taskTitle task))
1867: Lucid.div_ [Lucid.class_ "detail-row"] <| do
1868: Lucid.span_ [Lucid.class_ "detail-label"] "Status:"
1869: Lucid.span_ [Lucid.class_ "detail-value"] <| statusBadge (TaskCore.taskStatus task)
1870:
1871: case reviewInfo of
1872: ReviewNoCommit ->
1873: Lucid.div_ [Lucid.class_ "no-commit-msg"] <| do
1874: Lucid.h3_ "No Commit Found"
1875: Lucid.p_ "No commit with this task ID was found in the git history."
1876: Lucid.p_ "The worker may not have completed yet, or the commit message doesn't include the task ID."
1877: ReviewMergeConflict commitSha conflictFiles ->
1878: Lucid.div_ [Lucid.class_ "conflict-warning"] <| do
1879: Lucid.h3_ "Merge Conflict Detected"
1880: Lucid.p_ <| do
1881: "Commit "
1882: Lucid.code_ (Lucid.toHtml (Text.take 8 commitSha))
1883: " cannot be cleanly merged."
1884: Lucid.p_ "Conflicting files:"
1885: Lucid.ul_ <| traverse_ (Lucid.li_ <. Lucid.toHtml) conflictFiles
1886: ReviewReady commitSha diffText -> do
1887: Lucid.div_ [Lucid.class_ "diff-section"] <| do
1888: Lucid.h3_ <| do
1889: "Commit: "
1890: Lucid.code_ (Lucid.toHtml (Text.take 8 commitSha))
1891: Lucid.pre_ [Lucid.class_ "diff-block"] (Lucid.toHtml diffText)
1892:
1893: Lucid.div_ [Lucid.class_ "review-actions"] <| do
1894: Lucid.form_
1895: [ Lucid.method_ "POST",
1896: Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/accept"),
1897: Lucid.class_ "inline-form"
1898: ]
1899: <| do
1900: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "accept-btn"] "Accept"
1901:
1902: Lucid.form_
1903: [ Lucid.method_ "POST",
1904: Lucid.action_ ("/tasks/" <> TaskCore.taskId task <> "/reject"),
1905: Lucid.class_ "reject-form"
1906: ]
1907: <| do
1908: Lucid.textarea_
1909: [ Lucid.name_ "notes",
1910: Lucid.class_ "reject-notes",
1911: Lucid.placeholder_ "Rejection notes (optional)"
1912: ]
1913: ""
1914: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "reject-btn"] "Reject"
1915:
1916: instance Lucid.ToHtml TaskDiffPage where
1917: toHtmlRaw = Lucid.toHtml
1918: toHtml (DiffPageNotFound tid commitHash') =
1919: let shortHash = Text.take 8 commitHash'
1920: crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb ("Diff " <> shortHash) Nothing]
1921: in Lucid.doctypehtml_ <| do
1922: pageHead "Commit Not Found - Jr"
1923: pageBodyWithCrumbs crumbs <| do
1924: Lucid.div_ [Lucid.class_ "container"] <| do
1925: Lucid.h1_ "Commit Not Found"
1926: Lucid.p_ <| do
1927: "Could not find commit "
1928: Lucid.code_ (Lucid.toHtml commitHash')
1929: Lucid.a_ [Lucid.href_ ("/tasks/" <> tid), Lucid.class_ "back-link"] "← Back to task"
1930: toHtml (DiffPageFound tid commitHash' diffOutput) =
1931: let shortHash = Text.take 8 commitHash'
1932: crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Tasks" (Just "/tasks"), Breadcrumb tid (Just ("/tasks/" <> tid)), Breadcrumb ("Diff " <> shortHash) Nothing]
1933: in Lucid.doctypehtml_ <| do
1934: pageHead ("Diff " <> shortHash <> " - Jr")
1935: pageBodyWithCrumbs crumbs <| do
1936: Lucid.div_ [Lucid.class_ "container"] <| do
1937: Lucid.div_ [Lucid.class_ "diff-header"] <| do
1938: Lucid.a_ [Lucid.href_ ("/tasks/" <> tid), Lucid.class_ "back-link"] "← Back to task"
1939: Lucid.h1_ <| do
1940: "Commit "
1941: Lucid.code_ (Lucid.toHtml shortHash)
1942: Lucid.pre_ [Lucid.class_ "diff-block"] (Lucid.toHtml diffOutput)
1943:
1944: instance Lucid.ToHtml StatsPage where
1945: toHtmlRaw = Lucid.toHtml
1946: toHtml (StatsPage stats maybeEpic) =
1947: let crumbs = [Breadcrumb "Jr" (Just "/"), Breadcrumb "Stats" Nothing]
1948: in Lucid.doctypehtml_ <| do
1949: pageHead "Task Statistics - Jr"
1950: pageBodyWithCrumbs crumbs <| do
1951: Lucid.div_ [Lucid.class_ "container"] <| do
1952: Lucid.h1_ <| case maybeEpic of
1953: Nothing -> "Task Statistics"
1954: Just epicId -> Lucid.toHtml ("Statistics for Epic: " <> epicId)
1955:
1956: Lucid.form_ [Lucid.method_ "GET", Lucid.action_ "/stats", Lucid.class_ "filter-form"] <| do
1957: Lucid.div_ [Lucid.class_ "filter-row"] <| do
1958: Lucid.div_ [Lucid.class_ "filter-group"] <| do
1959: Lucid.label_ [Lucid.for_ "epic"] "Epic:"
1960: Lucid.input_
1961: [ Lucid.type_ "text",
1962: Lucid.name_ "epic",
1963: Lucid.id_ "epic",
1964: Lucid.class_ "filter-input",
1965: Lucid.placeholder_ "Epic ID (optional)",
1966: Lucid.value_ (fromMaybe "" maybeEpic)
1967: ]
1968: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "filter-btn"] "Filter"
1969: Lucid.a_ [Lucid.href_ "/stats", Lucid.class_ "clear-btn"] "Clear"
1970:
1971: Lucid.h2_ "By Status"
1972: multiColorProgressBar stats
1973: Lucid.div_ [Lucid.class_ "stats-grid"] <| do
1974: statCard "Open" (TaskCore.openTasks stats) (TaskCore.totalTasks stats)
1975: statCard "In Progress" (TaskCore.inProgressTasks stats) (TaskCore.totalTasks stats)
1976: statCard "Review" (TaskCore.reviewTasks stats) (TaskCore.totalTasks stats)
1977: statCard "Approved" (TaskCore.approvedTasks stats) (TaskCore.totalTasks stats)
1978: statCard "Done" (TaskCore.doneTasks stats) (TaskCore.totalTasks stats)
1979:
1980: Lucid.h2_ "By Priority"
1981: Lucid.div_ [Lucid.class_ "stats-section"] <| do
1982: traverse_ (uncurry renderPriorityRow) (TaskCore.tasksByPriority stats)
1983:
1984: Lucid.h2_ "By Namespace"
1985: Lucid.div_ [Lucid.class_ "stats-section"] <| do
1986: if null (TaskCore.tasksByNamespace stats)
1987: then Lucid.p_ [Lucid.class_ "empty-msg"] "No namespaces found."
1988: else traverse_ (uncurry (renderNamespaceRow (TaskCore.totalTasks stats))) (TaskCore.tasksByNamespace stats)
1989:
1990: Lucid.h2_ "Summary"
1991: Lucid.div_ [Lucid.class_ "summary-section"] <| do
1992: Lucid.div_ [Lucid.class_ "detail-row"] <| do
1993: Lucid.span_ [Lucid.class_ "detail-label"] "Total Tasks:"
1994: Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.totalTasks stats)))
1995: Lucid.div_ [Lucid.class_ "detail-row"] <| do
1996: Lucid.span_ [Lucid.class_ "detail-label"] "Epics:"
1997: Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.totalEpics stats)))
1998: Lucid.div_ [Lucid.class_ "detail-row"] <| do
1999: Lucid.span_ [Lucid.class_ "detail-label"] "Ready:"
2000: Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.readyTasks stats)))
2001: Lucid.div_ [Lucid.class_ "detail-row"] <| do
2002: Lucid.span_ [Lucid.class_ "detail-label"] "Blocked:"
2003: Lucid.span_ [Lucid.class_ "detail-value"] (Lucid.toHtml (tshow (TaskCore.blockedTasks stats)))
2004: where
2005: statCard :: (Monad m) => Text -> Int -> Int -> Lucid.HtmlT m ()
2006: statCard label count total =
2007: let pct = if total == 0 then 0 else (count * 100) `div` total
2008: in Lucid.div_ [Lucid.class_ "stat-card"] <| do
2009: Lucid.div_ [Lucid.class_ "stat-count"] (Lucid.toHtml (tshow count))
2010: Lucid.div_ [Lucid.class_ "stat-label"] (Lucid.toHtml label)
2011: Lucid.div_ [Lucid.class_ "progress-bar"] <| do
2012: Lucid.div_
2013: [ Lucid.class_ "progress-fill",
2014: Lucid.style_ ("width: " <> tshow pct <> "%")
2015: ]
2016: ""
2017:
2018: renderPriorityRow :: (Monad m) => TaskCore.Priority -> Int -> Lucid.HtmlT m ()
2019: renderPriorityRow priority count =
2020: let total = TaskCore.totalTasks stats
2021: pct = if total == 0 then 0 else (count * 100) `div` total
2022: in Lucid.div_ [Lucid.class_ "stats-row"] <| do
2023: Lucid.span_ [Lucid.class_ "stats-label"] (Lucid.toHtml (tshow priority))
2024: Lucid.div_ [Lucid.class_ "stats-bar-container"] <| do
2025: Lucid.div_ [Lucid.class_ "progress-bar"] <| do
2026: Lucid.div_
2027: [ Lucid.class_ "progress-fill",
2028: Lucid.style_ ("width: " <> tshow pct <> "%")
2029: ]
2030: ""
2031: Lucid.span_ [Lucid.class_ "stats-count"] (Lucid.toHtml (tshow count))
2032:
2033: renderNamespaceRow :: (Monad m) => Int -> Text -> Int -> Lucid.HtmlT m ()
2034: renderNamespaceRow total ns count =
2035: let pct = if total == 0 then 0 else (count * 100) `div` total
2036: in Lucid.div_ [Lucid.class_ "stats-row"] <| do
2037: Lucid.span_ [Lucid.class_ "stats-label"] (Lucid.toHtml ns)
2038: Lucid.div_ [Lucid.class_ "stats-bar-container"] <| do
2039: Lucid.div_ [Lucid.class_ "progress-bar"] <| do
2040: Lucid.div_
2041: [ Lucid.class_ "progress-fill",
2042: Lucid.style_ ("width: " <> tshow pct <> "%")
2043: ]
2044: ""
2045: Lucid.span_ [Lucid.class_ "stats-count"] (Lucid.toHtml (tshow count))
2046:
2047: instance Lucid.ToHtml RecentActivityNewPartial where
2048: toHtmlRaw = Lucid.toHtml
2049: toHtml (RecentActivityNewPartial tasks maybeNewestTs) = do
2050: traverse_ renderListGroupItem tasks
2051: case maybeNewestTs of
2052: Nothing -> pure ()
2053: Just ts ->
2054: Lucid.div_
2055: [ Lucid.id_ "recent-activity",
2056: Lucid.makeAttribute "data-newest-ts" (tshow ts),
2057: Lucid.makeAttribute "hx-swap-oob" "attributes:#recent-activity data-newest-ts"
2058: ]
2059: ""
2060:
2061: instance Lucid.ToHtml RecentActivityMorePartial where
2062: toHtmlRaw = Lucid.toHtml
2063: toHtml (RecentActivityMorePartial tasks nextOffset hasMore) = do
2064: traverse_ renderListGroupItem tasks
2065: if hasMore
2066: then
2067: Lucid.button_
2068: [ Lucid.id_ "activity-load-more",
2069: Lucid.class_ "btn btn-secondary load-more-btn",
2070: Lucid.makeAttribute "hx-get" ("/partials/recent-activity-more?offset=" <> tshow nextOffset),
2071: Lucid.makeAttribute "hx-target" "#activity-list",
2072: Lucid.makeAttribute "hx-swap" "beforeend",
2073: Lucid.makeAttribute "hx-swap-oob" "true"
2074: ]
2075: "Load More"
2076: else Lucid.span_ [Lucid.id_ "activity-load-more", Lucid.makeAttribute "hx-swap-oob" "true"] ""
2077:
2078: instance Lucid.ToHtml ReadyCountPartial where
2079: toHtmlRaw = Lucid.toHtml
2080: toHtml (ReadyCountPartial count) =
2081: Lucid.a_ [Lucid.href_ "/ready", Lucid.class_ "ready-link"]
2082: <| Lucid.toHtml ("(" <> tshow count <> " tasks)")
2083:
2084: instance Lucid.ToHtml StatusBadgePartial where
2085: toHtmlRaw = Lucid.toHtml
2086: toHtml (StatusBadgePartial status tid) =
2087: statusBadgeWithForm status tid
2088:
2089: instance Lucid.ToHtml PriorityBadgePartial where
2090: toHtmlRaw = Lucid.toHtml
2091: toHtml (PriorityBadgePartial priority tid) =
2092: priorityBadgeWithForm priority tid
2093:
2094: instance Lucid.ToHtml TaskListPartial where
2095: toHtmlRaw = Lucid.toHtml
2096: toHtml (TaskListPartial tasks) =
2097: if null tasks
2098: then Lucid.p_ [Lucid.class_ "empty-msg"] "No tasks match the current filters."
2099: else Lucid.div_ [Lucid.class_ "list-group"] <| traverse_ renderListGroupItem tasks
2100:
2101: instance Lucid.ToHtml TaskMetricsPartial where
2102: toHtmlRaw = Lucid.toHtml
2103: toHtml (TaskMetricsPartial _tid activities maybeRetry now) =
2104: let runningActs = filter (\a -> TaskCore.activityStage a == TaskCore.Running) activities
2105: in if null runningActs
2106: then Lucid.p_ [Lucid.class_ "empty-msg"] "No worker execution data available."
2107: else
2108: Lucid.div_ [Lucid.class_ "execution-details"] <| do
2109: let totalCost = sum [c | act <- runningActs, Just c <- [TaskCore.activityCostCents act]]
2110: totalDuration = sum [calcDurSecs act | act <- runningActs]
2111: attemptCount = length runningActs
2112:
2113: case maybeRetry of
2114: Nothing -> pure ()
2115: Just ctx ->
2116: Lucid.div_ [Lucid.class_ "metric-row"] <| do
2117: Lucid.span_ [Lucid.class_ "metric-label"] "Retry Attempt:"
2118: Lucid.span_ [Lucid.class_ "metric-value retry-count"] (Lucid.toHtml (tshow (TaskCore.retryAttempt ctx) <> "/3"))
2119:
2120: when (attemptCount > 1) <| do
2121: Lucid.div_ [Lucid.class_ "metric-row"] <| do
2122: Lucid.span_ [Lucid.class_ "metric-label"] "Total Attempts:"
2123: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (tshow attemptCount))
2124: Lucid.div_ [Lucid.class_ "metric-row"] <| do
2125: Lucid.span_ [Lucid.class_ "metric-label"] "Total Duration:"
2126: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDurSecs totalDuration))
2127: when (totalCost > 0)
2128: <| Lucid.div_ [Lucid.class_ "metric-row"]
2129: <| do
2130: Lucid.span_ [Lucid.class_ "metric-label"] "Total Cost:"
2131: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCost totalCost))
2132: Lucid.hr_ [Lucid.class_ "attempts-divider"]
2133:
2134: traverse_ (renderAttempt attemptCount now) (zip [1 ..] (reverse runningActs))
2135: where
2136: calcDurSecs :: TaskCore.TaskActivity -> Int
2137: calcDurSecs act = case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of
2138: (Just start, Just end) -> floor (diffUTCTime end start)
2139: _ -> 0
2140:
2141: formatDurSecs :: Int -> Text
2142: formatDurSecs secs
2143: | secs < 60 = tshow secs <> "s"
2144: | secs < 3600 = tshow (secs `div` 60) <> "m " <> tshow (secs `mod` 60) <> "s"
2145: | otherwise = tshow (secs `div` 3600) <> "h " <> tshow ((secs `mod` 3600) `div` 60) <> "m"
2146:
2147: renderAttempt :: (Monad m) => Int -> UTCTime -> (Int, TaskCore.TaskActivity) -> Lucid.HtmlT m ()
2148: renderAttempt totalAttempts currentTime (attemptNum, act) = do
2149: when (totalAttempts > 1)
2150: <| Lucid.div_ [Lucid.class_ "attempt-header"] (Lucid.toHtml ("Attempt " <> tshow attemptNum :: Text))
2151: case TaskCore.activityThreadUrl act of
2152: Nothing -> pure ()
2153: Just url ->
2154: Lucid.div_ [Lucid.class_ "metric-row"] <| do
2155: Lucid.span_ [Lucid.class_ "metric-label"] "Session:"
2156: Lucid.a_ [Lucid.href_ url, Lucid.target_ "_blank", Lucid.class_ "amp-thread-btn"] "View in Amp ↗"
2157:
2158: case (TaskCore.activityStartedAt act, TaskCore.activityCompletedAt act) of
2159: (Just start, Just end) ->
2160: Lucid.div_ [Lucid.class_ "metric-row"] <| do
2161: Lucid.span_ [Lucid.class_ "metric-label"] "Duration:"
2162: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatDuration start end))
2163: (Just start, Nothing) ->
2164: Lucid.div_ [Lucid.class_ "metric-row"] <| do
2165: Lucid.span_ [Lucid.class_ "metric-label"] "Started:"
2166: Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp currentTime start)
2167: _ -> pure ()
2168:
2169: case TaskCore.activityCostCents act of
2170: Nothing -> pure ()
2171: Just cents ->
2172: Lucid.div_ [Lucid.class_ "metric-row"] <| do
2173: Lucid.span_ [Lucid.class_ "metric-label"] "Cost:"
2174: Lucid.span_ [Lucid.class_ "metric-value"] (Lucid.toHtml (formatCost cents))
2175:
2176: Lucid.div_ [Lucid.class_ "metric-row"] <| do
2177: Lucid.span_ [Lucid.class_ "metric-label"] "Timestamp:"
2178: Lucid.span_ [Lucid.class_ "metric-value"] (renderRelativeTimestamp currentTime (TaskCore.activityTimestamp act))
2179:
2180: formatDuration :: UTCTime -> UTCTime -> Text
2181: formatDuration start end =
2182: let diffSecs = floor (diffUTCTime end start) :: Int
2183: mins = diffSecs `div` 60
2184: secs = diffSecs `mod` 60
2185: in if mins > 0
2186: then tshow mins <> "m " <> tshow secs <> "s"
2187: else tshow secs <> "s"
2188:
2189: formatCost :: Int -> Text
2190: formatCost cents =
2191: let dollars = fromIntegral cents / 100.0 :: Double
2192: in "$" <> Text.pack (showFFloat (Just 2) dollars "")
2193:
2194: instance Lucid.ToHtml DescriptionViewPartial where
2195: toHtmlRaw = Lucid.toHtml
2196: toHtml (DescriptionViewPartial tid desc isEpic) =
2197: Lucid.div_ [Lucid.id_ "description-block", Lucid.class_ "description-block"] <| do
2198: Lucid.div_ [Lucid.class_ "description-header"] <| do
2199: Lucid.h3_ (if isEpic then "Design" else "Description")
2200: Lucid.a_
2201: [ Lucid.href_ "#",
2202: Lucid.class_ "edit-link",
2203: Lucid.makeAttribute "hx-get" ("/tasks/" <> tid <> "/description/edit"),
2204: Lucid.makeAttribute "hx-target" "#description-block",
2205: Lucid.makeAttribute "hx-swap" "outerHTML"
2206: ]
2207: "Edit"
2208: if Text.null desc
2209: then Lucid.p_ [Lucid.class_ "empty-msg"] (if isEpic then "No design document yet." else "No description yet.")
2210: else Lucid.div_ [Lucid.class_ "markdown-content"] (renderMarkdown desc)
2211:
2212: instance Lucid.ToHtml DescriptionEditPartial where
2213: toHtmlRaw = Lucid.toHtml
2214: toHtml (DescriptionEditPartial tid desc isEpic) =
2215: Lucid.div_ [Lucid.id_ "description-block", Lucid.class_ "description-block editing"] <| do
2216: Lucid.div_ [Lucid.class_ "description-header"] <| do
2217: Lucid.h3_ (if isEpic then "Design" else "Description")
2218: Lucid.button_
2219: [ Lucid.type_ "button",
2220: Lucid.class_ "cancel-link",
2221: Lucid.makeAttribute "hx-get" ("/tasks/" <> tid <> "/description/view"),
2222: Lucid.makeAttribute "hx-target" "#description-block",
2223: Lucid.makeAttribute "hx-swap" "outerHTML",
2224: Lucid.makeAttribute "hx-confirm" "Discard changes?"
2225: ]
2226: "Cancel"
2227: Lucid.form_
2228: [ Lucid.makeAttribute "hx-post" ("/tasks/" <> tid <> "/description"),
2229: Lucid.makeAttribute "hx-target" "#description-block",
2230: Lucid.makeAttribute "hx-swap" "outerHTML"
2231: ]
2232: <| do
2233: Lucid.textarea_
2234: [ Lucid.name_ "description",
2235: Lucid.class_ "description-textarea",
2236: Lucid.rows_ (if isEpic then "15" else "10"),
2237: Lucid.placeholder_ (if isEpic then "Enter design in Markdown..." else "Enter description...")
2238: ]
2239: (Lucid.toHtml desc)
2240: Lucid.div_ [Lucid.class_ "form-actions"] <| do
2241: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Save"
2242:
2243: -- | Simple markdown renderer for epic descriptions
2244: -- Supports: headers (#, ##, ###), lists (- or *), code blocks (```), inline code (`)
2245: renderMarkdown :: (Monad m) => Text -> Lucid.HtmlT m ()
2246: renderMarkdown input = renderBlocks (parseBlocks (Text.lines input))
2247:
2248: data MarkdownBlock
2249: = MdHeader Int Text
2250: | MdParagraph [Text]
2251: | MdCodeBlock [Text]
2252: | MdList [Text]
2253: deriving (Show, Eq)
2254:
2255: parseBlocks :: [Text] -> [MarkdownBlock]
2256: parseBlocks [] = []
2257: parseBlocks lns = case lns of
2258: (l : rest)
2259: | "```" `Text.isPrefixOf` l ->
2260: let (codeLines, afterCode) = List.span (not <. Text.isPrefixOf "```") rest
2261: remaining = List.drop 1 afterCode
2262: in MdCodeBlock codeLines : parseBlocks remaining
2263: | "### " `Text.isPrefixOf` l ->
2264: MdHeader 3 (Text.drop 4 l) : parseBlocks rest
2265: | "## " `Text.isPrefixOf` l ->
2266: MdHeader 2 (Text.drop 3 l) : parseBlocks rest
2267: | "# " `Text.isPrefixOf` l ->
2268: MdHeader 1 (Text.drop 2 l) : parseBlocks rest
2269: | isListItem l ->
2270: let (listLines, afterList) = List.span isListItem lns
2271: in MdList (map stripListPrefix listLines) : parseBlocks afterList
2272: | Text.null (Text.strip l) ->
2273: parseBlocks rest
2274: | otherwise ->
2275: let (paraLines, afterPara) = List.span isParagraphLine lns
2276: in MdParagraph paraLines : parseBlocks afterPara
2277: where
2278: isListItem t =
2279: let stripped = Text.stripStart t
2280: in "- " `Text.isPrefixOf` stripped || "* " `Text.isPrefixOf` stripped
2281: stripListPrefix t =
2282: let stripped = Text.stripStart t
2283: in Text.drop 2 stripped
2284: isParagraphLine t =
2285: not (Text.null (Text.strip t))
2286: && not ("```" `Text.isPrefixOf` t)
2287: && not ("#" `Text.isPrefixOf` t)
2288: && not (isListItem t)
2289:
2290: renderBlocks :: (Monad m) => [MarkdownBlock] -> Lucid.HtmlT m ()
2291: renderBlocks = traverse_ renderBlock
2292:
2293: renderBlock :: (Monad m) => MarkdownBlock -> Lucid.HtmlT m ()
2294: renderBlock block = case block of
2295: MdHeader 1 txt -> Lucid.h2_ [Lucid.class_ "md-h1"] (renderInline txt)
2296: MdHeader 2 txt -> Lucid.h3_ [Lucid.class_ "md-h2"] (renderInline txt)
2297: MdHeader 3 txt -> Lucid.h4_ [Lucid.class_ "md-h3"] (renderInline txt)
2298: MdHeader _ txt -> Lucid.h4_ (renderInline txt)
2299: MdParagraph lns -> Lucid.p_ [Lucid.class_ "md-para"] (renderInline (Text.unlines lns))
2300: MdCodeBlock lns -> Lucid.pre_ [Lucid.class_ "md-code"] (Lucid.code_ (Lucid.toHtml (Text.unlines lns)))
2301: MdList items -> Lucid.ul_ [Lucid.class_ "md-list"] (traverse_ renderListItem items)
2302:
2303: renderListItem :: (Monad m) => Text -> Lucid.HtmlT m ()
2304: renderListItem txt = Lucid.li_ (renderInline txt)
2305:
2306: -- | Render inline markdown (backtick code, bold, italic)
2307: renderInline :: (Monad m) => Text -> Lucid.HtmlT m ()
2308: renderInline txt = renderInlineParts (parseInline txt)
2309:
2310: data InlinePart = PlainText Text | InlineCode Text | BoldText Text
2311: deriving (Show, Eq)
2312:
2313: parseInline :: Text -> [InlinePart]
2314: parseInline t
2315: | Text.null t = []
2316: | otherwise = case Text.breakOn "`" t of
2317: (before, rest)
2318: | Text.null rest -> parseBold before
2319: | otherwise ->
2320: let afterTick = Text.drop 1 rest
2321: in case Text.breakOn "`" afterTick of
2322: (code, rest2)
2323: | Text.null rest2 ->
2324: parseBold before ++ [PlainText ("`" <> afterTick)]
2325: | otherwise ->
2326: parseBold before ++ [InlineCode code] ++ parseInline (Text.drop 1 rest2)
2327:
2328: parseBold :: Text -> [InlinePart]
2329: parseBold t
2330: | Text.null t = []
2331: | otherwise = case Text.breakOn "**" t of
2332: (before, rest)
2333: | Text.null rest -> [PlainText before | not (Text.null before)]
2334: | otherwise ->
2335: let afterBold = Text.drop 2 rest
2336: in case Text.breakOn "**" afterBold of
2337: (boldText, rest2)
2338: | Text.null rest2 ->
2339: [PlainText before | not (Text.null before)] ++ [PlainText ("**" <> afterBold)]
2340: | otherwise ->
2341: [PlainText before | not (Text.null before)]
2342: ++ [BoldText boldText]
2343: ++ parseBold (Text.drop 2 rest2)
2344:
2345: renderInlineParts :: (Monad m) => [InlinePart] -> Lucid.HtmlT m ()
2346: renderInlineParts = traverse_ renderInlinePart
2347:
2348: renderInlinePart :: (Monad m) => InlinePart -> Lucid.HtmlT m ()
2349: renderInlinePart part = case part of
2350: PlainText txt -> Lucid.toHtml txt
2351: InlineCode txt -> Lucid.code_ [Lucid.class_ "md-inline-code"] (Lucid.toHtml txt)
2352: BoldText txt -> Lucid.strong_ (Lucid.toHtml txt)
2353:
2354: -- | Comment form for adding new comments
2355: commentForm :: (Monad m) => Text -> Lucid.HtmlT m ()
2356: commentForm tid =
2357: Lucid.form_
2358: [ Lucid.method_ "POST",
2359: Lucid.action_ ("/tasks/" <> tid <> "/comment"),
2360: Lucid.class_ "comment-form"
2361: ]
2362: <| do
2363: Lucid.textarea_
2364: [ Lucid.name_ "comment",
2365: Lucid.placeholder_ "Add a comment...",
2366: Lucid.rows_ "3",
2367: Lucid.class_ "comment-textarea"
2368: ]
2369: ""
2370: Lucid.button_ [Lucid.type_ "submit", Lucid.class_ "btn btn-primary"] "Post Comment"
2371:
2372: -- | Render the LIVE toggle button
2373: renderLiveToggle :: (Monad m) => Lucid.HtmlT m ()
2374: renderLiveToggle =
2375: Lucid.button_
2376: [ Lucid.class_ "timeline-live-toggle",
2377: Lucid.id_ "live-toggle",
2378: Lucid.makeAttribute "onclick" "toggleLiveUpdates()",
2379: Lucid.title_ "Click to pause/resume live updates"
2380: ]
2381: " LIVE"
2382:
2383: -- | JavaScript for toggling live updates
2384: liveToggleJs :: Text
2385: liveToggleJs =
2386: Text.unlines
2387: [ "var liveUpdatesEnabled = true;",
2388: "",
2389: "function toggleLiveUpdates() {",
2390: " liveUpdatesEnabled = !liveUpdatesEnabled;",
2391: " var btn = document.getElementById('live-toggle');",
2392: " if (btn) {",
2393: " btn.classList.toggle('timeline-live-paused', !liveUpdatesEnabled);",
2394: " }",
2395: "}",
2396: "",
2397: "document.body.addEventListener('htmx:beforeRequest', function(evt) {",
2398: " var timeline = document.getElementById('unified-timeline');",
2399: " if (timeline && timeline.contains(evt.target) && !liveUpdatesEnabled) {",
2400: " evt.preventDefault();",
2401: " }",
2402: "});"
2403: ]
2404:
2405: -- | Unified timeline view combining comments, status changes, and agent events
2406: renderUnifiedTimeline :: (Monad m) => Text -> [TaskCore.Comment] -> [TaskCore.StoredEvent] -> TaskCore.Status -> UTCTime -> Lucid.HtmlT m ()
2407: renderUnifiedTimeline tid legacyComments events status now = do
2408: let isInProgress = status == TaskCore.InProgress
2409: pollAttrs =
2410: if isInProgress
2411: then
2412: [ Lucid.makeAttribute "hx-get" ("/partials/task/" <> tid <> "/events"),
2413: Lucid.makeAttribute "hx-trigger" "every 3s",
2414: Lucid.makeAttribute "hx-swap" "innerHTML",
2415: Lucid.makeAttribute "hx-on::before-request" "var log = this.querySelector('.timeline-events'); if(log) this.dataset.scroll = log.scrollTop",
2416: Lucid.makeAttribute "hx-on::after-swap" "var log = this.querySelector('.timeline-events'); if(log && this.dataset.scroll) log.scrollTop = this.dataset.scroll"
2417: ]
2418: else []
2419: Lucid.div_ ([Lucid.class_ "unified-timeline-section", Lucid.id_ "unified-timeline"] <> pollAttrs) <| do
2420: Lucid.h3_ <| do
2421: Lucid.toHtml ("Timeline (" <> tshow (length events + length legacyComments) <> ")")
2422: when isInProgress <| renderLiveToggle
2423:
2424: if null events && null legacyComments
2425: then Lucid.p_ [Lucid.class_ "empty-msg"] "No activity yet."
2426: else do
2427: Lucid.div_ [Lucid.class_ "timeline-events"] <| do
2428: traverse_ (renderTimelineEvent now) events
2429: when isInProgress <| timelineScrollScript
2430:
2431: commentForm tid
2432:
2433: -- | Render a single timeline event with icon, actor label, and timestamp
2434: renderTimelineEvent :: (Monad m) => UTCTime -> TaskCore.StoredEvent -> Lucid.HtmlT m ()
2435: renderTimelineEvent now event =
2436: let eventType = TaskCore.storedEventType event
2437: content = TaskCore.storedEventContent event
2438: timestamp = TaskCore.storedEventTimestamp event
2439: actor = TaskCore.storedEventActor event
2440: eventId = TaskCore.storedEventId event
2441: (icon, label) = eventTypeIconAndLabel eventType
2442: in Lucid.div_
2443: [ Lucid.class_ ("timeline-event timeline-event-" <> eventType),
2444: Lucid.makeAttribute "data-event-id" (tshow eventId)
2445: ]
2446: <| do
2447: case eventType of
2448: "comment" -> renderCommentTimelineEvent content actor timestamp now
2449: "status_change" -> renderStatusChangeEvent content actor timestamp now
2450: "claim" -> renderActivityEvent icon label content actor timestamp now
2451: "running" -> renderActivityEvent icon label content actor timestamp now
2452: "reviewing" -> renderActivityEvent icon label content actor timestamp now
2453: "retrying" -> renderActivityEvent icon label content actor timestamp now
2454: "complete" -> renderActivityEvent icon label content actor timestamp now
2455: "error" -> renderErrorTimelineEvent content actor timestamp now
2456: "Assistant" -> renderAssistantTimelineEvent content actor timestamp now
2457: "ToolCall" -> renderToolCallTimelineEvent content actor timestamp now
2458: "ToolResult" -> renderToolResultTimelineEvent content actor timestamp now
2459: "Cost" -> renderCostTimelineEvent content
2460: "Checkpoint" -> renderCheckpointEvent content actor timestamp now
2461: "Guardrail" -> renderGuardrailEvent content actor timestamp now
2462: _ -> renderGenericEvent eventType content actor timestamp now
2463:
2464: -- | Get icon and label for event type
2465: eventTypeIconAndLabel :: Text -> (Text, Text)
2466: eventTypeIconAndLabel "comment" = ("💬", "Comment")
2467: eventTypeIconAndLabel "status_change" = ("🔄", "Status")
2468: eventTypeIconAndLabel "claim" = ("🤖", "Claimed")
2469: eventTypeIconAndLabel "running" = ("▶️", "Running")
2470: eventTypeIconAndLabel "reviewing" = ("👀", "Reviewing")
2471: eventTypeIconAndLabel "retrying" = ("🔁", "Retrying")
2472: eventTypeIconAndLabel "complete" = ("✅", "Complete")
2473: eventTypeIconAndLabel "error" = ("❌", "Error")
2474: eventTypeIconAndLabel "Assistant" = ("💭", "Thought")
2475: eventTypeIconAndLabel "ToolCall" = ("🔧", "Tool")
2476: eventTypeIconAndLabel "ToolResult" = ("📄", "Result")
2477: eventTypeIconAndLabel "Cost" = ("💰", "Cost")
2478: eventTypeIconAndLabel "Checkpoint" = ("📍", "Checkpoint")
2479: eventTypeIconAndLabel "Guardrail" = ("⚠️", "Guardrail")
2480: eventTypeIconAndLabel t = ("📝", t)
2481:
2482: -- | Render actor label
2483: renderActorLabel :: (Monad m) => TaskCore.CommentAuthor -> Lucid.HtmlT m ()
2484: renderActorLabel actor =
2485: let (cls, label) :: (Text, Text) = case actor of
2486: TaskCore.Human -> ("actor-human", "human")
2487: TaskCore.Junior -> ("actor-junior", "junior")
2488: TaskCore.System -> ("actor-system", "system")
2489: in Lucid.span_ [Lucid.class_ ("actor-label " <> cls)] (Lucid.toHtml ("[" <> label <> "]"))
2490:
2491: -- | Render comment event
2492: renderCommentTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2493: renderCommentTimelineEvent content actor timestamp now =
2494: Lucid.div_ [Lucid.class_ "timeline-comment"] <| do
2495: Lucid.div_ [Lucid.class_ "event-header"] <| do
2496: Lucid.span_ [Lucid.class_ "event-icon"] "💬"
2497: renderActorLabel actor
2498: renderRelativeTimestamp now timestamp
2499: Lucid.div_ [Lucid.class_ "event-content comment-bubble markdown-content"] <| do
2500: renderMarkdown content
2501:
2502: -- | Render status change event
2503: renderStatusChangeEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2504: renderStatusChangeEvent content actor timestamp now =
2505: Lucid.div_ [Lucid.class_ "timeline-status-change"] <| do
2506: Lucid.span_ [Lucid.class_ "event-icon"] "🔄"
2507: renderActorLabel actor
2508: Lucid.span_ [Lucid.class_ "status-change-text"] (Lucid.toHtml (parseStatusChange content))
2509: renderRelativeTimestamp now timestamp
2510:
2511: -- | Parse status change JSON
2512: parseStatusChange :: Text -> Text
2513: parseStatusChange content =
2514: case Aeson.decode (LBS.fromStrict (str content)) of
2515: Just (Aeson.Object obj) ->
2516: let fromStatus = case KeyMap.lookup "from" obj of
2517: Just (Aeson.String s) -> s
2518: _ -> "?"
2519: toStatus = case KeyMap.lookup "to" obj of
2520: Just (Aeson.String s) -> s
2521: _ -> "?"
2522: in fromStatus <> " → " <> toStatus
2523: _ -> content
2524:
2525: -- | Render activity event (claim, running, etc.)
2526: renderActivityEvent :: (Monad m) => Text -> Text -> Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2527: renderActivityEvent icon label content actor timestamp now =
2528: Lucid.div_ [Lucid.class_ "timeline-activity"] <| do
2529: Lucid.span_ [Lucid.class_ "event-icon"] (Lucid.toHtml icon)
2530: Lucid.span_ [Lucid.class_ "event-label"] (Lucid.toHtml label)
2531: renderActorLabel actor
2532: unless (Text.null content) <| Lucid.span_ [Lucid.class_ "activity-detail"] (Lucid.toHtml content)
2533: renderRelativeTimestamp now timestamp
2534:
2535: -- | Render error event
2536: renderErrorTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2537: renderErrorTimelineEvent content actor timestamp now =
2538: Lucid.div_ [Lucid.class_ "timeline-error"] <| do
2539: Lucid.div_ [Lucid.class_ "event-header"] <| do
2540: Lucid.span_ [Lucid.class_ "event-icon"] "❌"
2541: Lucid.span_ [Lucid.class_ "event-label"] "Error"
2542: renderActorLabel actor
2543: renderRelativeTimestamp now timestamp
2544: Lucid.div_ [Lucid.class_ "event-content error-message"] (Lucid.toHtml content)
2545:
2546: -- | Render assistant thought event
2547: renderAssistantTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2548: renderAssistantTimelineEvent content _actor timestamp now =
2549: Lucid.div_ [Lucid.class_ "timeline-thought"] <| do
2550: Lucid.div_ [Lucid.class_ "event-header"] <| do
2551: Lucid.span_ [Lucid.class_ "event-icon"] "💭"
2552: Lucid.span_ [Lucid.class_ "event-label"] "Thought"
2553: renderActorLabel TaskCore.Junior
2554: renderRelativeTimestamp now timestamp
2555: Lucid.div_ [Lucid.class_ "event-content thought-bubble markdown-content"] <| do
2556: let truncated = Text.take 2000 content
2557: isTruncated = Text.length content > 2000
2558: renderMarkdown truncated
2559: when isTruncated <| Lucid.span_ [Lucid.class_ "event-truncated"] "..."
2560:
2561: -- | Render tool call event
2562: renderToolCallTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2563: renderToolCallTimelineEvent content _actor timestamp now =
2564: let (toolName, args) = parseToolCallContent content
2565: summary = formatToolCallSummary toolName args
2566: in Lucid.details_ [Lucid.class_ "timeline-tool-call"] <| do
2567: Lucid.summary_ <| do
2568: Lucid.span_ [Lucid.class_ "event-icon"] "🔧"
2569: Lucid.span_ [Lucid.class_ "tool-name"] (Lucid.toHtml toolName)
2570: Lucid.span_ [Lucid.class_ "tool-summary"] (Lucid.toHtml summary)
2571: renderRelativeTimestamp now timestamp
2572: Lucid.div_ [Lucid.class_ "event-content tool-args"] <| do
2573: renderCollapsibleOutput args
2574:
2575: -- | Render tool result event (collapsed by default)
2576: renderToolResultTimelineEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2577: renderToolResultTimelineEvent content _actor timestamp now =
2578: let lineCount = length (Text.lines content)
2579: in Lucid.details_ [Lucid.class_ "timeline-tool-result"] <| do
2580: Lucid.summary_ <| do
2581: Lucid.span_ [Lucid.class_ "event-icon"] "📄"
2582: Lucid.span_ [Lucid.class_ "event-label"] "Result"
2583: when (lineCount > 1)
2584: <| Lucid.span_ [Lucid.class_ "line-count"] (Lucid.toHtml (tshow lineCount <> " lines"))
2585: renderRelativeTimestamp now timestamp
2586: Lucid.pre_ [Lucid.class_ "event-content tool-output"] (renderDecodedToolResult content)
2587:
2588: -- | Render cost event (inline)
2589: renderCostTimelineEvent :: (Monad m) => Text -> Lucid.HtmlT m ()
2590: renderCostTimelineEvent content =
2591: Lucid.div_ [Lucid.class_ "timeline-cost"] <| do
2592: Lucid.span_ [Lucid.class_ "event-icon"] "💰"
2593: Lucid.span_ [Lucid.class_ "cost-text"] (Lucid.toHtml content)
2594:
2595: -- | Render checkpoint event
2596: renderCheckpointEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2597: renderCheckpointEvent content actor timestamp now =
2598: Lucid.div_ [Lucid.class_ "timeline-checkpoint"] <| do
2599: Lucid.div_ [Lucid.class_ "event-header"] <| do
2600: Lucid.span_ [Lucid.class_ "event-icon"] "📍"
2601: Lucid.span_ [Lucid.class_ "event-label"] "Checkpoint"
2602: renderActorLabel actor
2603: renderRelativeTimestamp now timestamp
2604: Lucid.div_ [Lucid.class_ "event-content checkpoint-content"] (Lucid.toHtml content)
2605:
2606: -- | Render guardrail event
2607: renderGuardrailEvent :: (Monad m) => Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2608: renderGuardrailEvent content actor timestamp now =
2609: Lucid.div_ [Lucid.class_ "timeline-guardrail"] <| do
2610: Lucid.div_ [Lucid.class_ "event-header"] <| do
2611: Lucid.span_ [Lucid.class_ "event-icon"] "⚠️"
2612: Lucid.span_ [Lucid.class_ "event-label"] "Guardrail"
2613: renderActorLabel actor
2614: renderRelativeTimestamp now timestamp
2615: Lucid.div_ [Lucid.class_ "event-content guardrail-content"] (Lucid.toHtml content)
2616:
2617: -- | Render generic/unknown event
2618: renderGenericEvent :: (Monad m) => Text -> Text -> TaskCore.CommentAuthor -> UTCTime -> UTCTime -> Lucid.HtmlT m ()
2619: renderGenericEvent eventType content actor timestamp now =
2620: Lucid.div_ [Lucid.class_ "timeline-generic"] <| do
2621: Lucid.div_ [Lucid.class_ "event-header"] <| do
2622: Lucid.span_ [Lucid.class_ "event-icon"] "📝"
2623: Lucid.span_ [Lucid.class_ "event-label"] (Lucid.toHtml eventType)
2624: renderActorLabel actor
2625: renderRelativeTimestamp now timestamp
2626: unless (Text.null content) <| Lucid.div_ [Lucid.class_ "event-content"] (Lucid.toHtml content)
2627:
2628: parseToolCallContent :: Text -> (Text, Text)
2629: parseToolCallContent content =
2630: case Text.breakOn ":" content of
2631: (name, rest)
2632: | Text.null rest -> (content, "")
2633: | otherwise -> (Text.strip name, Text.strip (Text.drop 1 rest))
2634:
2635: formatToolCallSummary :: Text -> Text -> Text
2636: formatToolCallSummary toolName argsJson =
2637: case Aeson.decode (LBS.fromStrict (str argsJson)) of
2638: Just (Aeson.Object obj) ->
2639: let keyArg = case toolName of
2640: "run_bash" -> KeyMap.lookup "command" obj
2641: "read_file" -> KeyMap.lookup "path" obj
2642: "edit_file" -> KeyMap.lookup "path" obj
2643: "write_file" -> KeyMap.lookup "path" obj
2644: "search_codebase" -> KeyMap.lookup "pattern" obj
2645: "glob_files" -> KeyMap.lookup "pattern" obj
2646: "list_directory" -> KeyMap.lookup "path" obj
2647: _ -> Nothing
2648: in case keyArg of
2649: Just (Aeson.String s) -> "`" <> Text.take 100 s <> "`"
2650: _ -> Text.take 80 argsJson
2651: _ -> Text.take 80 argsJson
2652:
2653: renderCollapsibleOutput :: (Monad m) => Text -> Lucid.HtmlT m ()
2654: renderCollapsibleOutput content =
2655: let lineCount = length (Text.lines content)
2656: in if lineCount > 20
2657: then
2658: Lucid.details_ [Lucid.class_ "output-collapsible"] <| do
2659: Lucid.summary_ (Lucid.toHtml (tshow lineCount <> " lines"))
2660: Lucid.pre_ [Lucid.class_ "tool-output-pre"] (Lucid.toHtml content)
2661: else Lucid.pre_ [Lucid.class_ "tool-output-pre"] (Lucid.toHtml content)
2662:
2663: -- | Decode JSON tool result and render in a user-friendly way
2664: renderDecodedToolResult :: (Monad m) => Text -> Lucid.HtmlT m ()
2665: renderDecodedToolResult content =
2666: case Aeson.decode (LBS.fromStrict (str content)) of
2667: Just (Aeson.Object obj) ->
2668: case KeyMap.lookup "output" obj of
2669: Just (Aeson.String output) -> Lucid.toHtml output
2670: _ -> Lucid.toHtml content -- Fallback to raw if no output field
2671: _ -> Lucid.toHtml content -- Fallback to raw if not JSON
2672:
2673: timelineScrollScript :: (Monad m) => Lucid.HtmlT m ()
2674: timelineScrollScript =
2675: Lucid.script_
2676: [ Lucid.type_ "text/javascript"
2677: ]
2678: ( Text.unlines
2679: [ "(function() {",
2680: " var log = document.querySelector('.timeline-events');",
2681: " if (log) {",
2682: " var isNearBottom = log.scrollHeight - log.scrollTop - log.clientHeight < 100;",
2683: " if (isNearBottom) {",
2684: " log.scrollTop = log.scrollHeight;",
2685: " }",
2686: " }",
2687: "})();"
2688: ]
2689: )
2690:
2691: instance Lucid.ToHtml AgentEventsPartial where
2692: toHtmlRaw = Lucid.toHtml
2693: toHtml (AgentEventsPartial events isInProgress now) = do
2694: Lucid.h3_ <| do
2695: Lucid.toHtml ("Timeline (" <> tshow (length events) <> ")")
2696: when isInProgress <| Lucid.span_ [Lucid.class_ "timeline-live"] " LIVE"
2697: if null events
2698: then Lucid.p_ [Lucid.class_ "empty-msg"] "No activity yet."
2699: else do
2700: Lucid.div_ [Lucid.class_ "timeline-events"] <| do
2701: traverse_ (renderTimelineEvent now) events
2702: timelineScrollScript
2703:
2704: -- | Stream agent events as SSE
2705: streamAgentEvents :: Text -> Text -> IO (SourceIO ByteString)
2706: streamAgentEvents tid sid = do
2707: -- Get existing events first
2708: existingEvents <- TaskCore.getEventsForSession sid
2709: let lastId = if null existingEvents then 0 else maximum (map TaskCore.storedEventId existingEvents)
2710:
2711: -- Convert existing events to SSE format
2712: let existingSSE = map eventToSSE existingEvents
2713:
2714: -- Create a streaming source that sends existing events, then polls for new ones
2715: pure <| Source.fromStepT <| streamEventsStep tid sid lastId existingSSE True
2716:
2717: -- | Step function for streaming events
2718: streamEventsStep :: Text -> Text -> Int -> [ByteString] -> Bool -> Source.StepT IO ByteString
2719: streamEventsStep tid sid lastId buffer sendExisting = case (sendExisting, buffer) of
2720: -- Send buffered existing events first
2721: (True, b : bs) -> Source.Yield b (streamEventsStep tid sid lastId bs True)
2722: (True, []) -> streamEventsStep tid sid lastId [] False
2723: -- Poll for new events
2724: (False, _) ->
2725: Source.Effect <| do
2726: -- Check if task is still in progress
2727: tasks <- TaskCore.loadTasks
2728: let isComplete = case TaskCore.findTask tid tasks of
2729: Nothing -> True
2730: Just task -> TaskCore.taskStatus task /= TaskCore.InProgress
2731:
2732: if isComplete
2733: then do
2734: -- Send complete event and stop
2735: let completeSSE = formatSSE "complete" "{}"
2736: pure <| Source.Yield completeSSE Source.Stop
2737: else do
2738: -- Poll for new events
2739: Concurrent.threadDelay 500000 -- 500ms
2740: newEvents <- TaskCore.getEventsSince sid lastId
2741: if null newEvents
2742: then pure <| streamEventsStep tid sid lastId [] False
2743: else do
2744: let newLastId = maximum (map TaskCore.storedEventId newEvents)
2745: let newSSE = map eventToSSE newEvents
2746: case newSSE of
2747: (e : es) -> pure <| Source.Yield e (streamEventsStep tid sid newLastId es False)
2748: [] -> pure <| streamEventsStep tid sid newLastId [] False
2749:
2750: -- | Convert a StoredEvent to SSE format
2751: eventToSSE :: TaskCore.StoredEvent -> ByteString
2752: eventToSSE event =
2753: let eventType = Text.toLower (TaskCore.storedEventType event)
2754: content = TaskCore.storedEventContent event
2755: jsonData = case eventType of
2756: "assistant" -> Aeson.object ["content" Aeson..= content]
2757: "toolcall" ->
2758: let (tool, args) = parseToolCallContent content
2759: in Aeson.object ["tool" Aeson..= tool, "args" Aeson..= Aeson.object ["data" Aeson..= args]]
2760: "toolresult" ->
2761: Aeson.object ["tool" Aeson..= ("unknown" :: Text), "success" Aeson..= True, "output" Aeson..= content]
2762: "cost" -> Aeson.object ["cost" Aeson..= content]
2763: "error" -> Aeson.object ["error" Aeson..= content]
2764: "complete" -> Aeson.object []
2765: _ -> Aeson.object ["content" Aeson..= content]
2766: in formatSSE eventType (str (Aeson.encode jsonData))
2767:
2768: -- | Format an SSE message
2769: formatSSE :: Text -> ByteString -> ByteString
2770: formatSSE eventType jsonData =
2771: str
2772: <| "event: "
2773: <> eventType
2774: <> "\n"
2775: <> "data: "
2776: <> str jsonData
2777: <> "\n\n"
2778:
2779: api :: Proxy API
2780: api = Proxy
2781:
2782: server :: Server API
2783: server =
2784: homeHandler
2785: :<|> styleHandler
2786: :<|> readyQueueHandler
2787: :<|> blockedHandler
2788: :<|> interventionHandler
2789: :<|> statsHandler
2790: :<|> taskListHandler
2791: :<|> kbHandler
2792: :<|> factCreateHandler
2793: :<|> factDetailHandler
2794: :<|> factEditHandler
2795: :<|> factDeleteHandler
2796: :<|> epicsHandler
2797: :<|> taskDetailHandler
2798: :<|> taskStatusHandler
2799: :<|> taskPriorityHandler
2800: :<|> descriptionViewHandler
2801: :<|> descriptionEditHandler
2802: :<|> descriptionPostHandler
2803: :<|> taskNotesHandler
2804: :<|> taskCommentHandler
2805: :<|> taskReviewHandler
2806: :<|> taskDiffHandler
2807: :<|> taskAcceptHandler
2808: :<|> taskRejectHandler
2809: :<|> taskResetRetriesHandler
2810: :<|> recentActivityNewHandler
2811: :<|> recentActivityMoreHandler
2812: :<|> readyCountHandler
2813: :<|> taskListPartialHandler
2814: :<|> taskMetricsPartialHandler
2815: :<|> agentEventsPartialHandler
2816: :<|> taskEventsStreamHandler
2817: where
2818: styleHandler :: Servant.Handler LazyText.Text
2819: styleHandler = pure Style.css
2820:
2821: homeHandler :: Maybe Text -> Servant.Handler HomePage
2822: homeHandler maybeRangeText = do
2823: now <- liftIO getCurrentTime
2824: let range = parseTimeRange maybeRangeText
2825: maybeStart = getTimeRangeStart range now
2826: allTasks <- liftIO TaskCore.loadTasks
2827: let filteredTasks = case maybeStart of
2828: Nothing -> allTasks
2829: Just start -> [t | t <- allTasks, TaskCore.taskUpdatedAt t >= start]
2830: stats = TaskCore.computeTaskStatsFromList filteredTasks
2831: readyTasks <- liftIO TaskCore.getReadyTasks
2832: allActivities <- liftIO <| concat </ traverse (TaskCore.getActivitiesForTask <. TaskCore.taskId) allTasks
2833: let filteredActivities = case maybeStart of
2834: Nothing -> allActivities
2835: Just start -> [a | a <- allActivities, TaskCore.activityTimestamp a >= start]
2836: globalMetrics = computeMetricsFromActivities filteredTasks filteredActivities
2837: sortedTasks = List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) filteredTasks
2838: recentTasks = take 5 sortedTasks
2839: hasMoreRecent = length filteredTasks > 5
2840: pure (HomePage stats readyTasks recentTasks hasMoreRecent globalMetrics range now)
2841:
2842: readyQueueHandler :: Maybe Text -> Servant.Handler ReadyQueuePage
2843: readyQueueHandler maybeSortText = do
2844: now <- liftIO getCurrentTime
2845: readyTasks <- liftIO TaskCore.getReadyTasks
2846: let sortOrder = parseSortOrder maybeSortText
2847: sortedTasks = sortTasks sortOrder readyTasks
2848: pure (ReadyQueuePage sortedTasks sortOrder now)
2849:
2850: blockedHandler :: Maybe Text -> Servant.Handler BlockedPage
2851: blockedHandler maybeSortText = do
2852: now <- liftIO getCurrentTime
2853: blockedTasks <- liftIO TaskCore.getBlockedTasks
2854: allTasks <- liftIO TaskCore.loadTasks
2855: let sortOrder = parseSortOrder maybeSortText
2856: tasksWithImpact = [(t, TaskCore.getBlockingImpact allTasks t) | t <- blockedTasks]
2857: sorted = List.sortBy (comparing (Down <. snd)) tasksWithImpact
2858: pure (BlockedPage sorted sortOrder now)
2859:
2860: interventionHandler :: Maybe Text -> Servant.Handler InterventionPage
2861: interventionHandler maybeSortText = do
2862: now <- liftIO getCurrentTime
2863: actionItems <- liftIO TaskCore.getHumanActionItems
2864: let sortOrder = parseSortOrder maybeSortText
2865: pure (InterventionPage actionItems sortOrder now)
2866:
2867: statsHandler :: Maybe Text -> Servant.Handler StatsPage
2868: statsHandler maybeEpic = do
2869: let epicId = emptyToNothing maybeEpic
2870: stats <- liftIO <| TaskCore.getTaskStats epicId
2871: pure (StatsPage stats epicId)
2872:
2873: taskListHandler :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Servant.Handler TaskListPage
2874: taskListHandler maybeStatusText maybePriorityText maybeNamespace maybeTypeText maybeSortText = do
2875: now <- liftIO getCurrentTime
2876: allTasks <- liftIO TaskCore.loadTasks
2877: let maybeStatus = parseStatus =<< emptyToNothing maybeStatusText
2878: maybePriority = parsePriority =<< emptyToNothing maybePriorityText
2879: maybeType = parseTaskType =<< emptyToNothing maybeTypeText
2880: filters = TaskFilters maybeStatus maybePriority (emptyToNothing maybeNamespace) maybeType
2881: sortOrder = parseSortOrder maybeSortText
2882: filteredTasks = sortTasks sortOrder (applyFilters filters allTasks)
2883: pure (TaskListPage filteredTasks filters sortOrder now)
2884:
2885: kbHandler :: Servant.Handler KBPage
2886: kbHandler = do
2887: facts <- liftIO Fact.getAllFacts
2888: pure (KBPage facts)
2889:
2890: factCreateHandler :: FactCreateForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
2891: factCreateHandler (FactCreateForm project content filesText confText) = do
2892: let files = filter (not <. Text.null) (Text.splitOn "," (Text.strip filesText))
2893: confidence = fromMaybe 0.8 (readMaybe (Text.unpack confText))
2894: fid <- liftIO (Fact.createFact project content files Nothing confidence)
2895: pure <| addHeader ("/kb/" <> tshow fid) NoContent
2896:
2897: factDetailHandler :: Int -> Servant.Handler FactDetailPage
2898: factDetailHandler fid = do
2899: now <- liftIO getCurrentTime
2900: maybeFact <- liftIO (Fact.getFact fid)
2901: case maybeFact of
2902: Nothing -> pure (FactDetailNotFound fid)
2903: Just fact -> pure (FactDetailFound fact now)
2904:
2905: factEditHandler :: Int -> FactEditForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
2906: factEditHandler fid (FactEditForm content filesText confText) = do
2907: let files = filter (not <. Text.null) (Text.splitOn "," (Text.strip filesText))
2908: confidence = fromMaybe 0.8 (readMaybe (Text.unpack confText))
2909: liftIO (Fact.updateFact fid content files confidence)
2910: pure <| addHeader ("/kb/" <> tshow fid) NoContent
2911:
2912: factDeleteHandler :: Int -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
2913: factDeleteHandler fid = do
2914: liftIO (Fact.deleteFact fid)
2915: pure <| addHeader "/kb" NoContent
2916:
2917: epicsHandler :: Maybe Text -> Servant.Handler EpicsPage
2918: epicsHandler maybeSortText = do
2919: allTasks <- liftIO TaskCore.loadTasks
2920: let epicTasks = filter (\t -> TaskCore.taskType t == TaskCore.Epic) allTasks
2921: sortOrder = parseSortOrder maybeSortText
2922: sortedEpics = sortTasks sortOrder epicTasks
2923: pure (EpicsPage sortedEpics allTasks sortOrder)
2924:
2925: parseStatus :: Text -> Maybe TaskCore.Status
2926: parseStatus = readMaybe <. Text.unpack
2927:
2928: parsePriority :: Text -> Maybe TaskCore.Priority
2929: parsePriority = readMaybe <. Text.unpack
2930:
2931: parseTaskType :: Text -> Maybe TaskCore.TaskType
2932: parseTaskType = readMaybe <. Text.unpack
2933:
2934: emptyToNothing :: Maybe Text -> Maybe Text
2935: emptyToNothing (Just t) | Text.null (Text.strip t) = Nothing
2936: emptyToNothing x = x
2937:
2938: applyFilters :: TaskFilters -> [TaskCore.Task] -> [TaskCore.Task]
2939: applyFilters filters = filter matchesAllFilters
2940: where
2941: matchesAllFilters task =
2942: matchesStatus task
2943: && matchesPriority task
2944: && matchesNamespace task
2945: && matchesType task
2946:
2947: matchesStatus task = case filterStatus filters of
2948: Nothing -> True
2949: Just s -> TaskCore.taskStatus task == s
2950:
2951: matchesPriority task = case filterPriority filters of
2952: Nothing -> True
2953: Just p -> TaskCore.taskPriority task == p
2954:
2955: matchesNamespace task = case filterNamespace filters of
2956: Nothing -> True
2957: Just ns -> case TaskCore.taskNamespace task of
2958: Nothing -> False
2959: Just taskNs -> ns `Text.isPrefixOf` taskNs
2960:
2961: matchesType task = case filterType filters of
2962: Nothing -> True
2963: Just t -> TaskCore.taskType task == t
2964:
2965: taskDetailHandler :: Text -> Servant.Handler TaskDetailPage
2966: taskDetailHandler tid = do
2967: now <- liftIO getCurrentTime
2968: tasks <- liftIO TaskCore.loadTasks
2969: case TaskCore.findTask tid tasks of
2970: Nothing -> pure (TaskDetailNotFound tid)
2971: Just task -> do
2972: activities <- liftIO (TaskCore.getActivitiesForTask tid)
2973: retryCtx <- liftIO (TaskCore.getRetryContext tid)
2974: commits <- liftIO (getCommitsForTask tid)
2975: aggMetrics <-
2976: if TaskCore.taskType task == TaskCore.Epic
2977: then Just </ liftIO (TaskCore.getAggregatedMetrics tid)
2978: else pure Nothing
2979: agentEvents <- liftIO (TaskCore.getAllEventsForTask tid)
2980: pure (TaskDetailFound task tasks activities retryCtx commits aggMetrics agentEvents now)
2981:
2982: taskStatusHandler :: Text -> StatusForm -> Servant.Handler StatusBadgePartial
2983: taskStatusHandler tid (StatusForm newStatus) = do
2984: liftIO <| TaskCore.updateTaskStatusWithActor tid newStatus [] TaskCore.Human
2985: pure (StatusBadgePartial newStatus tid)
2986:
2987: taskPriorityHandler :: Text -> PriorityForm -> Servant.Handler PriorityBadgePartial
2988: taskPriorityHandler tid (PriorityForm newPriority) = do
2989: _ <- liftIO <| TaskCore.editTask tid (\t -> t {TaskCore.taskPriority = newPriority})
2990: pure (PriorityBadgePartial newPriority tid)
2991:
2992: descriptionViewHandler :: Text -> Servant.Handler DescriptionViewPartial
2993: descriptionViewHandler tid = do
2994: tasks <- liftIO TaskCore.loadTasks
2995: case TaskCore.findTask tid tasks of
2996: Nothing -> throwError err404
2997: Just task -> pure (DescriptionViewPartial tid (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic))
2998:
2999: descriptionEditHandler :: Text -> Servant.Handler DescriptionEditPartial
3000: descriptionEditHandler tid = do
3001: tasks <- liftIO TaskCore.loadTasks
3002: case TaskCore.findTask tid tasks of
3003: Nothing -> throwError err404
3004: Just task -> pure (DescriptionEditPartial tid (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic))
3005:
3006: descriptionPostHandler :: Text -> DescriptionForm -> Servant.Handler DescriptionViewPartial
3007: descriptionPostHandler tid (DescriptionForm desc) = do
3008: let descText = Text.strip desc
3009: _ <- liftIO <| TaskCore.editTask tid (\t -> t {TaskCore.taskDescription = descText})
3010: tasks <- liftIO TaskCore.loadTasks
3011: case TaskCore.findTask tid tasks of
3012: Nothing -> throwError err404
3013: Just task -> pure (DescriptionViewPartial tid (TaskCore.taskDescription task) (TaskCore.taskType task == TaskCore.Epic))
3014:
3015: taskNotesHandler :: Text -> NotesForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
3016: taskNotesHandler tid (NotesForm notes) = do
3017: liftIO <| TaskCore.updateRetryNotes tid notes
3018: pure <| addHeader ("/tasks/" <> tid) NoContent
3019:
3020: taskCommentHandler :: Text -> CommentForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
3021: taskCommentHandler tid (CommentForm commentText) = do
3022: _ <- liftIO (TaskCore.addComment tid commentText TaskCore.Human)
3023: pure <| addHeader ("/tasks/" <> tid) NoContent
3024:
3025: taskReviewHandler :: Text -> Servant.Handler TaskReviewPage
3026: taskReviewHandler tid = do
3027: tasks <- liftIO TaskCore.loadTasks
3028: case TaskCore.findTask tid tasks of
3029: Nothing -> pure (ReviewPageNotFound tid)
3030: Just task -> do
3031: reviewInfo <- liftIO <| getReviewInfo tid
3032: pure (ReviewPageFound task reviewInfo)
3033:
3034: taskDiffHandler :: Text -> Text -> Servant.Handler TaskDiffPage
3035: taskDiffHandler tid commitSha = do
3036: diffOutput <- liftIO <| getDiffForCommit commitSha
3037: case diffOutput of
3038: Nothing -> pure (DiffPageNotFound tid commitSha)
3039: Just output -> pure (DiffPageFound tid commitSha output)
3040:
3041: taskAcceptHandler :: Text -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
3042: taskAcceptHandler tid = do
3043: liftIO <| do
3044: TaskCore.clearRetryContext tid
3045: TaskCore.updateTaskStatusWithActor tid TaskCore.Done [] TaskCore.Human
3046: pure <| addHeader ("/tasks/" <> tid) NoContent
3047:
3048: taskRejectHandler :: Text -> RejectForm -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
3049: taskRejectHandler tid (RejectForm maybeNotes) = do
3050: liftIO <| do
3051: maybeCommit <- findCommitForTask tid
3052: let commitSha = fromMaybe "" maybeCommit
3053: maybeCtx <- TaskCore.getRetryContext tid
3054: let attempt = maybe 1 (\ctx -> TaskCore.retryAttempt ctx + 1) maybeCtx
3055: let currentReason = "attempt " <> tshow attempt <> ": rejected: " <> fromMaybe "(no notes)" maybeNotes
3056: let accumulatedReason = case maybeCtx of
3057: Nothing -> currentReason
3058: Just ctx -> TaskCore.retryReason ctx <> "\n" <> currentReason
3059: TaskCore.setRetryContext
3060: TaskCore.RetryContext
3061: { TaskCore.retryTaskId = tid,
3062: TaskCore.retryOriginalCommit = commitSha,
3063: TaskCore.retryConflictFiles = [],
3064: TaskCore.retryAttempt = attempt,
3065: TaskCore.retryReason = accumulatedReason,
3066: TaskCore.retryNotes = maybeCtx +> TaskCore.retryNotes
3067: }
3068: TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.Human
3069: pure <| addHeader ("/tasks/" <> tid) NoContent
3070:
3071: taskResetRetriesHandler :: Text -> Servant.Handler (Headers '[Header "Location" Text] NoContent)
3072: taskResetRetriesHandler tid = do
3073: liftIO <| do
3074: TaskCore.clearRetryContext tid
3075: TaskCore.updateTaskStatusWithActor tid TaskCore.Open [] TaskCore.Human
3076: pure <| addHeader ("/tasks/" <> tid) NoContent
3077:
3078: recentActivityNewHandler :: Maybe Int -> Servant.Handler RecentActivityNewPartial
3079: recentActivityNewHandler maybeSince = do
3080: allTasks <- liftIO TaskCore.loadTasks
3081: let sinceTime = maybe (posixSecondsToUTCTime 0) (posixSecondsToUTCTime <. fromIntegral) maybeSince
3082: sortedTasks = List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) allTasks
3083: newTasks = filter (\t -> TaskCore.taskUpdatedAt t > sinceTime) sortedTasks
3084: newestTs = maybe maybeSince (Just <. taskToUnixTs) (head newTasks)
3085: pure (RecentActivityNewPartial newTasks newestTs)
3086:
3087: recentActivityMoreHandler :: Maybe Int -> Servant.Handler RecentActivityMorePartial
3088: recentActivityMoreHandler maybeOffset = do
3089: allTasks <- liftIO TaskCore.loadTasks
3090: let offset = fromMaybe 0 maybeOffset
3091: pageSize = 5
3092: sortedTasks = List.sortBy (flip compare `on` TaskCore.taskUpdatedAt) allTasks
3093: pageTasks = take pageSize <| drop offset sortedTasks
3094: hasMore = length sortedTasks > offset + pageSize
3095: nextOffset = offset + pageSize
3096: pure (RecentActivityMorePartial pageTasks nextOffset hasMore)
3097:
3098: readyCountHandler :: Servant.Handler ReadyCountPartial
3099: readyCountHandler = do
3100: readyTasks <- liftIO TaskCore.getReadyTasks
3101: pure (ReadyCountPartial (length readyTasks))
3102:
3103: taskListPartialHandler :: Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Servant.Handler TaskListPartial
3104: taskListPartialHandler maybeStatusText maybePriorityText maybeNamespace maybeTypeText maybeSortText = do
3105: allTasks <- liftIO TaskCore.loadTasks
3106: let maybeStatus = parseStatus =<< emptyToNothing maybeStatusText
3107: maybePriority = parsePriority =<< emptyToNothing maybePriorityText
3108: maybeType = parseTaskType =<< emptyToNothing maybeTypeText
3109: filters = TaskFilters maybeStatus maybePriority (emptyToNothing maybeNamespace) maybeType
3110: sortOrder = parseSortOrder maybeSortText
3111: filteredTasks = sortTasks sortOrder (applyFilters filters allTasks)
3112: pure (TaskListPartial filteredTasks)
3113:
3114: taskMetricsPartialHandler :: Text -> Servant.Handler TaskMetricsPartial
3115: taskMetricsPartialHandler tid = do
3116: now <- liftIO getCurrentTime
3117: activities <- liftIO (TaskCore.getActivitiesForTask tid)
3118: maybeRetry <- liftIO (TaskCore.getRetryContext tid)
3119: pure (TaskMetricsPartial tid activities maybeRetry now)
3120:
3121: agentEventsPartialHandler :: Text -> Maybe Int -> Servant.Handler AgentEventsPartial
3122: agentEventsPartialHandler tid _maybeSince = do
3123: now <- liftIO getCurrentTime
3124: events <- liftIO (TaskCore.getAllEventsForTask tid)
3125: tasks <- liftIO TaskCore.loadTasks
3126: let isInProgress = case TaskCore.findTask tid tasks of
3127: Nothing -> False
3128: Just task -> TaskCore.taskStatus task == TaskCore.InProgress
3129: pure (AgentEventsPartial events isInProgress now)
3130:
3131: taskEventsStreamHandler :: Text -> Servant.Handler (SourceIO ByteString)
3132: taskEventsStreamHandler tid = do
3133: maybeSession <- liftIO (TaskCore.getLatestSessionForTask tid)
3134: case maybeSession of
3135: Nothing -> pure (Source.source [])
3136: Just sid -> liftIO (streamAgentEvents tid sid)
3137:
3138: taskToUnixTs :: TaskCore.Task -> Int
3139: taskToUnixTs t = round (utcTimeToPOSIXSeconds (TaskCore.taskUpdatedAt t))
3140:
3141: getReviewInfo :: Text -> IO ReviewInfo
3142: getReviewInfo tid = do
3143: maybeCommit <- findCommitForTask tid
3144: case maybeCommit of
3145: Nothing -> pure ReviewNoCommit
3146: Just commitSha -> do
3147: conflictResult <- checkMergeConflict (Text.unpack commitSha)
3148: case conflictResult of
3149: Just conflictFiles -> pure (ReviewMergeConflict commitSha conflictFiles)
3150: Nothing -> do
3151: (_, diffOut, _) <-
3152: Process.readProcessWithExitCode
3153: "git"
3154: ["show", Text.unpack commitSha]
3155: ""
3156: pure (ReviewReady commitSha (Text.pack diffOut))
3157:
3158: getDiffForCommit :: Text -> IO (Maybe Text)
3159: getDiffForCommit commitSha = do
3160: (code, diffOut, _) <-
3161: Process.readProcessWithExitCode
3162: "git"
3163: ["show", Text.unpack commitSha]
3164: ""
3165: case code of
3166: Exit.ExitSuccess -> pure (Just (Text.pack diffOut))
3167: Exit.ExitFailure _ -> pure Nothing
3168:
3169: findCommitForTask :: Text -> IO (Maybe Text)
3170: findCommitForTask tid = do
3171: let grepArg = "--grep=" <> Text.unpack tid
3172: (code, shaOut, _) <-
3173: Process.readProcessWithExitCode
3174: "git"
3175: ["log", "--pretty=format:%H", "-n", "1", grepArg]
3176: ""
3177: if code /= Exit.ExitSuccess || null shaOut
3178: then pure Nothing
3179: else case List.lines shaOut of
3180: (x : _) -> pure (Just (Text.pack x))
3181: [] -> pure Nothing
3182:
3183: getCommitsForTask :: Text -> IO [GitCommit]
3184: getCommitsForTask tid = do
3185: let grepArg = "--grep=Task-Id: " <> Text.unpack tid
3186: (code, out, _) <-
3187: Process.readProcessWithExitCode
3188: "git"
3189: ["log", "--pretty=format:%H|%h|%s|%an|%ar", grepArg]
3190: ""
3191: if code /= Exit.ExitSuccess || null out
3192: then pure []
3193: else do
3194: let commitLines = filter (not <. null) (List.lines out)
3195: traverse parseCommitLine commitLines
3196: where
3197: parseCommitLine :: String -> IO GitCommit
3198: parseCommitLine line =
3199: case Text.splitOn "|" (Text.pack line) of
3200: [sha, shortSha, summary, author, relDate] -> do
3201: filesCount <- getFilesChangedCount (Text.unpack sha)
3202: pure
3203: GitCommit
3204: { commitHash = sha,
3205: commitShortHash = shortSha,
3206: commitSummary = summary,
3207: commitAuthor = author,
3208: commitRelativeDate = relDate,
3209: commitFilesChanged = filesCount
3210: }
3211: _ ->
3212: pure
3213: GitCommit
3214: { commitHash = Text.pack line,
3215: commitShortHash = Text.take 7 (Text.pack line),
3216: commitSummary = "(parse error)",
3217: commitAuthor = "",
3218: commitRelativeDate = "",
3219: commitFilesChanged = 0
3220: }
3221:
3222: getFilesChangedCount :: String -> IO Int
3223: getFilesChangedCount sha = do
3224: (code', out', _) <-
3225: Process.readProcessWithExitCode
3226: "git"
3227: ["show", "--stat", "--format=", sha]
3228: ""
3229: pure
3230: <| if code' /= Exit.ExitSuccess
3231: then 0
3232: else
3233: let statLines = filter (not <. null) (List.lines out')
3234: in max 0 (length statLines - 1)
3235:
3236: checkMergeConflict :: String -> IO (Maybe [Text])
3237: checkMergeConflict commitSha = do
3238: (_, origHead, _) <- Process.readProcessWithExitCode "git" ["rev-parse", "HEAD"] ""
3239:
3240: (cpCode, _, cpErr) <-
3241: Process.readProcessWithExitCode
3242: "git"
3243: ["cherry-pick", "--no-commit", commitSha]
3244: ""
3245:
3246: _ <- Process.readProcessWithExitCode "git" ["cherry-pick", "--abort"] ""
3247: _ <- Process.readProcessWithExitCode "git" ["reset", "--hard", List.head (List.lines origHead)] ""
3248:
3249: case cpCode of
3250: Exit.ExitSuccess -> pure Nothing
3251: Exit.ExitFailure _ -> do
3252: let errLines = Text.lines (Text.pack cpErr)
3253: conflictLines = filter (Text.isPrefixOf "CONFLICT") errLines
3254: files = mapMaybe extractConflictFile conflictLines
3255: pure (Just (if null files then ["(unknown files)"] else files))
3256:
3257: extractConflictFile :: Text -> Maybe Text
3258: extractConflictFile line =
3259: case Text.breakOn "Merge conflict in " line of
3260: (_, rest)
3261: | not (Text.null rest) -> Just (Text.strip (Text.drop 18 rest))
3262: _ -> case Text.breakOn "in " line of
3263: (_, rest)
3264: | not (Text.null rest) -> Just (Text.strip (Text.drop 3 rest))
3265: _ -> Nothing
3266:
3267: app :: Application
3268: app = serve api server
3269:
3270: run :: Warp.Port -> IO ()
3271: run port = do
3272: TaskCore.initTaskDb
3273: putText <| "Starting Jr web server on port " <> tshow port
3274: Warp.run port app
Now I can see the timeline rendering code. Let me search for how Cost events are currently rendered and understand the task better:
renderCostTimelineEvent in /home/ben/omni/Omni/Jr/Web.hs:2459: "Cost" -> renderCostTimelineEvent content /home/ben/omni/Omni/Jr/Web.hs:2589:renderCostTimelineEvent :: (Monad m) => Text -> Lucid.HtmlT m () /home/ben/omni/Omni/Jr/Web.hs:2590:renderCostTimelineEvent content =
Let me check the test file:
cd /home/ben/omni && find . -name "*.hs" -type f | xargs grep -l "test.*timeline\|timeline.*test" 2>/dev/null | head -5Now let me understand what needs to be done based on the task description:
1. Remove individual Cost events from the timeline (filter out event_type='Cost') 2. Add a live-updating cost/token summary near the Timeline header 3. Remove the Execution Details section entirely
Let me start by implementing the changes to the timeline:
Omni/Jr/Web.hsLet me check the exact format in the file:
Omni/Jr/Web.hs @2433-24632433: -- | Render a single timeline event with icon, actor label, and timestamp
2434: renderTimelineEvent :: (Monad m) => UTCTime -> TaskCore.StoredEvent -> Lucid.HtmlT m ()
2435: renderTimelineEvent now event =
2436: let eventType = TaskCore.storedEventType event
2437: content = TaskCore.storedEventContent event
2438: timestamp = TaskCore.storedEventTimestamp event
2439: actor = TaskCore.storedEventActor event
2440: eventId = TaskCore.storedEventId event
2441: (icon, label) = eventTypeIconAndLabel eventType
2442: in Lucid.div_
2443: [ Lucid.class_ ("timeline-event timeline-event-" <> eventType),
2444: Lucid.makeAttribute "data-event-id" (tshow eventId)
2445: ]
2446: <| do
2447: case eventType of
2448: "comment" -> renderCommentTimelineEvent content actor timestamp now
2449: "status_change" -> renderStatusChangeEvent content actor timestamp now
2450: "claim" -> renderActivityEvent icon label content actor timestamp now
2451: "running" -> renderActivityEvent icon label content actor timestamp now
2452: "reviewing" -> renderActivityEvent icon label content actor timestamp now
2453: "retrying" -> renderActivityEvent icon label content actor timestamp now
2454: "complete" -> renderActivityEvent icon label content actor timestamp now
2455: "error" -> renderErrorTimelineEvent content actor timestamp now
2456: "Assistant" -> renderAssistantTimelineEvent content actor timestamp now
2457: "ToolCall" -> renderToolCallTimelineEvent content actor timestamp now
2458: "ToolResult" -> renderToolResultTimelineEvent content actor timestamp now
2459: "Cost" -> renderCostTimelineEvent content
2460: "Checkpoint" -> renderCheckpointEvent content actor timestamp now
2461: "Guardrail" -> renderGuardrailEvent content actor timestamp now
2462: _ -> renderGenericEvent eventType content actor timestamp now
2463:
Now let me edit it correctly:
Omni/Jr/Web.hsLet me try a smaller change:
Omni/Jr/Web.hsLet me check the exact whitespace:
cd /home/ben/omni && sed -n '2459p' Omni/Jr/Web.hs | cat -AOmni/Jr/Web.hsGood! Now I need to: 1. Aggregate cost data from events and display it in the header 2. Remove the renderCostTimelineEvent function (or leave it for potential reuse) 3. Modify the renderUnifiedTimeline to show the cost summary in the header 4. Remove the Execution Details section
Let me first look at how cost events are structured:
StoredEvent.*Cost\|event_type.*Cost in Let me look at the Task Core to understand the event structure better:
cd /home/ben/omni && find Omni/Task -name "*.hs" | head -5Omni/Task/Core.hs Omni/Task/MigrationTest.hs Omni/Task/RaceTest.hs
cd /home/ben/omni && grep -n "StoredEvent\|Event.*Cost" Omni/Task/Core.hs | head -201398:-- | Convert StoredEvent to TaskActivity for backward compatibility 1399:storedEventToActivity :: StoredEvent -> TaskActivity 1677:data StoredEvent = StoredEvent 1688:instance ToJSON StoredEvent 1690:instance FromJSON StoredEvent 1692:instance SQL.FromRow StoredEvent where 1694: StoredEvent 1719:getEventsForTask :: Text -> IO [StoredEvent] 1727:getEventsForSession :: Text -> IO [StoredEvent] 1763:getEventsSince :: Text -> Int -> IO [StoredEvent] 1778:getCheckpointsForTask :: Text -> IO [StoredEvent] 1796:getCommentsForTask :: Text -> IO [StoredEvent] 1806:storedEventToComment :: StoredEvent -> Comment 1816:getAllEventsForTask :: Text -> IO [StoredEvent]
Let me look at the StoredEvent structure more closely:
Omni/Task/Core.hs @1677-17101677: data StoredEvent = StoredEvent
1678: { storedEventId :: Int,
1679: storedEventTaskId :: Text,
1680: storedEventSessionId :: Text,
1681: storedEventTimestamp :: UTCTime,
1682: storedEventType :: Text,
1683: storedEventContent :: Text,
1684: storedEventActor :: CommentAuthor
1685: }
1686: deriving (Show, Eq, Generic)
1687:
1688: instance ToJSON StoredEvent
1689:
1690: instance FromJSON StoredEvent
1691:
1692: instance SQL.FromRow StoredEvent where
1693: fromRow =
1694: StoredEvent
1695: </ SQL.field
1696: <*> SQL.field
1697: <*> SQL.field
1698: <*> SQL.field
1699: <*> SQL.field
1700: <*> SQL.field
1701: <*> SQL.field
1702:
1703: -- | Generate a new session ID (timestamp-based for simplicity)
1704: generateSessionId :: IO Text
1705: generateSessionId = do
1706: now <- getCurrentTime
1707: pure <| "s-" <> T.pack (show now)
1708:
1709: -- | Insert an agent event with actor
1710: insertAgentEvent :: Text -> Text -> Text -> Text -> CommentAuthor -> IO ()
Now I understand. The Cost events have a storedEventContent that likely contains JSON data. Let me now create a function to aggregate cost/token data from events and modify the timeline header:
Omni/Jr/Web.hs @2405-24322405: -- | Unified timeline view combining comments, status changes, and agent events
2406: renderUnifiedTimeline :: (Monad m) => Text -> [TaskCore.Comment] -> [TaskCore.StoredEvent] -> TaskCore.Status -> UTCTime -> Lucid.HtmlT m ()
2407: renderUnifiedTimeline tid legacyComments events status now = do
2408: let isInProgress = status == TaskCore.InProgress
2409: pollAttrs =
2410: if isInProgress
2411: then
2412: [ Lucid.makeAttribute "hx-get" ("/partials/task/" <> tid <> "/events"),
2413: Lucid.makeAttribute "hx-trigger" "every 3s",
2414: Lucid.makeAttribute "hx-swap" "innerHTML",
2415: Lucid.makeAttribute "hx-on::before-request" "var log = this.querySelector('.timeline-events'); if(log) this.dataset.scroll = log.scrollTop",
2416: Lucid.makeAttribute "hx-on::after-swap" "var log = this.querySelector('.timeline-events'); if(log && this.dataset.scroll) log.scrollTop = this.dataset.scroll"
2417: ]
2418: else []
2419: Lucid.div_ ([Lucid.class_ "unified-timeline-section", Lucid.id_ "unified-timeline"] <> pollAttrs) <| do
2420: Lucid.h3_ <| do
2421: Lucid.toHtml ("Timeline (" <> tshow (length events + length legacyComments) <> ")")
2422: when isInProgress <| renderLiveToggle
2423:
2424: if null events && null legacyComments
2425: then Lucid.p_ [Lucid.class_ "empty-msg"] "No activity yet."
2426: else do
2427: Lucid.div_ [Lucid.class_ "timeline-events"] <| do
2428: traverse_ (renderTimelineEvent now) events
2429: when isInProgress <| timelineScrollScript
2430:
2431: commentForm tid
2432:
Now I need to add a function to aggregate cost and token data from events, and then display it in the header. Let me add this function:
Omni/Jr/Web.hsNow I need to add the missing imports for foldl':
Omni/Jr/Web.hs @1-451: {-# LANGUAGE DataKinds #-}
2: {-# LANGUAGE OverloadedStrings #-}
3: {-# LANGUAGE TypeOperators #-}
4: {-# LANGUAGE NoImplicitPrelude #-}
5:
6: -- : dep warp
7: -- : dep servant-server
8: -- : dep lucid
9: -- : dep servant-lucid
10: -- : dep http-api-data
11: -- : dep process
12: -- : dep clay
13: module Omni.Jr.Web
14: ( run,
15: defaultPort,
16: )
17: where
18:
19: import Alpha
20: import qualified Control.Concurrent as Concurrent
21: import qualified Data.Aeson as Aeson
22: import qualified Data.Aeson.KeyMap as KeyMap
23: import qualified Data.ByteString.Lazy as LBS
24: import qualified Data.List as List
25: import qualified Data.Text as Text
26: import qualified Data.Text.Lazy as LazyText
27: import qualified Data.Text.Lazy.Encoding as LazyText
28: import Data.Time (Day, NominalDiffTime, UTCTime (..), dayOfWeek, defaultTimeLocale, diffUTCTime, formatTime, getCurrentTime, toGregorian)
29: import Data.Time.Calendar (DayOfWeek (..))
30: import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
31: import qualified Lucid
32: import qualified Lucid.Base as Lucid
33: import qualified Network.Wai.Handler.Warp as Warp
34: import Numeric (showFFloat)
35: import qualified Omni.Fact as Fact
36: import qualified Omni.Jr.Web.Style as Style
37: import qualified Omni.Task.Core as TaskCore
38: import Servant
39: import qualified Servant.HTML.Lucid as Lucid
40: import qualified Servant.Types.SourceT as Source
41: import qualified System.Exit as Exit
42: import qualified System.Process as Process
43: import Web.FormUrlEncoded (FromForm (..), lookupUnique, parseUnique)
44:
45: type PostRedirect = Verb 'POST 303 '[Lucid.HTML] (Headers '[Header "Location" Text] NoContent)
I see that Alpha is imported which likely includes Data.List.foldl' already. Let me check if we need to add it explicitly. Now let me remove the Execution Details section. Let me search for where it's rendered:
Omni/Jr/Web.hs @1590-16151590:
1591: let hasRunningActivity = any (\a -> TaskCore.activityStage a == TaskCore.Running) activities
1592: when hasRunningActivity <| do
1593: let isInProgress = TaskCore.taskStatus task == TaskCore.InProgress
1594: htmxAttrs =
1595: [ Lucid.makeAttribute "hx-get" ("/partials/task/" <> TaskCore.taskId task <> "/metrics"),
1596: Lucid.makeAttribute "hx-trigger" "every 5s",
1597: Lucid.makeAttribute "hx-swap" "innerHTML"
1598: ]
1599: innerAttrs =
1600: [Lucid.id_ "execution-details-inner"]
1601: <> [attr | isInProgress, attr <- htmxAttrs]
1602: Lucid.div_ [Lucid.class_ "execution-section"] <| do
1603: Lucid.h3_ "Execution Details"
1604: Lucid.div_ innerAttrs <| renderExecutionDetails (TaskCore.taskId task) activities maybeRetry
1605:
1606: when (TaskCore.taskStatus task == TaskCore.Review) <| do
1607: Lucid.div_ [Lucid.class_ "review-link-section"] <| do
1608: Lucid.a_
1609: [ Lucid.href_ ("/tasks/" <> TaskCore.taskId task <> "/review"),
1610: Lucid.class_ "review-link-btn"
1611: ]
1612: "Review This Task"
1613:
1614: renderUnifiedTimeline (TaskCore.taskId task) (TaskCore.taskComments task) agentEvents (TaskCore.taskStatus task) now
1615: where
Now I'll remove the Execution Details section:
Omni/Jr/Web.hsLet me check the exact formatting:
cd /home/ben/omni && sed -n '1591,1605p' Omni/Jr/Web.hs | cat -A let hasRunningActivity = any (\a -> TaskCore.activityStage a == TaskCore.Running) activities$
when hasRunningActivity <| do$
let isInProgress = TaskCore.taskStatus task == TaskCore.InProgress$
htmxAttrs =$
[ Lucid.makeAttribute "hx-get" ("/partials/task/" <> TaskCore.taskId task <> "/metrics"),$
Lucid.makeAttribute "hx-trigger" "every 5s",$
Lucid.makeAttribute "hx-swap" "innerHTML"$
]$
innerAttrs =$
[Lucid.id_ "execution-details-inner"]$
<> [attr | isInProgress, attr <- htmxAttrs]$
Lucid.div_ [Lucid.class_ "execution-section"] <| do$
Lucid.h3_ "Execution Details"$
Lucid.div_ innerAttrs <| renderExecutionDetails (TaskCore.taskId task) activities maybeRetry$
$
Omni/Jr/Web.hsLet me try a different approach - just comment out or delete the section differently:
Omni/Jr/Web.hs @1587-16201587: Lucid.h3_ "Git Commits"
1588: Lucid.div_ [Lucid.class_ "commit-list"] <| do
1589: traverse_ (renderCommit (TaskCore.taskId task)) commits
1590:
1591: let hasRunningActivity = any (\a -> TaskCore.activityStage a == TaskCore.Running) activities
1592: when hasRunningActivity <| do
1593: let isInProgress = TaskCore.taskStatus task == TaskCore.InProgress
1594: htmxAttrs =
1595: [ Lucid.makeAttribute "hx-get" ("/partials/task/" <> TaskCore.taskId task <> "/metrics"),
1596: Lucid.makeAttribute "hx-trigger" "every 5s",
1597: Lucid.makeAttribute "hx-swap" "innerHTML"
1598: ]
1599: innerAttrs =
1600: [Lucid.id_ "execution-details-inner"]
1601: <> [attr | isInProgress, attr <- htmxAttrs]
1602: Lucid.div_ [Lucid.class_ "execution-section"] <| do
1603: Lucid.h3_ "Execution Details"
1604: Lucid.div_ innerAttrs <| renderExecutionDetails (TaskCore.taskId task) activities maybeRetry
1605:
1606: when (TaskCore.taskStatus task == TaskCore.Review) <| do
1607: Lucid.div_ [Lucid.class_ "review-link-section"] <| do
1608: Lucid.a_
1609: [ Lucid.href_ ("/tasks/" <> TaskCore.taskId task <> "/review"),
1610: Lucid.class_ "review-link-btn"
1611: ]
1612: "Review This Task"
1613:
1614: renderUnifiedTimeline (TaskCore.taskId task) (TaskCore.taskComments task) agentEvents (TaskCore.taskStatus task) now
1615: where
1616: renderDependency :: (Monad m) => TaskCore.Dependency -> Lucid.HtmlT m ()
1617: renderDependency dep =
1618: Lucid.li_ <| do
1619: Lucid.a_ [Lucid.href_ ("/tasks/" <> TaskCore.depId dep), Lucid.class_ "task-link"] (Lucid.toHtml (TaskCore.depId dep))
1620: Lucid.span_ [Lucid.class_ "dep-type"] <| Lucid.toHtml (" [" <> tshow (TaskCore.depType dep) <> "]")
Let me delete the lines more precisely:
Omni/Jr/Web.hsLet me check what the actual backslash looks like:
cd /home/ben/omni && sed -n '1591p' Omni/Jr/Web.hs | od -c | head -200000000 l e 0000020 t h a s R u n n i n g A c t i 0000040 v i t y = a n y ( \ a - 0000060 > T a s k C o r e . a c t i v 0000100 i t y S t a g e a = = T a 0000120 s k C o r e . R u n n i n g ) 0000140 a c t i v i t i e s \n 0000153
{"contents":[207.88610000000006,200],"tag":"GuardrailCostExceeded"}