module Data.DateTime.Parser(
    Format(..), expr, time, weekday, month,
    duration, date, parseDate, repetition,
    exprs, limExpr) where
import Text.Parsec
import Data.DateTime
import Data.Time.Clock (utctDayTime)
import Data.Duration
import Control.Concatenative
import Control.Monad
import Control.Monad.Reader

data Format = US | World deriving (Eq, Show, Read)
type Parser = ParsecT String () (Reader (Format,DateTime))
a <<| b = a >> (return b)

exprs :: Parser [DateTime]
exprs = liftM2 (++) expr (liftM concat $ many (char ',' >> expr))

expr :: Parser [DateTime]
expr = do
    t <- option 0 (try time)
    optional spaces
    d <- optionMaybe (try date)
    d' <- case d of
            Nothing -> asks (\x-> (snd x){utctDayTime=fromInteger 0})
            (Just a) -> return a
    t' <- option t (optional spaces >> try time)
    let dt = addMinutes t' d'
    optional spaces
    r <- optionMaybe (repetition dt)
    return $ case r of
        Nothing -> [dt]
        (Just a) -> a

limExpr :: Parser [DateTime]
limExpr = do
     t <- option 0 (try time)
     d <- asks (\x-> (snd x){utctDayTime=fromInteger 0})
     let dt = addMinutes t d
     optional spaces
     r <- optionMaybe (repetition dt)
     return $ case r of
        Nothing -> [dt]
        (Just a) -> a

time :: Parser Integer
time = do
    a <- digit
    b <- optionMaybe digit
    let hours = ifte (==12) (const 0) id (case b of {(Just i)-> read [a,i]; Nothing -> read [a]}) *60
    char ':'
    c <- digit
    d <- digit
    let minutes = read [c,d]
    amPm <- optionMaybe . try $
        spaces >> (((string "AM" <|> string "am") <<| 0) <|> ((string "PM" <|> string "pm") <<|720))
    return $ case amPm of
        (Just a) -> hours + minutes + a
        Nothing -> ifte (<= 360) (+720) id (hours + minutes)

weekday :: Parser Int
weekday = (string "Monday" <<|1) <|> try (string "Tuesday" <<|2) <|> (string "Wednesday" <<|3)
            <|> (string "Thursday" <<|4) <|> (string "Friday" <<|5)
            <|> try (string "Saturday" <<|6) <|> (string "Sunday" <<|0)

month :: Parser Int
month = try (string "January" <<|1) <|> (string "February" <<|2) <|> try (string "March" <<|3)
        <|> try (string "April" <<|4) <|> (string "May" <<|5) <|> try (string "June" <<|6)
        <|> (string "July" <<|7) <|> (string "August" <<|8) <|> (string "September" <<|9)
        <|> (string "October" <<|10) <|> (string "November" <<|11) <|> (string "December" <<|12)

duration :: Parser Days
duration = (string "day" <<|Day) <|> (string "week" <<|Week) <|> (string "month" <<|Month) <|> (string "year" <<|Year)

date :: Parser DateTime
date = do
    c <- asks snd
    let dur = duration >>= (return . toDuration 1) >>= (\x-> return $ x c)
    let day = liftM (fixTime (addWeeks 1 c)) weekday
    (string "next " >> (day <|> dur)) <|> parseDate

parseDate = slashed <|> long where
    digits :: (Read a, Integral a) => Parser a
    digits = liftM read (many1 digit)
    slashed = do
        a <- digits :: Parser Int
        b <- char '/' >> digits :: Parser Int
        c <- char '/' >> digits :: Parser Integer
        (y,_,_) <- asks (toGregorian' . snd)
        f <- asks ((==US) . fst)
        return $ uncurry (fromGregorian' (y - (y `mod` 1000) + c)) $ if f then (a,b) else (b,a)
    long = do
        optional $ try (weekday >> spaces)
        m <- month
        d <- spaces >> digits
        y <- optionMaybe (char ',' >> spaces >> digits)
        (c,_,_) <- asks (toGregorian' . snd)
        return $ fromGregorian' (maybe c id y) m d

repetition :: DateTime -> Parser [DateTime]
repetition t = do
    (c,t') <- weekRep <|> everyRep
    l <- optionMaybe $ (string " for " >> numbered) <|> (string " until " >> date >>= (\x-> return (const x,t)))
    l' <- return $ case l of {Nothing -> Nothing; (Just (a,_)) -> Just a}
    return (assemble t' c l') where
        weekRep = do {a <- nDay 1; char 's' >> return a}
        everyRep = string "every " >> (numbered <|> othDur <|> nDay 1 <|> nDur 1)
        nDur n = duration >>= (\x-> return (toDuration n x,t))
        nDay n = weekday >>= (\x->return (toDuration n Week, fixTime t x))
        othDur = string "other " >> (nDay 2 <|> nDur 2)
        numbered = do
            a <- many1 digit
            a' <- return $ read a
            b <- spaces >> (nDur a' <|> nDay a')
            optional (char 's')
            return b