-- Gettings things done in Haskell
--
module Main where
import System.Environment
import System.Directory
import Data.Maybe
import Data.List
import qualified Data.Set as Set
import Control.Monad
import Control.Monad.Trans
import Text.Printf
import System.IO
import System.IO.Unsafe
import System.Console.Haskeline
import System.Console.ANSI
import System.Exit

-- Possible return actions from commands
data Result =
      Tasks [(Int,String)]
    | Output [(Int,String)]
    | Print [String]
    | Plain [String]
    | None deriving (Show, Eq)

-- Available commands
commands = [("add",
             "add <task>\n" ++
             "Adds a task. Describe the contexts by adding @context,\n" ++
             "and the projects by adding :project.",
             add)
           ,("change",
             "change <id> <new task description>\n" ++
             "Changes the description of task <id>",
             change)
           ,("append", 
             "append <id> <text>\n" ++
             "Appends <text> to task <id>",
             append)
           ,("next", 
             "next <keyword>\n" ++
             "Shows the next task which has the keyword in its\n" ++
             "description. Use >next @context< or >next :project<\n" ++
             "to show the next actions for a context or project",
             next)
           ,("swap", 
             "swap <id-1> <id-2>\n" ++
             "Swaps the tasks with <id-1> and <id-2>",
             swap)
           ,("after", 
             "after <id-1> <id-2>\n" ++
             "Move task <id-2> after task <id-1>",
             after)
           ,("before", 
             "before <id-1> <id-2>\n" ++
             "Move task <id-2> before <id-1>",
             before)
           ,("projects", 
             "List all projects",
             projects)
           ,("contexts",
             "List all contexts", 
             contexts)
           ,("toend", 
             "toend <id>\n" ++
             "Moves task <id> to the end of the list",
             toend)
           ,("tostart", 
             "tostart <id>\n" ++ 
             "Moves task <id> to the beginning of the list",
             tostart)
           ,("remove", 
             "remove <id>\n" ++
             "Removes task <id>. Note, that the task is currently\n" ++
             "not removed from the file, just hidden", remove)
           ,("done", 
             "done <id-1> ... <id-n>\n" ++
             "Mark the listed tasks as done",
             done)
           ,("undone", 
             "undone <id>\n" ++
             "Mark the task <id> as not done yet",
             undone)
           ,("list",
             "list [keyword]\n" ++
             "List either all tasks or, given a keyword,\n" ++
             "only those tasks which contain the keyword",
             list)
           ,("listall",
             "List all tasks, even the ones marked as done",
             listAll)
           ,("listdone", 
             "List only tasks marked as done",
             listDone)
           ,("help", 
             "Shows this help",
             help)]
hide     = ["@done", "@remove"]
tmpFile  = "/tmp/xyzzy"


-- Get the path for the todo file
todoFile = 
    let env  = unsafePerformIO getEnvironment
        path = case (lookup "TODO" env) of
                   Just path -> path 
                   Nothing   -> let Just home = lookup "HOME" env
                                in home
    in path ++ "/" ++ ".todo.txt"

-- Handle arguments
main = do
    args <- getArgs

    if (null args) || (head args) == "daemon"
        then do putStrLn welcome
                putStrLn "Type >help< for a command overview\n"
                let set = Settings autoComplete Nothing True
                runInputT set (daemon "> ")
        else handleCommand args
    return ()      

welcome = --if you use this software drop me a short mail...
            "Getting things done in Haskell." 

-- Currently a bit inefficient, but works...
autoComplete = completeWord Nothing " \t" mkCompl 
  where mkCompl s = do
            tasks <- readTasks
            let Print ps = fromJust $ projects [] tasks
                Print cs = fromJust $ contexts [] tasks
                coms     = map (\(a,_,_) -> a) commands
                all      = ps ++ cs ++ coms
                possible = filter (isPrefixOf s) all
            return $ map (\s -> Completion s s True) possible


-- Small interactive console-application
daemon prompt = do
    line <- getInputLine prompt

    case line of
        Nothing   -> return ()
        Just line -> do liftIO $ handleLine line
                        daemon prompt
  where handleLine line = do
            if line == "exit"
                then exitSuccess
                else unless (null line) $ handleCommand $ words line


-- Handles one command
handleCommand args = do
    let command = head args
        rest    = tail args
        handler = lookup' command commands
    return ()
    case handler of
        Just f  -> use rest f
        Nothing -> use [command] next
  where lookup' _   [] = Nothing
        lookup' str ((com, _, handler):rest) =
            if com == str 
                then Just handler
                else lookup' str rest

-- Read tasks, call function with arguments and tasks
-- write file if the function changed something
use args f = do
    str <- readTasks
    let ss = f args str
    case ss of
        Just s  -> handle s 
        Nothing -> return ()

 where handle ss' = do               
        case ss' of
            Tasks ss  -> do writeFile tmpFile (unlines $ map snd ss)
                            copyFile tmpFile todoFile
            Output ss -> mapM_ toLine ss
            Print ss  -> mapM_ (putStrLn . colorTask) ss
            Plain ss  -> mapM_ putStrLn ss
            None      -> do putStrLn "?"
                            return ()
       toLine (n,s) = 
            let str = blue ++ "[%3d] " ++ normal ++ "%s\n"
            in printf str (n :: Int) (colorTask s)

