{-# 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 -> m a -> m a shiftBack by mod = do (result, modE) <- listen mod prev <- ask new <- asks $ view (prioEndo._Endo) modE when (new <= prev) $ scribe (prio Shift) . Just . Endo $ flexDT.seconds' %~ ((^+^) by) return result 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 [ dateSpec , timeOfDay ] 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 tod = shiftBack (1 % Day) $ scribe (prio' Assign . time) tod dateSpec = label "Date" $ (>> scribe (prio' Default . time) midnight) <$> choice [ (scribe (prio' Assign . date) =<< view date) <$ string' "today" , (scribe (prio' Assign . date) =<< views date succ) <$ string' "tomorrow" , try $ do string' "next" spaces choice [ string' "day" $> do scribe (prio' Assign . flexDT.date.days) =<< views (date.days) succ , string' "week" $> do scribe (prio' Assign . flexDT.date.days) =<< views (date.days) (+ 7) scribe (prio' Assign . weekDate._3) 1 , string' "month" $> do scribe (prio' Assign . flexDT.date.months) =<< views (date.months) succ scribe (prio' Assign . date.days) 1 , string' "year" $> do scribe (prio' Assign . flexDT.date.years) =<< views (date.years) succ scribe (prio' Assign . date.months) 1 scribe (prio' Assign . date.days) 1 ] , try $ do let daySuffix = optional $ choice [ string' "st", string' "nd", string' "rd", string' "th" ] (m, d) <- choice [ try $ (,) <$> monthName <* spaces <*> dayNumber False <* daySuffix , try $ flip (,) <$> dayNumber False <* daySuffix <* spaces <*> monthName ] y <- optional . try $ do spaces optional . lexeme $ char ',' yearNumber <* lookAhead (spaces <|> eof) return $ scribeDate y m d , try $ do m <- monthNumber False char '/' d <- dayNumber False y <- optional . try $ char '/' *> yearNumber <* lookAhead (spaces <|> eof) return $ scribeDate y m d , try $ do d <- dayNumber False char '.' m <- monthNumber False y <- optional . try $ char '.' *> yearNumber <* lookAhead (spaces <|> eof) return $ scribeDate y m d , try $ do (Just -> y) <- yearNumber char '-' m <- monthNumber True char '-' d <- dayNumber True return $ scribeDate y m d , try $ do ds <- lookAhead $ length <$ (optional $ ($ ()) <$> sign) <*> some digitChar let yDs = ds - 2 {- month-} - 2 {- day -} when (yDs <= 0) $ fail "Too few digits to interpret as concatenated date" (Just -> y) <- optSigned . boundedNatural True $ 10^(pred yDs) <=..< 10^yDs m <- monthNumber True d <- dayNumber True return $ scribeDate y m d , monthName <$$> \m -> shiftBack (1 % Year) $ do scribe (prio' Assign . flexDT.date.months) m scribe (prio' Assign . flexDT.date.days) 1 , weekdayName <$$> \w -> shiftBack (1 % Week) $ do scribe (prio' Assign . weekDate._3) w ] where withYear y | Just y' <- y = (>>) $ scribe (prio' Assign . date.years) y' | otherwise = shiftBack (1 % Year) scribeDate y m d = withYear y $ do scribe (prio' Assign . date.months) m scribe (prio' Assign . flexDT.date.days) d (<$$>) = flip (<$>) monthName = choice $ zipWith (<$) [1..] [ string' "january" <|> string' "jan" , string' "febuary" <|> string' "feb" , string' "march" <|> string' "mar" , string' "april" <|> string' "apr" , string' "may" , string' "june" <|> string' "jun" , string' "july" <|> string' "jul" , string' "august" <|> string' "aug" , string' "september" <|> string' "sep" , string' "october" <|> string' "oct" , string' "november" <|> string' "nov" , string' "december" <|> string' "dec" ] weekdayName = choice $ zipWith (<$) [1..] [ string' "monday" <|> string' "mon" , string' "tuesday" <|> string' "tue" , string' "wednesday" <|> string' "wed" , string' "thursday" <|> string' "thu" , string' "friday" <|> string' "fri" , string' "saturday" <|> string' "sat" , string' "sunday" <|> string' "sun" ] dayNumber p = boundedNatural p (1 <=..<= 31) monthNumber p = boundedNatural p (1 <=..<= 12) yearNumber = optSigned $ boundedNatural False (0 <=..< PosInf) 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)