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

module Postdelay.TimeSpec
  ( timeSpec
  , timeZone
  
  , spaceConsumer, lexeme
  ) where

import Postdelay.TimeSpec.Utils
import Postdelay.TimeSpec.Units
import Postdelay.PrioMap

import Text.Megaparsec

import Control.Monad.IO.Class
import Control.Applicative
import Control.Lens hiding ((#))
import Control.Exception (IOException)
import Control.Monad.Catch hiding (try)
import Control.Monad.RWS hiding ((<>))

import Data.Functor
import Data.Bool
import Data.Semigroup hiding (option)
import Data.Monoid (Endo(..))
import Data.Foldable
import Data.VectorSpace
import Data.Maybe

import Data.Time as Time hiding (months)
import Data.Time.Calendar.WeekDate
import Data.Time.Lens
import Data.Time.Zones


data ModPrio = Offset | Assign | Shift | Default
  deriving (Eq, Ord, Enum, Bounded, Show)

  
seconds' :: Timeable t => Lens' t Time
seconds' = seconds . iso (% Second) (# Second)

utcOffset :: Iso' TimeZone Time
utcOffset = iso ((% Minute) . fromIntegral . timeZoneMinutes) (minutesToTimeZone . round . (# Minute))

weekDate :: Dateable t => Lens' t (Integer, Int, Int)
weekDate = date . iso toWeekDate (\(y, w, d) -> fromWeekDate y w d)

shiftBack :: (MonadReader LocalTime m, MonadWriter (PrioEndo ModPrio LocalTime) m)
          => Time -> PrioEndo ModPrio LocalTime -> m ()
shiftBack by mod@(view (prioEndo._Endo) -> modE) = do
  tell mod

  prev <- ask
  new <- asks modE
  case new <= prev of
    True -> scribe (prio Shift) . Just . Endo $ flexDT.seconds' %~ ((^+^) by)
    False -> return ()

mod' :: ModPrio -> ASetter' LocalTime a -> a -> PrioEndo ModPrio LocalTime
mod' priority setter val = mempty & prio priority .~ (Just . Endo $ set setter val)

scribeMod :: MonadWriter (PrioEndo ModPrio LocalTime) m => ModPrio -> ASetter' LocalTime a -> a -> m ()
scribeMod priority setter val = tell $ mod' priority setter val


timeSpec :: forall s m. StringParser s m => m (Endo LocalTime)
timeSpec = label "Relative time specification" $ view prioEndo <$> choice
           [ flip (<>) <$> lexeme specBase <*> option mempty (offsets True)
           , lexeme (string' "now") *> offsets True
           , offsets False
           ]
  where
    specBase = toEndo <$> mkGramSepBy spaces [ timeOfDay
                                             , dateSpec
                                             ]
    
    toEndo :: [RWS LocalTime (PrioEndo ModPrio LocalTime) () ()] -> PrioEndo ModPrio LocalTime
    toEndo (sequence -> act) = mempty & prios .@~ (\i -> Just . Endo $ \t -> maybe t (($ t) . appEndo) . view (prio i) . snd $ execRWS act t ())

timeOfDay, dateSpec :: StringParser s m => m (RWS LocalTime (PrioEndo ModPrio LocalTime) () ())
timeOfDay = label "Time of day" $ withShift <$> choice
            [ TimeOfDay 0  0 0 <$ string' "midnight"
            , TimeOfDay 12 0 0 <$ string' "noon"
            , TimeOfDay 16 0 0 <$ string' "teatime"
            , try $ do
                h <- hour24 True
                m <- minute True
                s <- option 0 $ second True
                return $ TimeOfDay h m s
            , try $ do
                h <- hour12 False
                m <- option 0 $ char ':' *> minute False
                s <- option 0 $ char ':' *> second False
                spaceConsumer
                amPm <- (0 <$ string' "am") <|> (12 <$ string' "pm")
                return $ TimeOfDay (h + amPm) m s
            , try $ do
                h <- hour24 False
                m <- option 0 $ char ':' *> minute False
                s <- option 0 $ char ':' *> second False
                return $ TimeOfDay h m s
            ]
  where
    hour12 pad = label "Modulus 12 hour" . fmap (flip mod 12) . boundedNatural pad $ 1 <=..<= 12
    hour24 pad = label "Modulus 24 hour" . boundedNatural pad $ 0 <=..< 24
    minute pad = label "Minute" . boundedNatural pad $ 0 <=..< 60
    second pad = label "Second" . boundedRational pad $ 0 <=..< 61

    withShift :: TimeOfDay -> RWS LocalTime (PrioEndo ModPrio LocalTime) () ()
    withShift = shiftBack (1 % Day) . mod' Assign time
    
dateSpec = label "Date" $ choice
           [ (scribeMod Assign date =<< view date) <$ string' "today"
           , (scribeMod Assign date =<< views date succ) <$ string' "tomorrow"
           , do
               string' "next"
               spaces
               choice
                 [ string' "day" $> do
                     scribeMod Assign (flexDT.date.days) =<< views (date.days) succ
                     scribeMod Default time midnight
                 , string' "week" $> do
                     scribeMod Assign (flexDT.date.days) =<< views (date.days) (+ 7)
                     scribeMod Assign (weekDate._3) 1
                     scribeMod Default time midnight
                 , string' "month" $> do
                     scribeMod Assign (flexDT.date.months) =<< views (date.months) succ
                     scribeMod Assign (date.days) 1
                     scribeMod Default time midnight
                 , string' "year" $> do
                     scribeMod Assign (flexDT.date.years) =<< views (date.years) succ
                     scribeMod Assign (date.months) 1
                     scribeMod Assign (date.days) 1
                     scribeMod Default time midnight
                 ]
           ]

offsets :: forall s m. StringParser s m
         => Bool -- ^ Require sign on first offset?
         -> m (PrioEndo ModPrio LocalTime)
offsets reqSgn = fmap (foldMap . review $ prioEndo' Offset) $ (:) <$> offset reqSgn <*> many (offset False)
  where
    asOffset :: Time -> Endo LocalTime
    asOffset by = Endo $ flexDT.seconds' %~ (^+^ by)
    offset :: Bool -> m (Endo LocalTime)
    offset (bool (optSigned, "Time offset") (signed, "Signed time offset") -> (sgn, desc))
      = asOffset <$> lexeme (sgn timeLength) <?> desc

timeZone :: (StringParser s m, MonadIO m) => m (Either TimeZone TZ)
timeZone = label "Timezone" $ (Left <$> numericTimezone) <|> (Right <$> namedTimezone)

numericTimezone :: StringParser s m => m TimeZone
numericTimezone = review utcOffset <$> (sign <*> ((^+^) <$> hour <*> minute)) <?> "Numeric timezone"
  where
    hour   = (% Hour)   <$> boundedNatural True (0 <=..<= 24)
    minute = (% Minute) <$> boundedNatural True (0 <=..<  60)

namedTimezone :: (StringParser s m, MonadIO m) => m TZ
namedTimezone = do
  n <- ident <?> "Named timezone identifier"
  tz <- liftIO $ do
    let
      fbHandler :: IO a -> (IOException -> IO a)
      fbHandler fb _ = fb
    foldl (\fb a -> a `catch` fbHandler fb) (return Nothing)
      [ Just <$> loadSystemTZ n
      , Just <$> loadTZFromDB n
      ]
  case tz of
    Nothing   -> fail $ "Could not resolve timezone: " ++ show n
    (Just tz) -> return tz
  where
    asciiAlphaNum = oneOf $ ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z']
    ident = (++) <$> some asciiAlphaNum <*> option [] ((:) <$> oneOf "_-/.+" <*> ident)