From ee09f262f9b8c7c6a4042071cdfff3e22adbef86 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Wed, 15 Feb 2017 15:10:51 +0100 Subject: Establish framework --- lib/Postdelay/TimeSpec.hs | 336 +++------------------------------------------- 1 file changed, 15 insertions(+), 321 deletions(-) (limited to 'lib/Postdelay/TimeSpec.hs') diff --git a/lib/Postdelay/TimeSpec.hs b/lib/Postdelay/TimeSpec.hs index 676dabf..5c41180 100644 --- a/lib/Postdelay/TimeSpec.hs +++ b/lib/Postdelay/TimeSpec.hs @@ -1,335 +1,29 @@ -{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ViewPatterns, ConstraintKinds, TupleSections, RecordWildCards #-} +{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ViewPatterns, ConstraintKinds, TupleSections, RecordWildCards, TypeFamilies #-} module Postdelay.TimeSpec ( pTimeSpec , pTimeZone - , TimeCtx(..) + + , spaceConsumer, lexeme ) where -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Reader.Class -import Control.Monad.Error.Class +import Postdelay.TimeSpec.Utils +import Postdelay.TimeSpec.Units -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 Text.Megaparsec + +import Control.Monad.IO.Class +import Control.Applicative -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI +import Data.Semigroup +import Data.Monoid (Endo(..)) 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 +pTimeSpec :: StringParser s m => m (Endo LocalTime) +pTimeSpec = empty -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 - ] +pTimeZone :: (StringParser s m, MonadIO m) => m (Either TimeZone TZ) +pTimeZone = empty -- cgit v1.2.3