{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ViewPatterns, ConstraintKinds, TupleSections, RecordWildCards #-}

module Postdelay.TimeSpec
  ( pTimeSpec
  , pTimeZone
  , TimeCtx(..)
  ) where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader.Class
import Control.Monad.Error.Class

import Text.Parsec.Char hiding (digit)
import qualified Text.Parsec.Char as Parsec (digit)
import Text.Parsec.Prim
import Text.Parsec.Combinator
import Text.Parsec.Error (ParseError(..))
import Text.Read (readMaybe)

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

import Data.Time
import Data.Time.Calendar.WeekDate
import Data.Time.Zones
import Data.Function
import Data.Maybe
import Data.Foldable
import Data.Ord
import Data.List
import Data.Tuple
import Data.Bool

import Control.Exception (IOException)

import Debug.Trace


type MonadTP m = (MonadIO m, MonadReader TimeCtx m)

data TimeCtx = TimeCtx
               { baseTime :: UTCTime
               , tz :: Either TimeZone TZ
               }


spaced :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a
spaced p = spaces *> p <* spaces

string' :: Stream s m Char => String -> ParsecT s u m String
string' = mapM $ satisfy . ((==) `on` CI.mk)

choice' :: (Stream s m t, Foldable f) => f (ParsecT s u m a) -> ParsecT s u m a
choice' (toList -> f)
  | [p]    <- f = p
  | (p:ps) <- f = try p <|> choice' ps
  | otherwise   = mzero

strChoice' :: Stream s m Char => [String] -> ParsecT s u m String
strChoice' = choice' . map string' . sortBy (comparing $ Down . length)

natural :: (Stream s m Char, Num a) => ParsecT s u m a
natural = foldl' (\init last -> init * 10 + last) 0 <$> many1 digit

decimal :: (Stream s m Char, Num a, Fractional a) => ParsecT s u m a
decimal = do
  w <- foldl' (\init last -> init * 10 + last) 0 <$> many1 digit
  f <- option 0 $ do
    char '.'
    foldr' (\head tail -> head + tail / 10) 0 <$> many1 digit
  return $ w + f / 10
  
digit :: (Stream s m Char, Num a) => ParsecT s u m a
digit = fromIntegral . (\c -> fromEnum c - fromEnum '0') <$> Parsec.digit

ensure :: MonadPlus m => (a -> Bool) -> a -> m a
ensure p x = bool (const mzero) return (p x) $ x


pTimeSpec :: MonadTP m => ParsecT String () m UTCTime
pTimeSpec = choice' [ flip addUTCTime <$> spaced pSpecBase <*> spaced pSpecOffset <?> "Absolute time + offset"
                    , flip addUTCTime <$> asks baseTime <*> spaced pSpecOffset <?> "Time offset"
                    , spaced pSpecBase <?> "Absolute time"
                    ]
            <* eof <?> "Time specification"

