{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE TemplateHaskell    #-}

-- | Parse strings that aren't so precise
module Data.Dates.Parsing
  (
    Config (..)
  , DateTime (..)
  , DateInterval (..)
  , Time (..)
  , defaultConfig
  , defaultConfigIO
  , parseDate
  , parseDateTime
  , pAbsDateTime
  , pAbsDate
  , pDate
  , pDateTime
  , pTime
  , pDateInterval
  , weekdayToInterval
  , dateWeekDay
  , getStartOfThisWeek
  , getStartOfNextWeek
  , lastDate
  , nextDate
  , addInterval
  , negateInterval
  , minusInterval
  , dateInFormat
  , extractDates, extractDatesY, extract
  ) where

import Control.Lens
import Control.Monad

import Data.Char                            (toLower)
import Data.Data                            (Data, Typeable)
import Data.Hourglass
import Data.List                            (intercalate, find)
import Text.Parsec
import Text.Read (readMaybe)

import Time.System (dateCurrent)

import Data.Dates.Parsing.Internal

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

data Config = Config
    { _now            :: DateTime -- ^ "Current" date/time, to use as base for relative dates
    , _startOfWeekDay :: WeekDay} -- ^ Which day of the week to consider the start day

makeLenses ''Config

defaultConfig :: DateTime -> Config
defaultConfig now' = Config
  {
    _now = now'
  , _startOfWeekDay = Monday
  }

defaultConfigIO :: IO Config
defaultConfigIO = defaultConfig <$> dateCurrent

-- | Weekday as interval from the configure start of the week
weekdayToInterval :: Config -> WeekDay -> DateInterval
weekdayToInterval c wd =
  Days (fromIntegral $ fromEnum wd - fromEnum (c^.startOfWeekDay))

getStartOfThisWeek :: Config -> DateTime
getStartOfThisWeek c = (c^.now) `minusInterval` weekdayToInterval c (dateWeekDay (c^.now))

getStartOfNextWeek :: Config -> DateTime
getStartOfNextWeek c = getStartOfThisWeek c `addInterval` Weeks 1

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

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

time :: Stream s m Char => Hours -> ParsecT s st m TimeOfDay
time hMax = do
  h <- number 2 hMax
  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

time24 :: Stream s m Char => ParsecT s st m TimeOfDay
time24 = time 23
time12 :: Stream s m Char => ParsecT s st m TimeOfDay
time12 = time 12

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"


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

newtype DateFormat = DateFormat [(DatePart, String)]
data DatePart = D | M | Y
data DatePartVal = DV Int | MV Month | YV Int

datePart :: Stream s m Char => DatePart -> ParsecT s st m DatePartVal
datePart M = MV <$> pMonth
datePart D = DV <$> pDay
datePart Y = YV <$> pYear

isYV (YV _) = True
isYV _ = False

isMV (MV _) = True
isMV _ = False

isDV (DV _) = True
isDV _ = False

monthPart :: [DatePartVal] -> Month
monthPart = maybe January (\(MV m) -> m) . find isMV

dayPart :: [DatePartVal] -> Int
dayPart = maybe 1 (\(DV d) -> d) . find isDV

yearPart :: Int -> [DatePartVal] -> Int
yearPart year = maybe year (\(YV y) -> y) . find isYV

makeFormat :: String -> [DatePart] -> DateFormat
makeFormat sep parts = DateFormat $ zip parts $ repeat sep

dateInFormat year (DateFormat parts) = do
    partVals <- zipWithM go [1..] parts

    pure $ Date (yearPart year partVals) (monthPart partVals) (dayPart partVals)
    where
        go i (p, sep)
            -- The last one doesn't need to have a separator.
            | i == length parts = datePart p
            | otherwise = do
                v <- datePart p
                string sep
                pure v

euroNumDate = makeFormat "." [D, M, Y]
writtenDate = DateFormat [(M, " "), (D, ","), (Y, "")]
americanDate = makeFormat "/" [M, D, Y]
dashDate = makeFormat "-" [Y, M, D]
strDate = makeFormat " " [D, M, Y]
spaceDate = makeFormat " " [D, M]
spaceDateMD = makeFormat " " [M, D]

dotDateMonth = makeFormat "." [D, M]
dashDateMonth = makeFormat "-" [M, D]
slashDateMonth = makeFormat "/" [M, D]

pAbsDateTime :: Stream s m Char => Int -> ParsecT s st m DateTime
pAbsDateTime year = do
  date <- pAbsDate year
  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 . dateInFormat year)
    [euroNumDate, americanDate, strDate, writtenDate, dashDate,
     dotDateMonth, dashDateMonth, slashDateMonth, spaceDate, spaceDateMD]

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 (Int -> DateInterval)
pDateIntervalType = do
  s <- choice $ map maybePlural ["day", "week", "month", "year"]
  case toLower (head s) of
    'd' -> return Days
    'w' -> return Weeks
    'm' -> return Months
    'y' -> return Years
    _ -> fail $ "Unknown date interval type: " ++ s

