{-# 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 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.Bool
import Data.Semigroup hiding (option)
import Data.Monoid (Endo(..))
import Data.Foldable
import Data.VectorSpace

import Data.Time
import Data.Time.Lens
import Data.Time.Zones


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

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

shiftBack :: MonadState LocalTime m => Time -> m a -> m a
shiftBack by mod = join $ shiftBack' <$> get <*> mod <*> get
  where
    shiftBack' prev ret new
      | new < prev = ret <$ (flexDT.seconds' %= (^+^) by)
      | otherwise  = pure ret


timeSpec :: forall s m. StringParser s m => m (Endo LocalTime)
timeSpec = label "Relative time specification" $
           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 () LocalTime a] -> Endo LocalTime
    toEndo (sequence -> act) = Endo $ \t -> fst $ execRWS act t t

timeOfDay, dateSpec :: StringParser s m => m (RWS LocalTime () LocalTime ())
timeOfDay = label "Time of day" $ shiftBack (1 % Day) . assign time <$> 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
            ]
  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
    
dateSpec = label "Date" $ (date <~) <$> choice
           [ view date <$ string' "today"
           , views date succ <$ string' "tomorrow"
           ]

offsets :: forall s m. StringParser s m
         => Bool -- ^ Require sign on first offset?
         -> m (Endo LocalTime)
offsets reqSgn = fmap fold $ (:) <$> offset reqSgn <*> many (offset False)
  where
    asOffset :: Time -> Endo LocalTime
    asOffset by = Endo $ flexDT.seconds' %~ (^+^ by)
    offset :: Bool -> m (Endo LocalTime)
    offset sgnReq@(bool optSigned signed -> sgn)
      = asOffset <$> lexeme (sgn timeLength) <?> if sgnReq then "Signed time offset" else "Time offset"

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
  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) <?> "Named timezone identifier"