{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE StandaloneDeriving #-}

-- | Parse strings that aren't so precise
module Data.Hourglass.FuzzyParsing
  (
    DateTime (..)
  , Time (..)
  , parseDate
  , parseDateTime
  , pDate
  , pDateTime
  , pTime
  , pDateInterval
  , tryRead
  , tryReadInt
  , DateIntervalType (..)
  , DateInterval (..)
  , weekdayToInterval
  , dateWeekDay
  , lastMonday
  , nextMonday
  , addInterval
  , negateInterval
  , minusInterval
  ) where

import Control.Applicative                  hiding (optional, (<|>))
import Data.Char                            (toLower)
import Data.Data                            (Data, Typeable)
import Data.Hourglass
import Data.List                            (intercalate)
import Data.Monoid
import Text.Parsec

import Prelude

import Data.Hourglass.FuzzyParsing.Internal

data DateIntervalType = Day | Week | Month | Year
  deriving (Eq,Show,Read,Data,Typeable)

data DateInterval = Days Int
                  | Weeks Int
                  | Months Int
                  | Years Int
  deriving (Eq,Show,Data,Typeable)

deriving instance Bounded Month
deriving instance Bounded WeekDay

-- TODO: Hourglass weekday starts on Sunday
-- | Weekday as interval from Monday, so that
-- weekdayToInterval Monday == 0 and
-- weekdayToInterval Sunday == 6.
weekdayToInterval :: WeekDay -> DateInterval
weekdayToInterval wd = Days (fromIntegral $ fromEnum wd)

lastMonday :: DateTime -> DateTime
lastMonday dt = dt `minusInterval` weekdayToInterval (dateWeekDay dt)

nextMonday :: DateTime -> DateTime
nextMonday dt = lastMonday dt `addInterval` Weeks 1

-- | Get weekday of given date.
dateWeekDay :: DateTime -> WeekDay
dateWeekDay = getWeekDay . timeGetDate

lookupMonth :: String -> Either [Month] Month
lookupMonth = uniqFuzzyMatch

euroNumDate :: Stream s m Char => ParsecT s st m Date
euroNumDate = do
  d <- pDay
  char '.'
  m <- pMonth
  char '.'
  y <- pYear
  return $ Date y m d

americanDate :: Stream s m Char => ParsecT s st m Date
americanDate = do
  y <- pYear
  char '/'
  m <- pMonth
  char '/'
  d <- pDay
  return $ Date y m d

euroNumDate' :: Stream s m Char => Int -> ParsecT s st m Date
euroNumDate' year = do
  d <- pDay
  char '.'
  m <- pMonth
  return $ Date year m d

americanDate' :: Stream s m Char => Int -> ParsecT s st m Date
americanDate' year = do
  m <- pMonth
  char '/'
  d <- pDay
  return $ Date year m d

strDate :: Stream s m Char => ParsecT s st m Date
strDate = do
  d <- pDay
  space
  ms <- many1 letter
  case lookupMonth ms of
    Left ms' -> fail $ if null ms'
                          then "unknown month: " ++ ms
                          else "ambiguous month '" ++ ms ++ "' could be: " ++ intercalate " or " (map show ms')
    Right m  -> do
      space
      y <- pYear
      notFollowedBy $ char ':'
      return $ Date y m d

strDate' :: Stream s m Char => Int -> ParsecT s st m Date
strDate' year = do
  d <- pDay
  space
  ms <- many1 letter
  case lookupMonth ms of
    Left ms' -> fail $ if null ms'
                          then "unknown month: " ++ ms
                          else "ambiguous month '" ++ ms ++ "' could be: " ++ intercalate " or " (map show ms')
    Right m  -> return $ Date year m d

time24 :: Stream s m Char => ParsecT s st m TimeOfDay
time24 = do
  h <- number 2 23
  char ':'
  m <- number 2 59
  x <- optionMaybe $ char ':'
  case x of
    Nothing -> return $ TimeOfDay h m 0 0
    Just _ -> do
      s <- number 2 59
      notFollowedBy letter
      return $ TimeOfDay h m s 0

ampm :: Stream s m Char => ParsecT s st m Int
ampm = do
  s <- many1 letter
  case uppercase s of
    "AM" -> return 0
    "PM" -> return 12
    _ -> fail "AM/PM expected"

time12 :: Stream s m Char => ParsecT s st m TimeOfDay
time12 = do
  h <- number 2 12
  char ':'
  m <- number 2 59
  x <- optionMaybe $ char ':'
  s <- case x of
            Nothing -> return 0
            Just _  -> number 2 59
  optional space
  hd <- ampm
  return $ TimeOfDay (h + fromIntegral hd) m s 0

pTime :: Stream s m Char => ParsecT s st m TimeOfDay
pTime = choice $ map try [time12, time24]

pAbsDateTime :: Stream s m Char => Int -> ParsecT s st m DateTime
pAbsDateTime year = do
  date <- choice $ map try $ map ($ year) $
    [
      const euroNumDate
    , const americanDate
    , const strDate
    , strDate'
    , euroNumDate'
    , americanDate'
    ]
  optional $ char ','
  s <- optionMaybe space
  case s of
    Nothing -> return $ DateTime date (TimeOfDay 0 0 0 0)
    Just _ -> do
      t <- pTime
      return $ DateTime date t

pAbsDate :: Stream s m Char => Int -> ParsecT s st m Date
pAbsDate year =
  choice $ map try $ map ($ year) $
    [
      const euroNumDate
    , const americanDate
    , const strDate
    , strDate'
    , euroNumDate'
    , americanDate'
    ]

intervalToPeriod :: DateInterval -> Period
intervalToPeriod (Days ds)   = mempty { periodDays   = ds}
intervalToPeriod (Weeks ws)  = mempty { periodDays   = ws*7 }
intervalToPeriod (Months ms) = mempty { periodMonths = ms }
intervalToPeriod (Years ys)  = mempty { periodYears  = ys }

-- | Add date interval to DateTime
addInterval :: DateTime -> DateInterval -> DateTime
addInterval dt@DateTime {dtDate = date} interval =
  dt { dtDate = date `dateAddPeriod` intervalToPeriod interval }

-- | Negate DateInterval value: Days 3 -> Days (-3).
negateInterval :: DateInterval -> DateInterval
negateInterval (Days n)   = Days (negate n)
negateInterval (Weeks n)  = Weeks (negate n)
negateInterval (Months n) = Months (negate n)
negateInterval (Years n)  = Years (negate n)

-- | Subtract DateInterval from DateTime.
minusInterval :: DateTime -> DateInterval -> DateTime
minusInterval date int = date `addInterval` negateInterval int

maybePlural :: Stream s m Char => String -> ParsecT s st m String
maybePlural str = do
  r <- string str
  optional $ char 's'
  return r

pDateIntervalType :: Stream s m Char => ParsecT s st m DateIntervalType
pDateIntervalType = do
  s <- choice $ map maybePlural ["day", "week", "month", "year"]
  case toLower (head s) of
    'd' -> return Day
    'w' -> return Week
    'm' -> return Month
    'y' -> return Year
    _ -> fail $ "Unknown date interval type: " ++ s

pDateInterval :: Stream s m Char => ParsecT s st m DateInterval
pDateInterval = do
  n <- many1 digit
  spaces
  tp <- pDateIntervalType
  case tp of
    Day ->   Days   `fmap` tryReadInt n
    Week ->  Weeks  `fmap` tryReadInt n
    Month -> Months `fmap` tryReadInt n
    Year ->  Years  `fmap` tryReadInt n

pRelDate :: Stream s m Char => DateTime -> ParsecT s st m DateTime
pRelDate date = do
  offs <- try futureDate
     <|> try passDate
     <|> try today
     <|> try tomorrow
     <|> yesterday
  return $ date `addInterval` offs

lastDate :: Stream s m Char => DateTime -> ParsecT s st m DateTime
lastDate now = do
    string "last"
    spaces
    try byweek <|> try bymonth <|> byyear
  where
    byweek = do
      wd <- try (string "week" >> return Monday) <|> pWeekDay
      let monday = lastMonday now
          monday' = if wd > dateWeekDay now
                      then monday `minusInterval` Weeks 1
                      else monday
      return $ monday' `addInterval` weekdayToInterval wd

    bymonth = do
      string "month"
      return $ now { dtDate = (dtDate now) { dateDay = 1 } }

    byyear = do
      string "year"
      return $ now { dtDate = (dtDate now) { dateMonth = January, dateDay = 1 } }

nextDate :: Stream s m Char => DateTime -> ParsecT s st m DateTime
nextDate now = do
    string "next"
    spaces
    try byweek <|> try bymonth <|> byyear
  where
    byweek = do
      wd <- try (string "week" >> return Monday) <|> pWeekDay
      let monday = nextMonday now
          monday' = if wd > dateWeekDay now
                      then monday `minusInterval` Weeks 1
                      else monday
      return $ monday' `addInterval` weekdayToInterval wd

    bymonth = do
      string "month"
      let nextMonth = now `addInterval` Months 1
      return nextMonth { dtDate = (dtDate nextMonth) { dateDay = 1 } }

    byyear = do
      string "year"
      let nextYear = now `addInterval` Years 1
      return nextYear { dtDate = (dtDate nextYear) { dateMonth = January, dateDay = 1 } }

pWeekDay :: Stream s m Char => ParsecT s st m WeekDay
pWeekDay = do
  w <- many1 (oneOf "mondaytueswnhrfi")
  case uniqFuzzyMatch w :: Either [WeekDay] WeekDay of
    Left ds -> fail $ if null ds
                         then "unknown weekday: " ++ w
                         else "ambiguous weekday '" ++ w ++ "' could mean: " ++ intercalate " or " (map show ds)
    Right d -> return d

futureDate :: Stream s m Char => ParsecT s st m DateInterval
futureDate = do
  string "in "
  n <- many1 digit
  char ' '
  tp <- pDateIntervalType
  case tp of
    Day ->   Days   `fmap` tryReadInt n
    Week ->  Weeks  `fmap` tryReadInt n
    Month -> Months `fmap` tryReadInt n
    Year ->  Years  `fmap` tryReadInt n

passDate :: Stream s m Char => ParsecT s st m DateInterval
passDate = do
  n <- many1 digit
  char ' '
  tp <- pDateIntervalType
  string " ago"
  case tp of
    Day ->   (Days   . negate) `fmap` tryReadInt n
    Week ->  (Weeks  . negate) `fmap` tryReadInt n
    Month -> (Months . negate) `fmap` tryReadInt n
    Year ->  (Years  . negate) `fmap` tryReadInt n

today :: Stream s m Char => ParsecT s st m DateInterval
today = do
  string "today" <|> string "now"
  return $ Days 0

tomorrow :: Stream s m Char => ParsecT s st m DateInterval
tomorrow = do
  string "tomorrow"
  return $ Days 1

yesterday :: Stream s m Char => ParsecT s st m DateInterval
yesterday = do
  string "yesterday"
  return $ Days (-1)

pByWeek :: Stream s m Char => DateTime -> ParsecT s st m DateTime
pByWeek date =
  try (lastDate date) <|> nextDate date

-- | Parsec parser for DateTime.
pDateTime :: Stream s m Char
          => DateTime       -- ^ Current date / time, to use as base for relative dates
          -> ParsecT s st m DateTime
pDateTime date =
      (try $ pRelDate date)
  <|> (try $ pByWeek date)
  <|> (try $ pAbsDateTime $ dateYear (timeGetDate date))

-- | Parsec parser for Date only.
pDate :: Stream s m Char
      => DateTime       -- ^ Current date / time, to use as base for relative dates
      -> ParsecT s st m Date
pDate date =
      (try $ timeGetDate <$> pRelDate date)
  <|> (try $ timeGetDate <$> pByWeek date)
  <|> (try $ pAbsDate $ dateYear (timeGetDate date))

-- | Parse date/time
parseDate :: DateTime  -- ^ Current date / time, to use as base for relative dates
          -> String    -- ^ String to parse
          -> Either ParseError Date
parseDate date s = runParser (pDate date) () "" s

-- | Parse date/time
parseDateTime :: DateTime  -- ^ Current date / time, to use as base for relative dates
              -> String    -- ^ String to parse
              -> Either ParseError DateTime
parseDateTime date s = runParser (pDateTime date) () "" s