pSpecBase :: forall m. MonadTP m => ParsecT String () m UTCTime
pSpecBase = choice'
  [ utcTime <$> spaced pDate <*> spaced pTime
  , flip utcTime <$> spaced pTime <*> spaced pDate
  , do
      proto@(UTCTime{..}) <- utcTime <$> (utctDay <$> asks baseTime) <*> spaced pTime
      now <- asks baseTime
      return $ if proto < now
               then UTCTime (succ utctDay) utctDayTime
               else proto
  , utcTime <$> spaced pDate <*> ((dayFractionToTimeOfDay 0, ) <$> asks tz) 
  , spaced (string' "now") *> asks baseTime
  ] <?> "Base specification"
  where
    utcTime :: Day -> (TimeOfDay, Either TimeZone TZ) -> UTCTime
    utcTime d (t, Right tz) = localTimeToUTCTZ tz (LocalTime d t)
    utcTime d (t, Left  tz) = localTimeToUTC   tz (LocalTime d t)

pSpecOffset :: MonadTP m => ParsecT String () m NominalDiffTime
pSpecOffset = (+) <$> pSpecOffset' <*> option 0 (try (many $ space <|> char ',' <|> char ';') >> pSpecOffset)
  where
    pSpecOffset' = option id (spaced pSign) <*> ((*) <$> spaced pNumber <*> spaced pSpecOffsetConst) <?> "Time offset"
    pNumber = fromInteger <$> natural <?> "Offset multiplier"

pSign :: MonadTP m => ParsecT String () m (NominalDiffTime -> NominalDiffTime)
pSign = choice [ id     <$ char '+'
               , negate <$ char '-'
               ] <?> "Offset sign"

pSpecOffsetConst :: MonadTP m => ParsecT String () m NominalDiffTime
pSpecOffsetConst = choice' [ 1e-12           <$ strChoice' [ "ps"
                                                           , "picosecond"
                                                           , "picoseconds"
                                                           ]
                           , 1e-9            <$ strChoice' [ "ns"
                                                           , "nanosecond"
                                                           , "nanoseconds"
                                                           ]
                           , 1e-6            <$ strChoice' [ "us", "µs"
                                                           , "microsecond"
                                                           , "microseconds"
                                                           ]
                           , 1e-3            <$ strChoice' [ "ms"
                                                           , "millisecond"
                                                           , "milliseconds"
                                                           ]
                           , 1e-2            <$ strChoice' [ "ds"
                                                           , "decisecond"
                                                           , "deciseconds"
                                                           ]
                           , 1e-1            <$ strChoice' [ "cs"
                                                           , "centisecond"
                                                           , "centiseconds"
                                                           ]
                           , 1               <$ strChoice' [ "s"
                                                           , "second"
                                                           , "seconds"
                                                           ]
                           , 60              <$ strChoice' [ "min"
                                                           , "minute"
                                                           , "minutes"
                                                           ]
                           , 3600            <$ strChoice' [ "h"
                                                           , "hour"
                                                           , "hours"
                                                           ]
                           , 24 * 3600       <$ strChoice' [ "d"
                                                           , "day"
                                                           , "days"
                                                           ]
                           , 7 * 24 * 3600   <$ strChoice' [ "week"
                                                           , "weeks"
                                                           ]
                           , 30 * 24 * 3600  <$ strChoice' [ "month"
                                                           , "months"
                                                           ]
                           , 365 * 24 * 3600 <$ strChoice' [ "year"
                                                           , "years"
                                                           ]
                           ] <?> "Offset unit"

pDate :: MonadTP m => ParsecT String () m Day
pDate = choice' [ do
                    (m, d) <- choice' [ do
                                          m <- spaced pMonthName
                                          d <- spaced natural
                                          optional . spaced $ char ','
                                          return (m, d)
                                      , fmap swap . (,) <$> spaced natural <*> spaced pMonthName
                                      ]
                    y <- spaced natural
                    fromGregorian' y m d
                , do
                    now <- asks baseTime
                    (m, d) <- choice' [ (,) <$> spaced pMonthName <*> spaced natural
                                      , fmap swap . (,) <$> spaced natural <*> spaced pMonthName
                                      ]
                    let
                      (y, _, _) = toGregorian $ utctDay now
                    proto <- fromGregorian' y m d
                    if proto < utctDay now
                      then fromGregorian' (y + 1) m d
                      else return proto
                , do
                    now <- asks baseTime
                    optional $ spaces *> pNext <* many1 space
                    d <- spaced pWeekdayName
                    let
                      (y, w, _) = toWeekDate $ utctDay now
                    proto <- fromWeekDate' y w d
                    if proto < utctDay now
                      then maybe (fromWeekDate' (y + 1) 1 d) return $ fromWeekDateValid y (w + 1) d
                      else return proto
                , do
                    spaced $ string' "today"
                    utctDay <$> asks baseTime
                , do
                    spaced $ string' "tomorrow"
                    succ . utctDay <$> asks baseTime
                , do
                    y <- natural
                    char '-'
                    m <- natural
                    char '-'
                    d <- natural
                    fromGregorian' y m d
                , do
                    d <- natural
                    char '.'
                    m <- natural
                    char '.'
                    y <- natural
                    fromGregorian' y m d
                , do
                    m <- natural
                    char '/'
                    d <- natural
                    char '/'
                    y <- natural
                    fromGregorian' y m d
                , do
                    ds <- many1 digit
                    when (length ds < 5) $ fail "Insufficient digits to interpret as concatenated date"
                    let
                      d2 : d1 : m2 : m1 : ys = reverse ds
                      d = 10 * d1 + d2
                      m = 10 * m1 + m2
                      y = foldl' (\init last -> init * 10 + last) 0 . map fromIntegral $ reverse ys
                    fromGregorian' y m d
                , do
                    pNext
                    many1 space
                    fmap utctDay . addUTCTime <$> pSpecOffsetConst <*> asks baseTime
               ] <?> "Day specification"
  where
    fromGregorian' y m d = maybe (fail "Invalid gregorian date") return $ fromGregorianValid y m d
    fromWeekDate' y w d = maybe (fail "Invalid iso8601 date") return $ fromWeekDateValid y w d
    pNext = string' "next"

