path: root/app/Main.hs

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