pDateInterval :: Stream s m Char => ParsecT s st m DateInterval
pDateInterval = do
  maybeN <- readMaybe <$> many1 digit

  case maybeN of
    Nothing -> fail "Noperino."
    Just n -> do
      spaces
      tp <- pDateIntervalType
      pure $ tp n

pRelDate :: Stream s m Char => Config -> ParsecT s st m DateTime
pRelDate c = do
  offs <- try futureDate
     <|> try passDate
     <|> try today
     <|> try tomorrow
     <|> yesterday
  return $ (c^.now) `addInterval` offs

lastDate :: Stream s m Char => Config -> ParsecT s st m DateTime
lastDate c = do
    string "last"
    spaces
    try byweek <|> try bymonth <|> byyear
  where
    startOfWeekDay' = c^.startOfWeekDay
    now' = c^.now
    byweek = do
      wd <- try (string "week" >> return startOfWeekDay') <|> pWeekDay
      let lastWeekStart = getStartOfThisWeek c `minusInterval` Weeks 1
      return $ lastWeekStart `addInterval` weekdayToInterval c wd

    bymonth = do
      string "month"
      let lastMonth = now' `minusInterval` Months 1
      return $ lastMonth { dtDate = (dtDate lastMonth) { dateDay = 1 } }

    byyear = do
      string "year"
      let lastYear = now' `minusInterval` Years 1
      return $ lastYear { dtDate = (dtDate lastYear) { dateMonth = January, dateDay = 1 } }

nextDate :: Stream s m Char => Config -> ParsecT s st m DateTime
nextDate c = do
    string "next"
    spaces
    try byweek <|> try bymonth <|> byyear
  where
    startOfWeekDay' = c^.startOfWeekDay
    now' = c^.now
    byweek = do
      wd <- try (string "week" >> return startOfWeekDay') <|> pWeekDay
      let nextWeekStart = getStartOfNextWeek c
      return $ nextWeekStart `addInterval` weekdayToInterval c 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 "
  maybeN <- readMaybe <$> many1 digit

  case maybeN of
    Nothing -> fail "Noperino."
    Just n -> do
      char ' '
      tp <- pDateIntervalType
      pure $ tp n

passDate :: Stream s m Char => ParsecT s st m DateInterval
passDate = do
  maybeN <- readMaybe <$> many1 digit

  case maybeN of
    Nothing -> fail "Noperino."
    Just n -> do
      char ' '
      tp <- pDateIntervalType
      string " ago"
      pure $ tp $ negate 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 => Config -> ParsecT s st m DateTime
pByWeek c =
  try (lastDate c) <|> nextDate c

-- | Parsec parser for DateTime.
pDateTime :: Stream s m Char
          => Config
          -> ParsecT s st m DateTime
pDateTime c =
      try (pRelDate c)
  <|> try (pByWeek c)
  <|> try (pAbsDateTime (dateYear (timeGetDate (c^.now))))

-- | Parsec parser for Date only.
pDate :: Stream s m Char
      => Config
      -> ParsecT s st m Date
pDate c =
      try (timeGetDate <$> pRelDate c)
  <|> try (timeGetDate <$> pByWeek c)
  <|> try (pAbsDate $ dateYear (timeGetDate (c^.now)))

-- | Parse date/time
parseDate :: Config
          -> String -- ^ String to parse
          -> Either ParseError Date
parseDate c = runParser (pDate c) () ""

-- | Parse date/time
parseDateTime :: Config
              -> String -- ^ String to parse
              -> Either ParseError DateTime
parseDateTime c = runParser (pDateTime c) () ""

-- | Same as extractDatesY, but will get the current year from the system, so you don't have to provide it.
extractDates :: String -> IO [Date]
extractDates str = do
    c <- defaultConfigIO

    pure $ extractDatesY (dateYear (timeGetDate (c ^. now))) str

-- | Extract dates from a string, with the first argument being the current year (used for things like "Jan 18").
--
-- >>> extractDatesY 2018 "The party will be on 6/9"
-- [Date 2018 June 9]
extractDatesY :: Int -> String -> [Date]
extractDatesY y str =
    case parse (extract (pAbsDate y)) "" str of
        Left err -> error $ show err
        Right dates -> dates

extract :: Stream s m Char => ParsecT s st m a -> ParsecT s st m [a]
extract parser = Text.Parsec.many loop
    where
        loop = try parser <|> (anyChar >> loop)