-- a simple gtd-inspired tasklist manager
-- pesco 2010, isc license

import Data.Char(isSpace)
import Data.List
import Data.Time
import Text.Parsers.Frisby
import Text.Parsers.Frisby.Char
import Control.Monad(liftM)
import System.IO(hPutStrLn, stderr)
import Data.Maybe(isJust)
import System.Environment

-- pesco's really cheap and simple flags and options (tm)
clparts = getArgs >>= return . (\(a,b) -> (a,drop 1 b)) . break (=="--")
getargs = clparts >>= \(a,b)-> return ([h:t| h:t<-a, h/='-' || null t] ++ b)
getflags = clparts >>= \(a,_)-> return (concat [t| '-':t <- a])
getflag x = getflags >>= return . elem x
getenv f v x = catch (getEnv v >>= return . f) (\_ -> return x)


newtype Date = D [Int]                      -- [year,month,day]
    deriving (Eq,Ord,Show)

data Task = T { t_due       :: Maybe Date
              , t_activate  :: Maybe Date
              , t_marked    :: Bool
              , t_text      :: String
              }
    deriving Show

t_tags    :: Task -> [String]
t_active  :: Date -> Task -> Bool
t_stalled :: Date -> Task -> Bool

todo :: Date -> [[Task]] -> [[Task]]
stalled :: Date -> [[Task]] -> [[Task]]
projects :: [[Task]] -> [String]

t_tags = filter ((=='#').head) . words . t_text
t_active today t = t_marked t || t_activated today t
t_stalled today t = not (t_marked t) && isJust (t_activate t)

t_activated :: Date -> Task -> Bool
t_activated today = maybe False (today >=) . t_activate

todo today = filter (not.null) . map (filter (t_active today))
stalled today = filter (not.null) . map (filter (t_stalled today))
projects = nub . concatMap (concatMap t_tags)

formattasks :: Date -> [[Task]] -> String
parsetasks  :: Date -> String -> [[Task]]

parsetasks today = map (map (parsetask today)) . grouplines . lines
formattasks today = unlines . concat . intersperse [""]
    . map (map (formattask today))

formattask :: Date -> Task -> String 
parsetask  :: Date -> String -> Task
grouplines :: [String] -> [[String]]

formattask today t = (if isdue then boldface else id) $
        "o " ++ maybe "" ((++"! ") . formatdate today) (t_due t) ++ t_text t
    where
    isdue = maybe False (today>=) (t_due t)

formatdate :: Date -> Date -> String
formatdate today (D [y,m,d]) = show d ++ "." ++ show m ++ "."
    ++ if guessyear today m d == y then "" else show y

formatdate_iso :: Date -> String
formatdate_iso (D [y,m,d]) = show y ++ "-" ++ show2 m ++ "-" ++ show2 d
    where
    show2 n = if n<10 then ('0':show n) else show n

grouplines = filter (any nonemp) . groupBy eq
    where
    eq a b = nonemp a && nonemp b
    nonemp = not . all isSpace

parsetask today line = filldates (runPeg p_task line)
    where
    filldates t = t { t_due      = liftM filldate (t_due t)
                    , t_activate = liftM filldate (t_activate t) }
    filldate (D [m,d]) = D [guessyear today m d, m, d]
    filldate d = d

guessyear (D [y0,m0,_]) m _ = minimumBy (on dist) candidates
    where
    on f x y = compare (f x) (f y)
    candidates = [y0-1, y0, y0+1]
    dist y = abs ((y-y0)*12 + m-m0)

(<:)  :: P s x -> P s [x] -> P s [x]
(<:>) :: P s x -> P s x -> P s [x]
infixr <:>, <:

p <: q = p <> q ## \(x,xs) -> x:xs
p <:> q = p <> q ## \(x,y) -> [x,y]


p_date :: PM s (P s Date)
p_date = do
    dig2 <- newRule $ ((digit <:> digit) // (digit ## return)) ## read
    year <- newRule $ many1 digit ## read
    mon  <- newRule $ dig2 `onlyIf` (\m -> m>0 && m<=12)
    day  <- newRule $ dig2 `onlyIf` (\d -> d>0 && d<=31)

    isodate  <- newRule $ (year <<- char '-') <: (mon <<- char '-') <:> day

    gershort <- newRule $ ((day <<- char '.') <:> (mon <<- char '.')) ## reverse
    gerlong  <- newRule $ gershort <> year ## \(md,y) -> y:md
    gerdate  <- newRule $ gerlong // gershort

    usshort  <- newRule $ ((mon <<- char '/') <:> day) ## reverse
    uslong   <- newRule $ usshort <> char '/' ->> year ## \(md,y) -> y:md
    usdate   <- newRule $ uslong // usshort

    return ((isodate // gerdate // usdate) ## D)

p_due :: PM s (P s Date)
p_due = do
    date <- p_date
    return (date <<- char '!')

p_activate :: PM s (P s Date)
p_activate = do
    date <- p_date
    return (date <<- char '>')

data Taskpart = Due Date
              | Activate Date
              | Text String

dnm = doesNotMatch
eol = oneOf "\n\r"
spcs = many (dnm eol ->> space)

p_task :: PM s (P s Task)
p_task = do
    mark     <- newRule $ isMatch (char '>' ->> spcs)
    due      <- p_due
    activate <- p_activate
    nontext  <- newRule $ (due ## Due) // (activate ## Activate)
    txt      <- newRule $ many1 (dnm eol ->> dnm nontext ->> anyChar)
    taskpart <- newRule $ (spcs ->> nontext <<- spcs) // (txt ## Text)
    rest     <- newRule $ many taskpart
    task     <- newRule $ mark <> rest ## mktask
    return task
    where
    mktask (m,xs) = T { t_due      = mmin [d | Due d <- xs]
                      , t_activate = mmin [d | Activate d <- xs]
                      , t_marked   = m
                      , t_text     = unwords [t | Text t <- xs]
                      }
    mmin [] = Nothing
    mmin xs = Just (minimum xs)

main = do
    today <- getenv (runPeg p_date) "today" =<< getcurdate
    input <- getplan
    let tasks  = parsetasks today input
        active = todo today tasks
        later  = stalled today tasks
        output = formattasks today active
        tags   = projects tasks
        atags  = projects active
        stags  = projects later
        itags  = tags \\ (atags ++ stags)   -- idle tags
    mapM_ (hPutStrLn stderr . idlewarning) itags
    putStrLn (boldface "TODO" ++ replicate 32 ' ' ++ formatdate_iso today)
    putStrLn ""
    putStr output

idlewarning t = "warning: idle project " ++ t

boldface = concatMap (\c -> [c,'\b',c])

getplan = do
    plan <- getenv id "PLAN"
            =<< getenv (++ "/.plan") "HOME"
            =<< return "-"
    if plan=="-"
        then getContents
        else readFile plan

-- gah, all the crap they make you put up with these days
getcurdate :: IO Date
getcurdate = do
    utc <- getCurrentTime
    tz  <- getCurrentTimeZone
    let local   = utcToLocalTime tz utc
        (y,m,d) = toGregorian (localDay local)
    return $ D [fromIntegral y,m,d]