-- Gettings things done in Haskell
--
module Main where
import System.Environment
import System.Directory
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]
    | None deriving (Show, Eq)

-- Available commands
commands = [("add"      , "task @context :project" , add)
           ,("change"   , "<id> task..."           , change)
           ,("append"   , "<id> text..."           , append)
           ,("next"     , ":project | @context"    , next)
           ,("swap"     , "<id> <id>"              , swap)
           ,("after"    , "<id> <id>"              , after)
           ,("before"   , "<id> <id>"              , before)
           ,("projects" , ""                       , projects)
           ,("contexts" , ""                       , contexts)
           ,("toend"    , "<id>"                   , toend)
           ,("tostart"  , "<id>"                   , tostart)
           ,("remove"   , "<id>"                   , remove)
           ,("done"     , "<id>"                   , done)
           ,("undone"   , "<id>"                   , undone)
           ,("listall"  , ""                       , listAll)
           ,("help"     , ""                       , help)
           ,("listdone" , ""                       , listDone)
           ,("daemon"   , ""                       , done)
           ,("list"     , ":project | @contex | "  , list)]
hide     = ["@done", "@remove"]
todoFile = let home = unsafePerformIO (getEnv "HOME")
           in home ++ "/" ++ ".todo.txt"
tmpFile  = "/tmp/xyzzy"


-- Handle arguments
main = do
    args <- getArgs
    when (null args) $ error "no command given."

    if (head args) == "daemon"
        then do let set = Settings autoComplete Nothing True
                runInputT set daemon
        else handleCommand args
    return ()      


-- Auto-completion
-- Currently a bit inefficient, but works...
autoComplete = completeWord Nothing " \t" mkCompl 
  where mkCompl s = do
            tasks <- readTasks
            let Print ps = projects [] tasks
                Print cs = 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 console-application
daemon = do
    line <- getInputLine "> "

    case line of
        Nothing   -> return ()
        Just line -> do liftIO $ handleLine line
                        daemon
  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
    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
        Tasks ss  -> do writeFile tmpFile (unlines $ map snd ss)
                        copyFile tmpFile todoFile
        Output ss -> mapM_ toLine ss
        Print ss  -> mapM_ (putStrLn . colorTask) ss
        None      -> do putStrLn "?"
                        return ()
  where 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)]

-- Append a task
add args tasks = 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 = Output $ filterTasks args hide tasks

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

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

-- Show list of contexts
contexts args tasks = 
    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

-- Mark task as done
done [line] = append [line, "@done"] 

-- Mark task as deleted
remove [line] = append [line, "@removed"] 

-- Remove done marker
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 =
    let [pos1,pos2] = map read args
        a           = tasks !! (pos1-1)
        b           = tasks !! (pos2-1)
        tasks'      = foldl insert tasks [(pos1,snd b), (pos2,snd a)] 
    in Tasks tasks'    
  where insert t (p,v) = let (pre, _, post) = getTask p t
                         in pre ++ [(p,v)] ++ post

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

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

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

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

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

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

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


-- Show help
help args tasks = 
    let msg = "Getting things done in Haskell\n"
    in Print $ msg : map f commands
  where f (c,h,_) = c ++ "\t  " ++ h

-- Helper function
getTask n tasks = (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