idk

Signed-off-by: David Moc <personal@cdatgoose.org>

1 files changed, 399 insertions, 0 deletions

diff --git a/app/Main.hs b/app/Main.hs
new file mode 100644
index 0000000..6ec23de
--- /dev/null
+++ b/app/Main.hs
@@ -0,0 +1,399 @@
+module Main where
+
+import Control.DeepSeq (force)
+import Control.Exception (evaluate)
+import Data.Char (toLower)
+import Data.List (isInfixOf, isPrefixOf, sortOn, stripPrefix)
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Maybe (fromMaybe)
+import Data.Ord (Down (..))
+import Data.Time.Clock (getCurrentTime)
+import Data.Time.Format (defaultTimeLocale, formatTime)
+import System.Directory
+import System.Environment
+import System.FilePath ((</>))
+import Text.Read (readMaybe)
+
+data Status
+  = CLOSED
+  | IN_PROGRESS
+  | OPEN
+  deriving (Show, Eq, Enum, Bounded, Read, Ord)
+
+data Task = Task
+  { priority :: Int
+  , desc     :: String
+  , status   :: Status
+  } deriving (Show, Eq)
+
+data AppError
+  = TaskNotFound FilePath
+  | InvalidStatus String
+  | InvalidPriority String
+  | MissingArgument String
+  | UnknownOption String
+  | UnexpectedArgument String
+  deriving (Eq)
+
+instance Show AppError where
+  show (TaskNotFound path)      = "Could not find task file: " ++ path </> "Task.md"
+  show (InvalidStatus s)        = "Invalid status: " ++ s ++ ". Use OPEN, IN_PROGRESS, or CLOSED."
+  show (InvalidPriority p)      = "Invalid priority: " ++ p ++ ". Must be an integer."
+  show (MissingArgument flag)   = "Missing value after " ++ flag
+  show (UnknownOption flag)     = "Unknown option: " ++ flag
+  show (UnexpectedArgument arg) = "Unexpected argument: " ++ arg
+
+data TaskRecord = TaskRecord
+  { recordDir  :: FilePath
+  , recordName :: String
+  , recordTask :: Task
+  } deriving (Show, Eq)
+
+recordFile :: TaskRecord -> FilePath
+recordFile r = recordDir r </> "Task.md"
+
+data NewTaskOptions = NewTaskOptions
+  { optPriority :: Maybe Int
+  , optDesc     :: Maybe String
+  } deriving (Show, Eq)
+
+data ListOptions = ListOptions
+  { filterStatus      :: Maybe Status
+  , filterPriority    :: Maybe Int
+  , filterMinPriority :: Maybe Int
+  , filterContains    :: Maybe String
+  } deriving (Show, Eq)
+
+data SetOptions = SetOptions
+  { setName     :: Maybe String
+  , setPriority :: Maybe Int
+  , setDesc     :: Maybe String
+  , setStatus   :: Maybe Status
+  } deriving (Show, Eq)
+
+defaultNewOptions :: NewTaskOptions
+defaultNewOptions = NewTaskOptions Nothing Nothing
+
+parseNewTaskOptions :: [String] -> Either AppError NewTaskOptions
+parseNewTaskOptions = go defaultNewOptions
+  where
+    go opts []              = Right opts
+    go opts ("-p" : p : rs) = readPriority p >>= \n -> go opts { optPriority = Just n } rs
+    go _    ("-p" : [])     = Left (MissingArgument "-p")
+    go opts ("-d" : d : rs) = go opts { optDesc = Just d } rs
+    go _    ("-d" : [])     = Left (MissingArgument "-d")
+    go _    (f    : _) | "-" `isPrefixOf` f = Left (UnknownOption f)
+    go _    (a    : _)      = Left (UnexpectedArgument a)
+
+defaultListOptions :: ListOptions
+defaultListOptions = ListOptions Nothing Nothing Nothing Nothing
+
+parseListOptions :: [String] -> Either AppError ListOptions
+parseListOptions = go defaultListOptions
+  where
+    go opts [] = Right opts
+    go opts (flag : val : rs)
+      | flag `elem` ["--status",       "-s"] = readStatus val   >>= \s -> go opts { filterStatus      = Just s } rs
+      | flag `elem` ["--priority",     "-p"] = readPriority val >>= \n -> go opts { filterPriority    = Just n } rs
+      | flag `elem` ["--min-priority"      ] = readPriority val >>= \n -> go opts { filterMinPriority = Just n } rs
+      | flag `elem` ["--contains",     "-c"] = go opts { filterContains = Just val } rs
+    go _ (flag : [])
+      | flag `elem` ["--status", "-s", "--priority", "-p", "--min-priority", "--contains", "-c"] =
+          Left (MissingArgument flag)
+    go _ (f : _) | "-" `isPrefixOf` f = Left (UnknownOption f)
+    go _ (a : _)                       = Left (UnexpectedArgument a)
+
+defaultSetOptions :: SetOptions
+defaultSetOptions = SetOptions Nothing Nothing Nothing Nothing
+
+parseSetOptions :: [String] -> Either AppError SetOptions
+parseSetOptions = go defaultSetOptions
+  where
+    go opts [] = Right opts
+    go opts (flag : val : rs)
+      | flag `elem` ["--name",     "-n"] = go opts { setName     = Just val } rs
+      | flag `elem` ["--priority", "-p"] = readPriority val >>= \n -> go opts { setPriority = Just n } rs
+      | flag `elem` ["--desc",     "-d"] = go opts { setDesc     = Just val } rs
+      | flag `elem` ["--status",   "-s"] = readStatus val   >>= \s -> go opts { setStatus   = Just s } rs
+    go _ (flag : [])
+      | flag `elem` ["--name", "-n", "--priority", "-p", "--desc", "-d", "--status", "-s"] =
+          Left (MissingArgument flag)
+    go _ (f : _) | "-" `isPrefixOf` f = Left (UnknownOption f)
+    go _ (a : _)                       = Left (UnexpectedArgument a)
+
+readPriority :: String -> Either AppError Int
+readPriority s = maybe (Left (InvalidPriority s)) Right (readMaybe s)
+
+readStatus :: String -> Either AppError Status
+readStatus s = maybe (Left (InvalidStatus s)) Right (readMaybe s)
+
+usage :: String -> String
+usage prog = unlines
+  [ "Usage: " ++ prog ++ " <command> [options]"
+  , ""
+  , "Commands:"
+  , "  new    TASK_NAME [-p PRIORITY] [-d DESCRIPTION]"
+  , "  list   [--status STATUS] [--priority N] [--min-priority N] [--contains TEXT]"
+  , "  set    TASK_DIR [--name NAME] [--status STATUS] [--priority N] [--desc DESC]"
+  , "  delete TASK_DIR"
+  , ""
+  , "Statuses: OPEN | IN_PROGRESS | CLOSED"
+  ]
+
+makeTaskMarkdown :: String -> Task -> String
+makeTaskMarkdown taskName task =
+  unlines
+    [ "# " ++ taskName
+    , ""
+    , "- Description: " ++ desc task
+    , "- Priority: "    ++ show (priority task)
+    , "- Status: "      ++ show (status task)
+    ]
+
+parseFields :: [String] -> Map String String
+parseFields = Map.fromList . concatMap parseLine
+  where
+    parseLine line =
+      case stripPrefix "- " line of
+        Nothing   -> []
+        Just rest ->
+          case break (== ':') rest of
+            (key, ':' : ' ' : val) -> [(key, val)]
+            _                      -> []
+
+readTaskRecord :: FilePath -> IO (Either AppError TaskRecord)
+readTaskRecord taskDir = do
+  let taskFile = taskDir </> "Task.md"
+  exists <- doesFileExist taskFile
+  if not exists
+    then pure (Left (TaskNotFound taskDir))
+    else do
+      contents <- readFile taskFile >>= evaluate . force
+      let ls       = lines contents
+          fields   = parseFields ls
+          taskName = case ls of
+            firstLine : _ -> fromMaybe firstLine (stripPrefix "# " firstLine)
+            []            -> taskDir
+          look k = Map.lookup k fields
+          task = Task
+            { priority = fromMaybe 0    (look "Priority" >>= readMaybe)
+            , desc     = fromMaybe ""   (look "Description")
+            , status   = fromMaybe OPEN (look "Status"   >>= readMaybe)
+            }
+      pure $ Right $ TaskRecord
+        { recordDir  = taskDir
+        , recordName = taskName
+        , recordTask = task
+        }
+
+writeTaskRecord :: TaskRecord -> IO ()
+writeTaskRecord record =
+  writeFile (recordFile record) (makeTaskMarkdown (recordName record) (recordTask record))
+
+matchesListOptions :: ListOptions -> TaskRecord -> Bool
+matchesListOptions opts record =
+  all id
+    [ maybe True (status task   ==) (filterStatus opts)
+    , maybe True (priority task ==) (filterPriority opts)
+    , maybe True (priority task >=) (filterMinPriority opts)
+    , maybe True (\needle -> map toLower needle `isInfixOf` searchableText) (filterContains opts)
+    ]
+  where
+    task = recordTask record
+    searchableText = map toLower $ unwords
+      [ recordName record
+      , desc task
+      , show (status task)
+      , show (priority task)
+      ]
+
+printTaskRecord :: TaskRecord -> IO ()
+printTaskRecord record =
+  putStrLn $
+    recordFile record ++ ":1:1: "
+      ++ "[" ++ show (status task) ++ "] "
+      ++ "P"  ++ show (priority task) ++ " "
+      ++ recordName record
+      ++ descPart
+  where
+    task = recordTask record
+    descPart = case desc task of
+      "" -> ""
+      d  -> " -- " ++ d
+
+taskDirFormat :: String
+taskDirFormat = "%y-%m-%d %H:%M:%S"
+
+isTask :: FilePath -> Bool
+isTask d = isBaseTask base && validSuffix rest
+  where
+    (base, rest) = splitAt 17 d
+    isBaseTask s =
+      length s == 17
+        && isDatePart (take 8 s)
+        && s !! 8 == ' '
+        && isTimePart (drop 9 s)
+    validSuffix ""             = True
+    validSuffix ('.' : digits) = not (null digits) && allDigits digits
+    validSuffix _              = False
+    isDatePart s =
+      length s == 8
+        && allDigits (take 2 s)
+        && s !! 2 == '-'
+        && allDigits (take 2 (drop 3 s))
+        && s !! 5 == '-'
+        && allDigits (drop 6 s)
+    isTimePart s =
+      length s == 8
+        && allDigits (take 2 s)
+        && s !! 2 == ':'
+        && allDigits (take 2 (drop 3 s))
+        && s !! 5 == ':'
+        && allDigits (drop 6 s)
+    allDigits = all (`elem` ['0' .. '9'])
+
+tasksSubdir :: FilePath
+tasksSubdir = "tasks"
+
+findTasksRoot :: IO FilePath
+findTasksRoot = do
+  hasSub <- doesDirectoryExist tasksSubdir
+  pure $ if hasSub then tasksSubdir else "."
+
+newTaskDirName :: FilePath -> IO FilePath
+newTaskDirName root = do
+  now <- getCurrentTime
+  let base = formatTime defaultTimeLocale taskDirFormat now
+  findFree base (0 :: Int)
+  where
+    findFree base n = do
+      let name      = if n == 0 then base else base ++ "." ++ show n
+          candidate = root </> name
+      exists <- doesDirectoryExist candidate
+      if not exists then pure candidate else findFree base (n + 1)
+
+loadAllRecords :: IO [TaskRecord]
+loadAllRecords = do
+  root    <- findTasksRoot
+  files   <- listDirectory root
+  results <- mapM (readTaskRecord . (root </>)) (filter isTask files)
+  pure $ sortOn (Down . priority . recordTask) [r | Right r <- results]
+
+resolveTaskDir :: FilePath -> IO FilePath
+resolveTaskDir d
+  | isTask d  = findTasksRoot >>= \root -> pure (root </> d)
+  | otherwise = pure d
+
+printChanges :: TaskRecord -> TaskRecord -> IO ()
+printChanges old new = mapM_ report3
+  [ ("name",     recordName old,                     recordName new)
+  , ("priority", show . priority . recordTask $ old,  show . priority . recordTask $ new)
+  , ("desc",     desc . recordTask $ old,             desc . recordTask $ new)
+  , ("status",   show . status . recordTask $ old,    show . status . recordTask $ new)
+  ]
+  where
+    report3 (field, oldVal, newVal)
+      | oldVal /= newVal = putStrLn $ "  " ++ field ++ ": " ++ oldVal ++ " -> " ++ newVal
+      | otherwise        = pure ()
+
+newTask :: String -> [String] -> IO ()
+newTask programName args =
+  case args of
+    [] -> do
+      putStrLn "Error: missing task name."
+      putStrLn $ usage programName
+    taskName : rest ->
+      case parseNewTaskOptions rest of
+        Left err -> do
+          putStrLn (show err)
+          putStrLn $ usage programName
+        Right opts -> do
+          root        <- findTasksRoot
+          taskDirName <- newTaskDirName root
+          let task = Task
+                { priority = fromMaybe 0  (optPriority opts)
+                , desc     = fromMaybe "" (optDesc opts)
+                , status   = OPEN
+                }
+              record = TaskRecord
+                { recordDir  = taskDirName
+                , recordName = taskName
+                , recordTask = task
+                }
+          createDirectory taskDirName
+          writeTaskRecord record
+          putStrLn $ recordFile record ++ ":1:1: Created task: " ++ taskName
+
+listTasks :: String -> [String] -> IO ()
+listTasks programName args =
+  case parseListOptions args of
+    Left err -> do
+      putStrLn (show err)
+      putStrLn $ usage programName
+    Right opts -> do
+      records <- loadAllRecords
+      let filtered = filter (matchesListOptions opts) records
+      if null filtered
+        then putStrLn "(no matching tasks)"
+        else mapM_ printTaskRecord filtered
+
+setTask :: String -> [String] -> IO ()
+setTask programName args =
+  case args of
+    [] -> putStrLn $ usage programName
+    taskDir : rest ->
+      case parseSetOptions rest of
+        Left err -> do
+          putStrLn (show err)
+          putStrLn $ usage programName
+        Right opts -> do
+          resolved <- resolveTaskDir taskDir
+          result   <- readTaskRecord resolved
+          case result of
+            Left err -> putStrLn (show err)
+            Right record -> do
+              let old = recordTask record
+                  updatedTask = old
+                    { priority = fromMaybe (priority old) (setPriority opts)
+                    , desc     = fromMaybe (desc old)     (setDesc opts)
+                    , status   = fromMaybe (status old)   (setStatus opts)
+                    }
+                  updatedRecord = record
+                    { recordName = fromMaybe (recordName record) (setName opts)
+                    , recordTask = updatedTask
+                    }
+              printChanges record updatedRecord
+              writeTaskRecord updatedRecord
+              putStrLn $ recordFile updatedRecord ++ ":1:1: Updated task: " ++ recordName updatedRecord
+
+deleteTask :: String -> [String] -> IO ()
+deleteTask programName args =
+  case args of
+    [] -> putStrLn $ usage programName
+    taskDir : _ -> do
+      resolved <- resolveTaskDir taskDir
+      result   <- readTaskRecord resolved
+      case result of
+        Left err     -> putStrLn (show err)
+        Right record -> do
+          removeDirectoryRecursive (recordDir record)
+          putStrLn $ "Deleted task: " ++ recordName record ++ " (" ++ recordDir record ++ ")"
+
+handleArgs :: String -> [String] -> IO ()
+handleArgs prog args =
+  case args of
+    "new"    : rest -> newTask    prog rest
+    "list"   : rest -> listTasks  prog rest
+    "set"    : rest -> setTask    prog rest
+    "delete" : rest -> deleteTask prog rest
+    []              -> listTasks  prog []
+    cmd      : _    -> do
+      putStrLn $ "Unknown command: " ++ cmd
+      putStrLn $ usage prog
+
+main :: IO ()
+main = do
+  prog <- getProgName
+  args <- getArgs
+  handleArgs prog args