diff options
Diffstat (limited to 'Omni/Task.hs')
| -rw-r--r-- | Omni/Task.hs | 1014 |
1 files changed, 1014 insertions, 0 deletions
diff --git a/Omni/Task.hs b/Omni/Task.hs new file mode 100644 index 0000000..c6e68ac --- /dev/null +++ b/Omni/Task.hs @@ -0,0 +1,1014 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- : dep sqlite-simple +module Omni.Task where + +import Alpha +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as BLC +import qualified Data.Text as T +import qualified Omni.Cli as Cli +import qualified Omni.Namespace as Namespace +import Omni.Task.Core +import qualified Omni.Task.MigrationTest as MigrationTest +import qualified Omni.Task.RaceTest as RaceTest +import qualified Omni.Test as Test +import qualified System.Console.Docopt as Docopt +import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile) +import System.Environment (setEnv) +import qualified Test.Tasty as Tasty +import Web.HttpApiData (parseQueryParam) +import Prelude (read) + +main :: IO () +main = Cli.main plan + +plan :: Cli.Plan () +plan = + Cli.Plan + { help = help, + move = move, + test = test, + tidy = \_ -> pure () + } + +help :: Cli.Docopt +help = + [Cli.docopt| +task + +Usage: + task init [--quiet] + task create <title> [options] + task edit <id> [options] + task delete <id> [--json] + task comment <id> <message> [--json] + task list [options] + task ready [--json] + task show <id> [--json] + task update <id> <status> [options] [--verified] + task deps <id> [--json] + task tree [<id>] [--json] + task progress <id> [--json] + task stats [--epic=<id>] [--json] + task export [-o <file>] + task import -i <file> + task test + task (-h | --help) + +Commands: + init Initialize task database + create Create a new task or epic + edit Edit an existing task + delete Delete a task + comment Add a comment to a task + list List all tasks + ready Show ready tasks (not blocked) + show Show detailed task information + update Update task status + deps Show dependency tree + tree Show task tree (epics with children, or all epics if no ID given) + progress Show progress for an epic + stats Show task statistics + export Export tasks to JSONL + import Import tasks from JSONL file + test Run tests + +Options: + -h --help Show this help + --title=<title> Task title + --type=<type> Task type: epic, task, or human (default: task) + --parent=<id> Parent epic ID + --priority=<p> Priority: 0-4 (0=critical, 4=backlog, default: 2) + --complexity=<c> Complexity: 1-5 for model selection (1=trivial, 5=expert) + --status=<status> Filter by status: draft, open, in-progress, review, approved, done + --epic=<id> Filter stats by epic (recursive) + --deps=<ids> Comma-separated list of dependency IDs + --dep-type=<type> Dependency type: blocks, discovered-from, parent-child, related + --discovered-from=<id> Shortcut for --deps=<id> --dep-type=discovered-from + --namespace=<ns> Optional namespace (e.g., Omni/Task, Biz/Cloud) + --description=<desc> Task description + --db=<file> Path to SQLite database (overrides TASK_DB_PATH) + --flush Force immediate export + --json Output in JSON format (for agent use) + --quiet Non-interactive mode (for agents) + --verified Mark task as verified (code compiles, tests pass, feature works) + -i <file> Input file for import + -o <file> Output file for export + +Arguments: + <title> Task title + <id> Task ID + <status> Task status (draft, open, in-progress, review, approved, done) + <message> Comment message + <file> JSONL file to import +|] + +-- Helper to check if JSON output is requested +isJsonMode :: Cli.Arguments -> Bool +isJsonMode args = args `Cli.has` Cli.longOption "json" + +-- Helper to output JSON +outputJson :: (Aeson.ToJSON a) => a -> IO () +outputJson val = BLC.putStrLn <| Aeson.encode val + +-- Helper for success message in JSON +outputSuccess :: Text -> IO () +outputSuccess msg = outputJson <| Aeson.object ["success" Aeson..= True, "message" Aeson..= msg] + +move :: Cli.Arguments -> IO () +move args = do + -- Handle --db flag globally + for_ + (Cli.getArg args (Cli.longOption "db")) + (setEnv "TASK_DB_PATH") + + move' args + +move' :: Cli.Arguments -> IO () +move' args + | args `Cli.has` Cli.command "init" = do + let quiet = args `Cli.has` Cli.longOption "quiet" + initTaskDb + unless quiet <| putText "Task database initialized. Use 'task create' to add tasks." + | args `Cli.has` Cli.command "create" = do + title <- getArgText args "title" + taskType <- case Cli.getArg args (Cli.longOption "type") of + Nothing -> pure WorkTask + Just "epic" -> pure Epic + Just "task" -> pure WorkTask + Just "human" -> pure HumanTask + Just other -> panic <| "Invalid task type: " <> T.pack other <> ". Use: epic, task, or human" + parent <- case Cli.getArg args (Cli.longOption "parent") of + Nothing -> pure Nothing + Just p -> pure <| Just (T.pack p) + + -- Handle --discovered-from as shortcut + (depIds, depType) <- case Cli.getArg args (Cli.longOption "discovered-from") of + Just discoveredId -> pure ([T.pack discoveredId], DiscoveredFrom) + Nothing -> do + -- Parse regular --deps and --dep-type + ids <- case Cli.getArg args (Cli.longOption "deps") of + Nothing -> pure [] + Just depStr -> pure <| T.splitOn "," (T.pack depStr) + dtype <- case Cli.getArg args (Cli.longOption "dep-type") of + Nothing -> pure Blocks + Just "blocks" -> pure Blocks + Just "discovered-from" -> pure DiscoveredFrom + Just "parent-child" -> pure ParentChild + Just "related" -> pure Related + Just other -> panic <| "Invalid dependency type: " <> T.pack other <> ". Use: blocks, discovered-from, parent-child, or related" + pure (ids, dtype) + + let deps = map (\did -> Dependency {depId = did, depType = depType}) depIds + + -- Parse priority (default to P2 = medium) + priority <- case Cli.getArg args (Cli.longOption "priority") of + Nothing -> pure P2 + Just "0" -> pure P0 + Just "1" -> pure P1 + Just "2" -> pure P2 + Just "3" -> pure P3 + Just "4" -> pure P4 + Just other -> panic <| "Invalid priority: " <> T.pack other <> ". Use: 0-4" + + -- Parse complexity (1-5 scale) + complexity <- case Cli.getArg args (Cli.longOption "complexity") of + Nothing -> pure Nothing + Just c -> case readMaybe c of + Just n | n >= 1 && n <= 5 -> pure (Just n) + _ -> panic <| "Invalid complexity: " <> T.pack c <> ". Use: 1-5" + + namespace <- case Cli.getArg args (Cli.longOption "namespace") of + Nothing -> pure Nothing + Just ns -> do + -- Validate it's a proper namespace by parsing it + let validNs = Namespace.fromHaskellModule ns + nsPath = T.pack <| Namespace.toPath validNs + pure <| Just nsPath + + description <- case Cli.getArg args (Cli.longOption "description") of + Nothing -> panic "--description is required for task create" + Just d -> pure (T.pack d) + + createdTask <- createTask title taskType parent namespace priority complexity deps description + if isJsonMode args + then outputJson createdTask + else putStrLn <| "Created task: " <> T.unpack (taskId createdTask) + | args `Cli.has` Cli.command "edit" = do + tid <- getArgText args "id" + + -- Parse optional edits + maybeTitle <- pure <| Cli.getArg args (Cli.longOption "title") + maybeType <- case Cli.getArg args (Cli.longOption "type") of + Nothing -> pure Nothing + Just "epic" -> pure <| Just Epic + Just "task" -> pure <| Just WorkTask + Just other -> panic <| "Invalid task type: " <> T.pack other <> ". Use: epic or task" + maybeParent <- pure <| fmap T.pack (Cli.getArg args (Cli.longOption "parent")) + maybePriority <- case Cli.getArg args (Cli.longOption "priority") of + Nothing -> pure Nothing + Just "0" -> pure <| Just P0 + Just "1" -> pure <| Just P1 + Just "2" -> pure <| Just P2 + Just "3" -> pure <| Just P3 + Just "4" -> pure <| Just P4 + Just other -> panic <| "Invalid priority: " <> T.pack other <> ". Use: 0-4" + maybeComplexity <- case Cli.getArg args (Cli.longOption "complexity") of + Nothing -> pure Nothing + Just c -> case readMaybe c of + Just n | n >= 1 && n <= 5 -> pure (Just (Just n)) + _ -> panic <| "Invalid complexity: " <> T.pack c <> ". Use: 1-5" + maybeStatus <- case Cli.getArg args (Cli.longOption "status") of + Nothing -> pure Nothing + Just "draft" -> pure <| Just Draft + Just "open" -> pure <| Just Open + Just "in-progress" -> pure <| Just InProgress + Just "review" -> pure <| Just Review + Just "done" -> pure <| Just Done + Just other -> panic <| "Invalid status: " <> T.pack other <> ". Use: draft, open, in-progress, review, or done" + maybeNamespace <- case Cli.getArg args (Cli.longOption "namespace") of + Nothing -> pure Nothing + Just ns -> do + let validNs = Namespace.fromHaskellModule ns + nsPath = T.pack <| Namespace.toPath validNs + pure <| Just nsPath + maybeDesc <- pure <| fmap T.pack (Cli.getArg args (Cli.longOption "description")) + + maybeDeps <- case Cli.getArg args (Cli.longOption "discovered-from") of + Just discoveredId -> pure <| Just [Dependency {depId = T.pack discoveredId, depType = DiscoveredFrom}] + Nothing -> case Cli.getArg args (Cli.longOption "deps") of + Nothing -> pure Nothing + Just depStr -> do + let ids = T.splitOn "," (T.pack depStr) + dtype <- case Cli.getArg args (Cli.longOption "dep-type") of + Nothing -> pure Blocks + Just "blocks" -> pure Blocks + Just "discovered-from" -> pure DiscoveredFrom + Just "parent-child" -> pure ParentChild + Just "related" -> pure Related + Just other -> panic <| "Invalid dependency type: " <> T.pack other + pure <| Just (map (\did -> Dependency {depId = did, depType = dtype}) ids) + + let modifyFn task = + task + { taskTitle = maybe (taskTitle task) T.pack maybeTitle, + taskType = fromMaybe (taskType task) maybeType, + taskParent = case maybeParent of Nothing -> taskParent task; Just p -> Just p, + taskNamespace = case maybeNamespace of Nothing -> taskNamespace task; Just ns -> Just ns, + taskStatus = fromMaybe (taskStatus task) maybeStatus, + taskPriority = fromMaybe (taskPriority task) maybePriority, + taskComplexity = fromMaybe (taskComplexity task) maybeComplexity, + taskDescription = fromMaybe (taskDescription task) maybeDesc, + taskDependencies = fromMaybe (taskDependencies task) maybeDeps + } + + updatedTask <- editTask tid modifyFn + if isJsonMode args + then outputJson updatedTask + else putStrLn <| "Updated task: " <> T.unpack (taskId updatedTask) + | args `Cli.has` Cli.command "delete" = do + tid <- getArgText args "id" + deleteTask tid + if isJsonMode args + then outputSuccess ("Deleted task " <> tid) + else putStrLn <| "Deleted task: " <> T.unpack tid + | args `Cli.has` Cli.command "comment" = do + tid <- getArgText args "id" + message <- getArgText args "message" + updatedTask <- addComment tid message + if isJsonMode args + then outputJson updatedTask + else putStrLn <| "Added comment to task: " <> T.unpack tid + | args `Cli.has` Cli.command "list" = do + maybeType <- case Cli.getArg args (Cli.longOption "type") of + Nothing -> pure Nothing + Just "epic" -> pure <| Just Epic + Just "task" -> pure <| Just WorkTask + Just "human" -> pure <| Just HumanTask + Just other -> panic <| "Invalid task type: " <> T.pack other + maybeParent <- case Cli.getArg args (Cli.longOption "parent") of + Nothing -> pure Nothing + Just p -> pure <| Just (T.pack p) + maybeStatus <- case Cli.getArg args (Cli.longOption "status") of + Nothing -> pure Nothing + Just "draft" -> pure <| Just Draft + Just "open" -> pure <| Just Open + Just "in-progress" -> pure <| Just InProgress + Just "review" -> pure <| Just Review + Just "approved" -> pure <| Just Approved + Just "done" -> pure <| Just Done + Just other -> panic <| "Invalid status: " <> T.pack other <> ". Use: draft, open, in-progress, review, approved, or done" + maybeNamespace <- case Cli.getArg args (Cli.longOption "namespace") of + Nothing -> pure Nothing + Just ns -> do + let validNs = Namespace.fromHaskellModule ns + nsPath = T.pack <| Namespace.toPath validNs + pure <| Just nsPath + tasks <- listTasks maybeType maybeParent maybeStatus maybeNamespace + if isJsonMode args + then outputJson tasks + else traverse_ printTask tasks + | args `Cli.has` Cli.command "ready" = do + tasks <- getReadyTasks + if isJsonMode args + then outputJson tasks + else do + putText "Ready tasks:" + traverse_ printTask tasks + | args `Cli.has` Cli.command "show" = do + tid <- getArgText args "id" + tasks <- loadTasks + case findTask tid tasks of + Nothing -> putText "Task not found" + Just task -> + if isJsonMode args + then outputJson task + else showTaskDetailed task + | args `Cli.has` Cli.command "update" = do + tid <- getArgText args "id" + statusStr <- getArgText args "status" + let isVerified = args `Cli.has` Cli.longOption "verified" + + -- Handle update dependencies + deps <- do + -- Parse --deps and --dep-type + ids <- case Cli.getArg args (Cli.longOption "deps") of + Nothing -> pure [] + Just depStr -> pure <| T.splitOn "," (T.pack depStr) + dtype <- case Cli.getArg args (Cli.longOption "dep-type") of + Nothing -> pure Blocks + Just "blocks" -> pure Blocks + Just "discovered-from" -> pure DiscoveredFrom + Just "parent-child" -> pure ParentChild + Just "related" -> pure Related + Just other -> panic <| "Invalid dependency type: " <> T.pack other <> ". Use: blocks, discovered-from, parent-child, or related" + pure (map (\d -> Dependency {depId = d, depType = dtype}) ids) + + let newStatus = case statusStr of + "draft" -> Draft + "open" -> Open + "in-progress" -> InProgress + "review" -> Review + "approved" -> Approved + "done" -> Done + _ -> panic "Invalid status. Use: draft, open, in-progress, review, approved, or done" + + -- Show verification checklist warning when marking Done without --verified + when (newStatus == Done && not isVerified && not (isJsonMode args)) <| do + putText "" + putText "⚠️ VERIFICATION CHECKLIST (use --verified to skip):" + putText " [ ] Code compiles (bild succeeds)" + putText " [ ] Tests pass (bild --test)" + putText " [ ] Feature works in production (manual verification)" + putText "" + + updateTaskStatus tid newStatus deps + + -- Record verification in activity log if verified + when (newStatus == Done && isVerified) + <| logActivity tid Completed (Just "{\"verified\":true}") + + if isJsonMode args + then + if newStatus == Done && isVerified + then outputJson <| Aeson.object ["success" Aeson..= True, "message" Aeson..= ("Updated task " <> tid), "verified" Aeson..= True] + else outputSuccess <| "Updated task " <> tid + else + if newStatus == Done && isVerified + then putStrLn <| "Updated task " <> T.unpack tid <> " (verified ✓)" + else putStrLn <| "Updated task " <> T.unpack tid + | args `Cli.has` Cli.command "deps" = do + tid <- getArgText args "id" + if isJsonMode args + then do + deps <- getDependencyTree tid + outputJson deps + else showDependencyTree tid + | args `Cli.has` Cli.command "tree" = do + maybeId <- case Cli.getArg args (Cli.argument "id") of + Nothing -> pure Nothing + Just idStr -> pure <| Just (T.pack idStr) + if isJsonMode args + then do + tree <- getTaskTree maybeId + outputJson tree + else showTaskTree maybeId + | args `Cli.has` Cli.command "progress" = do + tid <- getArgText args "id" + if isJsonMode args + then do + progress <- getTaskProgress tid + outputJson progress + else showTaskProgress tid + | args `Cli.has` Cli.command "stats" = do + maybeEpic <- case Cli.getArg args (Cli.longOption "epic") of + Nothing -> pure Nothing + Just e -> pure <| Just (T.pack e) + if isJsonMode args + then do + stats <- getTaskStats maybeEpic + outputJson stats + else showTaskStats maybeEpic + | args `Cli.has` Cli.command "export" = do + file <- case Cli.getArg args (Cli.shortOption 'o') of + Nothing -> pure Nothing + Just f -> pure (Just f) + exportTasks file + case file of + Just f -> putText <| "Exported tasks to " <> T.pack f + Nothing -> pure () + | args `Cli.has` Cli.command "import" = do + -- Note: -i <file> means the value is stored in option 'i', not argument "file" + file <- case Cli.getArg args (Cli.shortOption 'i') of + Nothing -> panic "import requires -i <file>" + Just f -> pure (T.pack f) + importTasks (T.unpack file) + putText <| "Imported tasks from " <> file + | otherwise = putText (T.pack <| Cli.usage help) + where + getArgText :: Cli.Arguments -> String -> IO Text + getArgText argz name = do + maybeArg <- pure <| Cli.getArg argz (Cli.argument name) + case maybeArg of + Nothing -> panic (T.pack name <> " required") + Just val -> pure (T.pack val) + +test :: Test.Tree +test = + Test.group + "Omni.Task" + [ unitTests, + cliTests, + Tasty.after Tasty.AllSucceed "Unit tests" RaceTest.test, + Tasty.after Tasty.AllSucceed "Unit tests" MigrationTest.test + ] + +unitTests :: Test.Tree +unitTests = + Test.group + "Unit tests" + [ Test.unit "setup test database" <| do + -- Set up test mode for all tests (uses _/tmp/tasks-test.db) + setEnv "TASK_TEST_MODE" "1" + + -- Clean up test database before all tests + let testFile = "_/tmp/tasks-test.db" + createDirectoryIfMissing True "_/tmp" + exists <- doesFileExist testFile + when exists <| removeFile testFile + initTaskDb + True Test.@?= True, + Test.unit "can create task" <| do + task <- createTask "Test task" WorkTask Nothing Nothing P2 Nothing [] "Test description" + taskTitle task Test.@?= "Test task" + taskType task Test.@?= WorkTask + taskStatus task Test.@?= Open + taskPriority task Test.@?= P2 + null (taskDependencies task) Test.@?= True, + Test.unit "can create human task" <| do + task <- createTask "Human Task" HumanTask Nothing Nothing P2 Nothing [] "Human task description" + taskType task Test.@?= HumanTask, + Test.unit "ready tasks exclude human tasks" <| do + task <- createTask "Human Task" HumanTask Nothing Nothing P2 Nothing [] "Human task" + ready <- getReadyTasks + (taskId task `notElem` map taskId ready) Test.@?= True, + Test.unit "ready tasks exclude draft tasks" <| do + task <- createTask "Draft Task" WorkTask Nothing Nothing P2 Nothing [] "Draft description" + updateTaskStatus (taskId task) Draft [] + ready <- getReadyTasks + (taskId task `notElem` map taskId ready) Test.@?= True, + Test.unit "can create task with description" <| do + task <- createTask "Test task" WorkTask Nothing Nothing P2 Nothing [] "My description" + taskDescription task Test.@?= "My description", + Test.unit "can create task with complexity" <| do + task <- createTask "Complex task" WorkTask Nothing Nothing P2 (Just 4) [] "High complexity task" + taskComplexity task Test.@?= Just 4, + Test.unit "complexity is persisted" <| do + task <- createTask "Persisted complexity" WorkTask Nothing Nothing P2 (Just 3) [] "Medium complexity" + tasks <- loadTasks + case findTask (taskId task) tasks of + Nothing -> Test.assertFailure "Could not reload task" + Just reloaded -> taskComplexity reloaded Test.@?= Just 3, + Test.unit "can list tasks" <| do + _ <- createTask "Test task for list" WorkTask Nothing Nothing P2 Nothing [] "List test" + tasks <- listTasks Nothing Nothing Nothing Nothing + not (null tasks) Test.@?= True, + Test.unit "ready tasks exclude blocked ones" <| do + task1 <- createTask "First task" WorkTask Nothing Nothing P2 Nothing [] "First description" + let blockingDep = Dependency {depId = taskId task1, depType = Blocks} + task2 <- createTask "Blocked task" WorkTask Nothing Nothing P2 Nothing [blockingDep] "Blocked description" + ready <- getReadyTasks + (taskId task1 `elem` map taskId ready) Test.@?= True + (taskId task2 `notElem` map taskId ready) Test.@?= True, + Test.unit "discovered-from dependencies don't block" <| do + task1 <- createTask "Original task" WorkTask Nothing Nothing P2 Nothing [] "Original" + let discDep = Dependency {depId = taskId task1, depType = DiscoveredFrom} + task2 <- createTask "Discovered work" WorkTask Nothing Nothing P2 Nothing [discDep] "Discovered" + ready <- getReadyTasks + -- Both should be ready since DiscoveredFrom doesn't block + (taskId task1 `elem` map taskId ready) Test.@?= True + (taskId task2 `elem` map taskId ready) Test.@?= True, + Test.unit "related dependencies don't block" <| do + task1 <- createTask "Task A" WorkTask Nothing Nothing P2 Nothing [] "Task A description" + let relDep = Dependency {depId = taskId task1, depType = Related} + task2 <- createTask "Task B" WorkTask Nothing Nothing P2 Nothing [relDep] "Task B description" + ready <- getReadyTasks + -- Both should be ready since Related doesn't block + (taskId task1 `elem` map taskId ready) Test.@?= True + (taskId task2 `elem` map taskId ready) Test.@?= True, + Test.unit "ready tasks exclude epics" <| do + epic <- createTask "Epic task" Epic Nothing Nothing P2 Nothing [] "Epic description" + ready <- getReadyTasks + (taskId epic `notElem` map taskId ready) Test.@?= True, + Test.unit "ready tasks exclude tasks needing intervention (retry >= 3)" <| do + task <- createTask "Failing task" WorkTask Nothing Nothing P2 Nothing [] "Failing description" + ready1 <- getReadyTasks + (taskId task `elem` map taskId ready1) Test.@?= True + setRetryContext + RetryContext + { retryTaskId = taskId task, + retryOriginalCommit = "abc123", + retryConflictFiles = [], + retryAttempt = 3, + retryReason = "test_failure", + retryNotes = Nothing + } + ready2 <- getReadyTasks + (taskId task `notElem` map taskId ready2) Test.@?= True, + Test.unit "child task gets sequential ID" <| do + parent <- createTask "Parent" Epic Nothing Nothing P2 Nothing [] "Parent epic" + child1 <- createTask "Child 1" WorkTask (Just (taskId parent)) Nothing P2 Nothing [] "Child 1 description" + child2 <- createTask "Child 2" WorkTask (Just (taskId parent)) Nothing P2 Nothing [] "Child 2 description" + taskId child1 Test.@?= taskId parent <> ".1" + taskId child2 Test.@?= taskId parent <> ".2", + Test.unit "grandchild task gets sequential ID" <| do + parent <- createTask "Grandparent" Epic Nothing Nothing P2 Nothing [] "Grandparent epic" + child <- createTask "Parent" Epic (Just (taskId parent)) Nothing P2 Nothing [] "Parent epic" + grandchild <- createTask "Grandchild" WorkTask (Just (taskId child)) Nothing P2 Nothing [] "Grandchild task" + taskId grandchild Test.@?= taskId parent <> ".1.1", + Test.unit "siblings of grandchild task get sequential ID" <| do + parent <- createTask "Grandparent" Epic Nothing Nothing P2 Nothing [] "Grandparent" + child <- createTask "Parent" Epic (Just (taskId parent)) Nothing P2 Nothing [] "Parent" + grandchild1 <- createTask "Grandchild 1" WorkTask (Just (taskId child)) Nothing P2 Nothing [] "Grandchild 1" + grandchild2 <- createTask "Grandchild 2" WorkTask (Just (taskId child)) Nothing P2 Nothing [] "Grandchild 2" + taskId grandchild1 Test.@?= taskId parent <> ".1.1" + taskId grandchild2 Test.@?= taskId parent <> ".1.2", + Test.unit "child ID generation skips gaps" <| do + parent <- createTask "Parent with gaps" Epic Nothing Nothing P2 Nothing [] "Parent with gaps" + child1 <- createTask "Child 1" WorkTask (Just (taskId parent)) Nothing P2 Nothing [] "Child 1" + -- Manually create a task with .3 suffix to simulate a gap (or deleted task) + let child3Id = taskId parent <> ".3" + child3 = + Task + { taskId = child3Id, + taskTitle = "Child 3", + taskType = WorkTask, + taskParent = Just (taskId parent), + taskNamespace = Nothing, + taskStatus = Open, + taskPriority = P2, + taskComplexity = Nothing, + taskDependencies = [], + taskDescription = "Child 3", + taskComments = [], + taskCreatedAt = taskCreatedAt child1, + taskUpdatedAt = taskUpdatedAt child1 + } + saveTask child3 + + -- Create a new child, it should get .4, not .2 + child4 <- createTask "Child 4" WorkTask (Just (taskId parent)) Nothing P2 Nothing [] "Child 4" + taskId child4 Test.@?= taskId parent <> ".4", + Test.unit "can edit task" <| do + task <- createTask "Original Title" WorkTask Nothing Nothing P2 Nothing [] "Original" + let modifyFn t = t {taskTitle = "New Title", taskPriority = P0} + updated <- editTask (taskId task) modifyFn + taskTitle updated Test.@?= "New Title" + taskPriority updated Test.@?= P0 + -- Check persistence + tasks <- loadTasks + case findTask (taskId task) tasks of + Nothing -> Test.assertFailure "Could not reload task" + Just reloaded -> do + taskTitle reloaded Test.@?= "New Title" + taskPriority reloaded Test.@?= P0, + Test.unit "task lookup is case insensitive" <| do + task <- createTask "Case sensitive" WorkTask Nothing Nothing P2 Nothing [] "Case sensitive description" + let tid = taskId task + upperTid = T.toUpper tid + tasks <- loadTasks + let found = findTask upperTid tasks + case found of + Just t -> taskId t Test.@?= tid + Nothing -> Test.assertFailure "Could not find task with upper case ID", + Test.unit "namespace normalization handles .hs suffix" <| do + let ns = "Omni/Task.hs" + validNs = Namespace.fromHaskellModule ns + Namespace.toPath validNs Test.@?= "Omni/Task.hs", + Test.unit "generated IDs are lowercase" <| do + task <- createTask "Lowercase check" WorkTask Nothing Nothing P2 Nothing [] "Lowercase description" + let tid = taskId task + tid Test.@?= T.toLower tid + -- check it matches regex for base36 (t-[0-9a-z]+) + let isLowerBase36 = T.all (\c -> c `elem` ['0' .. '9'] ++ ['a' .. 'z'] || c == 't' || c == '-') tid + isLowerBase36 Test.@?= True, + Test.unit "dependencies are case insensitive" <| do + task1 <- createTask "Blocker" WorkTask Nothing Nothing P2 Nothing [] "Blocker description" + let tid1 = taskId task1 + -- Use uppercase ID for dependency + upperTid1 = T.toUpper tid1 + dep = Dependency {depId = upperTid1, depType = Blocks} + task2 <- createTask "Blocked" WorkTask Nothing Nothing P2 Nothing [dep] "Blocked description" + + -- task1 is Open, so task2 should NOT be ready + ready <- getReadyTasks + (taskId task2 `notElem` map taskId ready) Test.@?= True + + updateTaskStatus tid1 Done [] + + -- task2 should now be ready because dependency check normalizes IDs + ready2 <- getReadyTasks + (taskId task2 `elem` map taskId ready2) Test.@?= True, + Test.unit "can create task with lowercase ID" <| do + -- This verifies that lowercase IDs are accepted and not rejected + let lowerId = "t-lowercase" + let task = Task lowerId "Lower" WorkTask Nothing Nothing Open P2 Nothing [] "Lower description" [] (read "2025-01-01 00:00:00 UTC") (read "2025-01-01 00:00:00 UTC") + saveTask task + tasks <- loadTasks + case findTask lowerId tasks of + Just t -> taskId t Test.@?= lowerId + Nothing -> Test.assertFailure "Should find task with lowercase ID", + Test.unit "generateId produces valid ID" <| do + tid <- generateId + let task = Task tid "Auto" WorkTask Nothing Nothing Open P2 Nothing [] "Auto description" [] (read "2025-01-01 00:00:00 UTC") (read "2025-01-01 00:00:00 UTC") + saveTask task + tasks <- loadTasks + case findTask tid tasks of + Just _ -> pure () + Nothing -> Test.assertFailure "Should find generated task", + Test.unit "generateId produces sequential IDs" <| do + tid1 <- generateId + tid2 <- generateId + tid3 <- generateId + T.isPrefixOf "t-" tid1 Test.@?= True + T.isPrefixOf "t-" tid2 Test.@?= True + T.isPrefixOf "t-" tid3 Test.@?= True + let num1 = readMaybe (T.unpack (T.drop 2 tid1)) :: Maybe Int + num2 = readMaybe (T.unpack (T.drop 2 tid2)) :: Maybe Int + num3 = readMaybe (T.unpack (T.drop 2 tid3)) :: Maybe Int + case (num1, num2, num3) of + (Just n1, Just n2, Just n3) -> do + (n2 == n1 + 1) Test.@?= True + (n3 == n2 + 1) Test.@?= True + _ -> Test.assertFailure "IDs should be sequential integers", + Test.unit "lowercase ID does not clash with existing uppercase ID" <| do + -- Setup: Create task with Uppercase ID + let upperId = "t-UPPER" + let task1 = Task upperId "Upper Task" WorkTask Nothing Nothing Open P2 Nothing [] "Upper description" [] (read "2025-01-01 00:00:00 UTC") (read "2025-01-01 00:00:00 UTC") + saveTask task1 + + -- Action: Try to create task with Lowercase ID (same letters) + -- Note: In the current implementation, saveTask blindly appends. + -- Ideally, we should be checking for existence if we want to avoid clash. + -- OR, we accept that they are the SAME task and this is an update? + -- But if they are different tasks (different titles, created at different times), + -- treating them as the same is dangerous. + + let lowerId = "t-upper" + let task2 = Task lowerId "Lower Task" WorkTask Nothing Nothing Open P2 Nothing [] "Lower description" [] (read "2025-01-01 00:00:01 UTC") (read "2025-01-01 00:00:01 UTC") + saveTask task2 + + tasks <- loadTasks + -- What do we expect? + -- If we expect them to be distinct: + -- let foundUpper = List.find (\t -> taskId t == upperId) tasks + -- let foundLower = List.find (\t -> taskId t == lowerId) tasks + -- foundUpper /= Nothing + -- foundLower /= Nothing + + -- BUT findTask uses case-insensitive search. + -- So findTask upperId returns task1 (probably, as it's first). + -- findTask lowerId returns task1. + -- task2 is effectively hidden/lost to findTask. + + -- So, "do not clash" implies we shouldn't end up in this state. + -- The test should probably fail if we have multiple tasks that match the same ID case-insensitively. + + let matches = filter (\t -> matchesId (taskId t) upperId) tasks + length matches Test.@?= 2, + Test.unit "FromHttpApiData Priority: empty string returns Left" <| do + let result = parseQueryParam "" :: Either Text Priority + case result of + Left _ -> pure () + Right _ -> Test.assertFailure "Empty string should return Left", + Test.unit "FromHttpApiData Priority: valid values parse correctly" <| do + (parseQueryParam "P0" :: Either Text Priority) Test.@?= Right P0 + (parseQueryParam "P1" :: Either Text Priority) Test.@?= Right P1 + (parseQueryParam "P2" :: Either Text Priority) Test.@?= Right P2 + (parseQueryParam "P3" :: Either Text Priority) Test.@?= Right P3 + (parseQueryParam "P4" :: Either Text Priority) Test.@?= Right P4, + Test.unit "FromHttpApiData Status: empty string returns Left" <| do + let result = parseQueryParam "" :: Either Text Status + case result of + Left _ -> pure () + Right _ -> Test.assertFailure "Empty string should return Left", + Test.unit "FromHttpApiData Status: valid values parse correctly" <| do + (parseQueryParam "Open" :: Either Text Status) Test.@?= Right Open + (parseQueryParam "InProgress" :: Either Text Status) Test.@?= Right InProgress + (parseQueryParam "Done" :: Either Text Status) Test.@?= Right Done, + Test.unit "can add comment to task" <| do + task <- createTask "Task with comment" WorkTask Nothing Nothing P2 Nothing [] "Description" + updatedTask <- addComment (taskId task) "This is a test comment" + length (taskComments updatedTask) Test.@?= 1 + case taskComments updatedTask of + (c : _) -> commentText c Test.@?= "This is a test comment" + [] -> Test.assertFailure "Expected at least one comment", + Test.unit "can add multiple comments to task" <| do + task <- createTask "Task with comments" WorkTask Nothing Nothing P2 Nothing [] "Description" + _ <- addComment (taskId task) "First comment" + updatedTask <- addComment (taskId task) "Second comment" + length (taskComments updatedTask) Test.@?= 2 + case taskComments updatedTask of + (c1 : c2 : _) -> do + commentText c1 Test.@?= "First comment" + commentText c2 Test.@?= "Second comment" + _ -> Test.assertFailure "Expected at least two comments", + Test.unit "comments are persisted" <| do + task <- createTask "Persistent comments" WorkTask Nothing Nothing P2 Nothing [] "Description" + _ <- addComment (taskId task) "Persisted comment" + tasks <- loadTasks + case findTask (taskId task) tasks of + Nothing -> Test.assertFailure "Could not reload task" + Just reloaded -> do + length (taskComments reloaded) Test.@?= 1 + case taskComments reloaded of + (c : _) -> commentText c Test.@?= "Persisted comment" + [] -> Test.assertFailure "Expected at least one comment" + ] + +-- | Test CLI argument parsing to ensure docopt string matches actual usage +cliTests :: Test.Tree +cliTests = + Test.group + "CLI argument parsing" + [ Test.unit "init command" <| do + let result = Docopt.parseArgs help ["init"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'init': " <> show err + Right args -> args `Cli.has` Cli.command "init" Test.@?= True, + Test.unit "init with --quiet flag" <| do + let result = Docopt.parseArgs help ["init", "--quiet"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'init --quiet': " <> show err + Right args -> do + args `Cli.has` Cli.command "init" Test.@?= True + args `Cli.has` Cli.longOption "quiet" Test.@?= True, + Test.unit "create with title" <| do + let result = Docopt.parseArgs help ["create", "Test task"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'create': " <> show err + Right args -> do + args `Cli.has` Cli.command "create" Test.@?= True + Cli.getArg args (Cli.argument "title") Test.@?= Just "Test task", + Test.unit "create with --json flag" <| do + let result = Docopt.parseArgs help ["create", "Test", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'create --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "create" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True, + Test.unit "create with --namespace flag" <| do + let result = Docopt.parseArgs help ["create", "Test", "--namespace=Omni/Task"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'create --namespace': " <> show err + Right args -> do + args `Cli.has` Cli.command "create" Test.@?= True + Cli.getArg args (Cli.longOption "namespace") Test.@?= Just "Omni/Task", + Test.unit "create with --discovered-from flag" <| do + let result = Docopt.parseArgs help ["create", "Test", "--discovered-from=t-abc123"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'create --discovered-from': " <> show err + Right args -> do + args `Cli.has` Cli.command "create" Test.@?= True + Cli.getArg args (Cli.longOption "discovered-from") Test.@?= Just "t-abc123", + Test.unit "create with --priority flag" <| do + let result = Docopt.parseArgs help ["create", "Test", "--priority=1"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'create --priority': " <> show err + Right args -> do + args `Cli.has` Cli.command "create" Test.@?= True + Cli.getArg args (Cli.longOption "priority") Test.@?= Just "1", + Test.unit "create with --complexity flag" <| do + let result = Docopt.parseArgs help ["create", "Test", "--complexity=3"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'create --complexity': " <> show err + Right args -> do + args `Cli.has` Cli.command "create" Test.@?= True + Cli.getArg args (Cli.longOption "complexity") Test.@?= Just "3", + Test.unit "edit with --complexity flag" <| do + let result = Docopt.parseArgs help ["edit", "t-abc123", "--complexity=4"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'edit --complexity': " <> show err + Right args -> do + args `Cli.has` Cli.command "edit" Test.@?= True + Cli.getArg args (Cli.longOption "complexity") Test.@?= Just "4", + Test.unit "edit command" <| do + let result = Docopt.parseArgs help ["edit", "t-abc123"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'edit': " <> show err + Right args -> do + args `Cli.has` Cli.command "edit" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123", + Test.unit "edit with options" <| do + let result = Docopt.parseArgs help ["edit", "t-abc123", "--title=New Title", "--priority=0"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'edit' with options: " <> show err + Right args -> do + args `Cli.has` Cli.command "edit" Test.@?= True + Cli.getArg args (Cli.longOption "title") Test.@?= Just "New Title" + Cli.getArg args (Cli.longOption "priority") Test.@?= Just "0", + Test.unit "list command" <| do + let result = Docopt.parseArgs help ["list"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'list': " <> show err + Right args -> args `Cli.has` Cli.command "list" Test.@?= True, + Test.unit "list with --json flag" <| do + let result = Docopt.parseArgs help ["list", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'list --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "list" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True, + Test.unit "list with --status filter" <| do + let result = Docopt.parseArgs help ["list", "--status=open"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'list --status': " <> show err + Right args -> do + args `Cli.has` Cli.command "list" Test.@?= True + Cli.getArg args (Cli.longOption "status") Test.@?= Just "open", + Test.unit "list with --status=approved filter" <| do + let result = Docopt.parseArgs help ["list", "--status=approved"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'list --status=approved': " <> show err + Right args -> do + args `Cli.has` Cli.command "list" Test.@?= True + Cli.getArg args (Cli.longOption "status") Test.@?= Just "approved", + Test.unit "list with --status=draft filter" <| do + let result = Docopt.parseArgs help ["list", "--status=draft"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'list --status=draft': " <> show err + Right args -> do + args `Cli.has` Cli.command "list" Test.@?= True + Cli.getArg args (Cli.longOption "status") Test.@?= Just "draft", + Test.unit "ready command" <| do + let result = Docopt.parseArgs help ["ready"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'ready': " <> show err + Right args -> args `Cli.has` Cli.command "ready" Test.@?= True, + Test.unit "ready with --json flag" <| do + let result = Docopt.parseArgs help ["ready", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'ready --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "ready" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True, + Test.unit "update command" <| do + let result = Docopt.parseArgs help ["update", "t-abc123", "done"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'update': " <> show err + Right args -> do + args `Cli.has` Cli.command "update" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123" + Cli.getArg args (Cli.argument "status") Test.@?= Just "done", + Test.unit "update command with approved" <| do + let result = Docopt.parseArgs help ["update", "t-abc123", "approved"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'update ... approved': " <> show err + Right args -> do + args `Cli.has` Cli.command "update" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123" + Cli.getArg args (Cli.argument "status") Test.@?= Just "approved", + Test.unit "update command with draft" <| do + let result = Docopt.parseArgs help ["update", "t-abc123", "draft"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'update ... draft': " <> show err + Right args -> do + args `Cli.has` Cli.command "update" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123" + Cli.getArg args (Cli.argument "status") Test.@?= Just "draft", + Test.unit "update with --json flag" <| do + let result = Docopt.parseArgs help ["update", "t-abc123", "done", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'update --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "update" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True, + Test.unit "update with --verified flag" <| do + let result = Docopt.parseArgs help ["update", "t-abc123", "done", "--verified"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'update --verified': " <> show err + Right args -> do + args `Cli.has` Cli.command "update" Test.@?= True + args `Cli.has` Cli.longOption "verified" Test.@?= True, + Test.unit "update with --verified and --json flags" <| do + let result = Docopt.parseArgs help ["update", "t-abc123", "done", "--verified", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'update --verified --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "update" Test.@?= True + args `Cli.has` Cli.longOption "verified" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True, + Test.unit "deps command" <| do + let result = Docopt.parseArgs help ["deps", "t-abc123"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'deps': " <> show err + Right args -> do + args `Cli.has` Cli.command "deps" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123", + Test.unit "tree command" <| do + let result = Docopt.parseArgs help ["tree"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'tree': " <> show err + Right args -> args `Cli.has` Cli.command "tree" Test.@?= True, + Test.unit "tree with id" <| do + let result = Docopt.parseArgs help ["tree", "t-abc123"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'tree <id>': " <> show err + Right args -> do + args `Cli.has` Cli.command "tree" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123", + Test.unit "export command" <| do + let result = Docopt.parseArgs help ["export"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'export': " <> show err + Right args -> args `Cli.has` Cli.command "export" Test.@?= True, + Test.unit "import command" <| do + let result = Docopt.parseArgs help ["import", "-i", "tasks.jsonl"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'import': " <> show err + Right args -> do + args `Cli.has` Cli.command "import" Test.@?= True + -- Note: -i is a short option, not an argument + Cli.getArg args (Cli.shortOption 'i') Test.@?= Just "tasks.jsonl", + Test.unit "show command" <| do + let result = Docopt.parseArgs help ["show", "t-abc123"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'show': " <> show err + Right args -> do + args `Cli.has` Cli.command "show" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123", + Test.unit "show with --json flag" <| do + let result = Docopt.parseArgs help ["show", "t-abc123", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'show --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "show" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True, + Test.unit "stats command" <| do + let result = Docopt.parseArgs help ["stats"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'stats': " <> show err + Right args -> args `Cli.has` Cli.command "stats" Test.@?= True, + Test.unit "stats with --json flag" <| do + let result = Docopt.parseArgs help ["stats", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'stats --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "stats" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True, + Test.unit "stats with --epic flag" <| do + let result = Docopt.parseArgs help ["stats", "--epic=t-abc123"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'stats --epic': " <> show err + Right args -> do + args `Cli.has` Cli.command "stats" Test.@?= True + Cli.getArg args (Cli.longOption "epic") Test.@?= Just "t-abc123", + Test.unit "create with flags in different order" <| do + let result = Docopt.parseArgs help ["create", "Test", "--json", "--priority=1", "--namespace=Omni/Task"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'create' with reordered flags: " <> show err + Right args -> do + args `Cli.has` Cli.command "create" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True + Cli.getArg args (Cli.longOption "priority") Test.@?= Just "1" + Cli.getArg args (Cli.longOption "namespace") Test.@?= Just "Omni/Task", + Test.unit "comment command" <| do + let result = Docopt.parseArgs help ["comment", "t-abc123", "This is a comment"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'comment': " <> show err + Right args -> do + args `Cli.has` Cli.command "comment" Test.@?= True + Cli.getArg args (Cli.argument "id") Test.@?= Just "t-abc123" + Cli.getArg args (Cli.argument "message") Test.@?= Just "This is a comment", + Test.unit "comment with --json flag" <| do + let result = Docopt.parseArgs help ["comment", "t-abc123", "Test comment", "--json"] + case result of + Left err -> Test.assertFailure <| "Failed to parse 'comment --json': " <> show err + Right args -> do + args `Cli.has` Cli.command "comment" Test.@?= True + args `Cli.has` Cli.longOption "json" Test.@?= True + ] |