pMonthName :: MonadTP m => ParsecT String () m Int
pMonthName = choice' (zipWith (<$) [1..] [ strChoice' [ "January", "Jan" ]
                                         , strChoice' [ "Febuary", "Feb" ]
                                         , strChoice' [ "March", "Mar" ]
                                         , strChoice' [ "April", "Apr" ]
                                         , strChoice' [ "May" ]
                                         , strChoice' [ "June", "Jun" ]
                                         , strChoice' [ "July", "Jul" ]
                                         , strChoice' [ "August", "Aug" ]
                                         , strChoice' [ "September", "Sep" ]
                                         , strChoice' [ "October", "Oct" ]
                                         , strChoice' [ "November", "Nov" ]
                                         , strChoice' [ "December", "Dec" ]
                                         ]) <?> "Month name"

pWeekdayName :: MonadTP m => ParsecT String () m Int
pWeekdayName = choice' (zipWith (<$) [1..] [ strChoice' [ "Monday", "Mon" ]
                                           , strChoice' [ "Tuesday", "Tue" ]
                                           , strChoice' [ "Wednesday", "Wed" ]
                                           , strChoice' [ "Thursday", "Thu" ]
                                           , strChoice' [ "Friday", "Fri" ]
                                           , strChoice' [ "Saturday", "Sat" ]
                                           , strChoice' [ "Sunday", "Sun" ]
                                           ])

pTime :: MonadTP m => ParsecT String () m (TimeOfDay, Either TimeZone TZ)
pTime = choice' [ (,) <$> spaced pTimeBase <*> spaced pTimeZone
                , (,) <$> spaced pTimeBase <*> asks tz
                ] <?> "Time of day and timezone specification"

data AMPM = AM | PM
  deriving (Eq, Ord, Enum)

pTimeBase :: MonadTP m => ParsecT String () m TimeOfDay
pTimeBase = choice' [ do
                        h <- pHour12
                        m <- option 0 $ char ':' >> pMinute
                        s <- option 0 $ char ':' >> pSecond
                        amPM <- spaced pAMPM
                        let h' = h + fromEnum amPM * 12
                        return $ TimeOfDay h' m s
                    , do
                        h <- pHour
                        m <- option 0 $ char ':' >> pMinute
                        s <- option 0 $ char ':' >> pSecond
                        return $ TimeOfDay h m s
                    , do
                        h <- ensure (<= 24) =<< (\d u -> 10 * d + u) <$> digit <*> digit
                        m <- option 0 $ ensure (< 60) =<< (\d u -> 10 * d + u) <$> digit <*> digit
                        s <- option 0 $ pSecond
                        return $ TimeOfDay h m s
                    , TimeOfDay 0 0 0 <$ string' "midnight"
                    , TimeOfDay 12 0 0 <$ string' "noon"
                    , TimeOfDay 16 0 0 <$ string' "teatime"
                    ] <?> "Time of day specification"
  where
    pAMPM = choice [ AM <$ string' "AM"
                   , PM <$ string' "PM"
                   ]
    pHour12 = (`rem` 12) <$> (ensure (<= 12) =<< natural)

    pHour = (`rem` 24) <$> (ensure (<= 24) =<< natural)
    pMinute = ensure (< 60) =<< natural
    pSecond = decimal

pTimeZone :: MonadIO m => ParsecT String () m (Either TimeZone TZ)
pTimeZone = choice' [ do
                        sgn <- choice [ id <$ char '+'
                                      , negate <$ char '-'
                                      ]
                        hs <- (\d u -> 10 * d + u) <$> digit <*> digit
                        ms <- option 0 $ (\d u -> 10 * d + u) <$> digit <*> digit
                        return . Left . minutesToTimeZone $ hs * 60 + ms
                    , do
                        let
                          ident = (++) <$> many1 alphaNum <*> option "" ((:) <$> oneOf "_-/.+" <*> ident)
                        n <- ident
                        tz <- liftIO $ do
                          let
                            fbHandler :: IO a -> (IOException -> IO a)
                            fbHandler fb _ = fb
                          foldl (\fb a -> a `catchError` fbHandler fb) (return Nothing)
                            [ Just <$> loadSystemTZ n
                            , Just <$> loadTZFromDB n
                            ]
                        case tz of
                          Nothing   -> fail $ "Could not resolve timezone: " ++ n
                          (Just tz) -> return $ Right tz
                    ]