-- Color codes
blue   = setSGRCode [SetColor Foreground Vivid Blue]
yellow = setSGRCode [SetColor Foreground Vivid Yellow]
green  = setSGRCode [SetColor Foreground Vivid Green]
normal = setSGRCode [SetColor Foreground Dull White]

-- Colorize a task
colorTask = unwords . map handleWord . words 
  where handleWord word = 
            case lookup (head word) table of
                Just c  -> c ++ word ++ normal
                Nothing -> word
        table = [(':', green), ('@', yellow)]

add args tasks = Just $ Tasks $ tasks ++ [(0,(unwords args))]

-- List all tasks which are not done; if arguments 
-- were given list only tasks which have these
list args tasks = Just $ Output $ filterTasks args hide tasks

listAll args tasks = Just $ Output $ filterTasks args ["@remove"] tasks
    
listDone args tasks = Just $ Output $ filterTasks ("@done":args) [] tasks

-- Show list of projects
projects args tasks = Just $ Print $ getPrefixes ":" tasks

-- Show list of contexts
contexts args tasks = 
    Just $ Print $ filter (/= "@removed") $  getPrefixes "@" tasks

-- Filter tasks which have args but not noArgs in them
filterTasks args noArgs tasks =
    filter (\t -> hasStrings t && hasNoStrings t) tasks
  where hasStrings   = filt id args
        hasNoStrings = filt not noArgs
        filt op ls t = and $ map (\s -> op $ isInfixOf s (snd t)) ls

done [] tasks = Just $ Tasks tasks
done (line:lines) tasks = 
    let newTasks = append [line, "@done"] tasks
    in case newTasks of 
                Just (Tasks nt) -> done lines nt
                Nothing -> done lines tasks

-- Mark task as deleted
remove [] tasks = Just $ Tasks tasks
remove (line:lines) tasks = 
    let newTasks = append [line, "@removed"] tasks
    in case newTasks of 
                Just (Tasks nt) -> remove lines nt
                Nothing -> remove lines tasks

-- Remove done marker
undone [line] tasks = 
    undone' line tasks
  where undone' line tasks =
            let t   = tasks !! (read line - 1)
                new = filter (/= "@done") $ words $ snd t 
            in change ([line] ++ new) tasks

-- Swap two tasks
swap args tasks = do
    let [pos1,pos2] = map read args
        a           = tasks !! (pos1-1)
        b           = tasks !! (pos2-1)
    tasks' <- foldM insert tasks [(pos1,snd b), (pos2,snd a)] 
    return $ Tasks tasks'    
  where insert t (p,v) = do (pre, _, post) <- getTask p t
                            return $ pre ++ [(p,v)] ++ post

-- Put pos2 after pos1
after args tasks = do
    let [pos1,pos2]    = map read args
        a              = tasks !! (pos2-1)
        delta          = if pos1 < pos2 then 0 else -1
    (prea,_,posta) <- getTask pos2 tasks 
    result         <- append (prea++posta) (pos1+delta,snd a)
    return $ Tasks result
  where append t (p,v) = do (pre, old, post) <- getTask p t
                            return $ pre ++ [old] ++ [(p,v)] ++ post


-- Put pos2 before pos1
before args tasks = do
    let [pos1,pos2] = map read args
        a           = tasks !! (pos2-1)
        delta       = if pos1 < pos2 then 0 else -1
    (prea,_,posta) <- getTask pos2 tasks 
    result         <- append (prea++posta) (pos1+delta,snd a)
    return $ Tasks result
    where append t (p,v) = do (pre, old, post) <- getTask p t
                              return $ pre ++ [(p,v)] ++ [old] ++ post

-- Find the next action
next args tasks =
    let all = filterTasks args hide tasks
    in Just $ if null all || null args
        then None
        else Output [head all]

-- Append some text on line
append (line:desc) tasks = do
    (pre,(p,str),post) <- getTask (read line) tasks
    return $ Tasks $ pre ++ [(p,str ++ " " ++ unwords desc)] ++ post

-- Move task to end of list
toend [line] tasks = do
    (pre,t,post) <- getTask (read line) tasks
    return $ Tasks $ pre ++ post ++ [t]

-- Move task to beginning of list
tostart [line] tasks = do
    (pre,t,post) <- getTask (read line) tasks
    return $ Tasks $ t : pre ++ post

-- Change a line
change (line:desc) tasks = do
    (pre,(p,_),post) <- getTask (read line) tasks
    return $ Tasks $ pre ++ [(p,unwords desc)] ++ post       


-- Show help
help args tasks = 
    Just $ Plain $ welcome : map f commands
  where f (c,h,_) = c ++ ":\n" ++ h ++ "\n"

-- Helper function
getTask n tasks = 
    if length tasks < n 
        then Nothing
        else Just (take (n-1) tasks, tasks !! (n-1), drop n tasks)
   
getPrefixes pre tasks =   
    let ws  = filter (isPrefixOf pre) . words . intercalate " " $
              map snd tasks   
        set = foldl (flip Set.insert) Set.empty ws
    in Set.toList set

-- Read tasks out of the file
readTasks = (zip [1..] . lines) `fmap` readFile todoFile