{-# 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

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))


timeSpec :: StringParser s m => m (Endo LocalTime)
timeSpec = label "Relative time specification" $
           choice [ lexeme (string' "now") *> offsets True
                  , offsets False
                  ]

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) <$> twoDigit
    minute = (% Minute) <$> twoDigit
    twoDigit = (\n1 n2 -> fromDigit n1 * 10 + fromDigit n2) <$> digitChar <*> digitChar

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"