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/Scan.hs | 39 +++-- lib/Postdelay/TimeSpec.hs | 336 ++-------------------------------------- lib/Postdelay/TimeSpec/Units.hs | 111 +++++++++++++ lib/Postdelay/TimeSpec/Utils.hs | 35 +++++ lib/Postdelay/Utils.hs | 21 --- 5 files changed, 183 insertions(+), 359 deletions(-) create mode 100644 lib/Postdelay/TimeSpec/Units.hs create mode 100644 lib/Postdelay/TimeSpec/Utils.hs delete mode 100644 lib/Postdelay/Utils.hs (limited to 'lib/Postdelay') diff --git a/lib/Postdelay/Scan.hs b/lib/Postdelay/Scan.hs index 2f0a78a..888a237 100644 --- a/lib/Postdelay/Scan.hs +++ b/lib/Postdelay/Scan.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, FlexibleContexts, RecordWildCards, ViewPatterns, TupleSections #-} +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, FlexibleContexts, RecordWildCards, ViewPatterns, TupleSections, RankNTypes #-} module Postdelay.Scan ( scan @@ -7,20 +7,18 @@ module Postdelay.Scan ) where import Postdelay.Types -import Postdelay.Utils import Postdelay.TimeSpec import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Except +import Control.Monad.Catch import Control.Monad.Reader import Control.Monad.List import Control.Exception.Base +import Control.Lens -import Text.Parsec.Char -import Text.Parsec.Prim -import Text.Parsec.Combinator -import Text.Parsec.Error (ParseError(..)) +import qualified Text.Parsec as P +import Text.Megaparsec import Text.ParserCombinators.Parsec.Rfc2822 import Codec.MIME.Decode (decodeWords) @@ -40,17 +38,20 @@ import System.Time (CalendarTime(..)) import Debug.Trace +instance Exception P.ParseError -scan :: (MonadIO m, MonadError ParseError m) => String -> m (Maybe Delay) -scan = fmap getOption . extractDelay <=< either throwError return . parse message "" -extractDelay :: forall m. (MonadIO m, MonadError ParseError m) => Message -> m (Option Delay) +scan :: (MonadIO m, MonadThrow m) => String -> m (Maybe Delay) +scan = fmap getOption . extractDelay <=< either throwM return . P.parse message "" + +extractDelay :: forall m. (MonadIO m, MonadThrow m) => Message -> m (Option Delay) extractDelay (Message headers _) = do - zones <- zoneHeaders - let (baseTime, dateTz) = maximumBy (comparing fst) dateHeaders - tz = foldr' (flip (<>)) (Left dateTz) zones - foldMap pure <$> mapM (flip runReaderT TimeCtx{..} . parseDelay) delayHeaders + tz <- foldr' (flip (<>)) (Left dateTz) <$> zoneHeaders + let apply f = Until (baseTime & localT tz %~ appEndo f) + fmap apply . foldMap pure <$> mapM parseDelay delayHeaders where + (baseTime, dateTz) = maximumBy (comparing fst) dateHeaders + delayHeaders :: [Field] delayHeaders = do (OptionalField field content) <- headers @@ -67,7 +68,11 @@ extractDelay (Message headers _) = do zoneHeaders = runListT $ do (OptionalField field content) <- ListT $ return headers guard $ CI.mk field == "X-Timezone" - Right r <- runParserT (spaces *> pTimeZone <* spaces <* eof) () field content + Right r <- runParserT (spaceConsumer *> lexeme pTimeZone <* eof) field content return r - parseDelay :: Field -> ReaderT TimeCtx m Delay - parseDelay (OptionalField field content) = either throwError return =<< runParserT (Until <$> pTimeSpec) () field content + parseDelay :: Field -> m (Endo LocalTime) + parseDelay (OptionalField field content) = either throwM return =<< runParserT (spaceConsumer *> lexeme pTimeSpec <* eof) field content + +localT :: Either TimeZone TZ -> Iso' UTCTime LocalTime +localT (Left tz) = iso (utcToLocalTime tz) (localTimeToUTC tz) +localT (Right tz) = iso (utcToLocalTimeTZ tz) (localTimeToUTCTZ tz) 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 diff --git a/lib/Postdelay/TimeSpec/Units.hs b/lib/Postdelay/TimeSpec/Units.hs new file mode 100644 index 0000000..330997a --- /dev/null +++ b/lib/Postdelay/TimeSpec/Units.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, RankNTypes, DataKinds, ViewPatterns, ScopedTypeVariables #-} + +module Postdelay.TimeSpec.Units + ( Time + + , Second, Minute, Hour + , Day, Week, Month, Year + + , timeLength + + , module Data.Units.SI.Prefixes + ) where + +import Postdelay.TimeSpec.Utils + +import Control.Applicative + +import Data.Metrology +import Data.Metrology.TH +import Data.Metrology.SI.Mono () + +import Data.Units.SI +import Data.Units.SI.Prefixes +import Data.Units.SI.Parser +import qualified Data.Dimensions.SI as D + +import Data.Foldable +import Data.Function +import Data.VectorSpace + +import Data.Fixed (Fixed, HasResolution) +import qualified Data.Fixed as Fixed + + +import Text.Megaparsec + + +declareDerivedUnit "Day" [t| Hour |] 24 Nothing +declareDerivedUnit "Week" [t| Day |] 7 Nothing +declareDerivedUnit "Month" [t| Day |] 30 Nothing +declareDerivedUnit "Year" [t| Day |] 365.25 Nothing + +type Time = MkQu_DLN D.Time DefaultLCSU Fixed.Pico + +data Prefix where + Prefix :: forall p. (UnitPrefix p, Show p) => p -> Prefix + +instance HasResolution p => AdditiveGroup (Fixed p) where + zeroV = 0 + (^+^) = (+) + negateV = negate + (^-^) = (-) + +instance HasResolution p => VectorSpace (Fixed p) where + type Scalar (Fixed p) = Fixed p + (*^) = (*) + + +timeLength :: StringParser s m => m Time +timeLength = (*^) <$> lexeme rational <*> timeUnit + +rational :: forall s m n. (StringParser s m, Fractional n, Num n) => m n +rational = combine <$> some digitChar <*> option [] (char '.' *> many digitChar) + where + combine :: [Char] -> [Char] -> n + combine (map asN -> whole) (map asN -> fractional) + = foldl' (\i l -> i * 10 + l) 0 whole + (foldr' (\h t -> h + t / 10) 0 fractional) / 10 + asN :: Char -> n + asN c = fromIntegral $ ((-) `on` fromEnum) c '0' + +timeUnit :: StringParser s m => m Time +timeUnit = label "Unit of time" . choice $ + [ 1 % Second <$ choice [ string' "seconds" + , string' "second" + , string' "secs" + , string' "sec" + ] + , 1 % Minute <$ choice [ string' "minutes" + , string' "minute" + , string' "mins" + , string' "min" + ] + , 1 % Hour <$ choice [ string' "hours" + , string' "hour" + ] + , 1 % Day <$ choice [ string' "days" + , string' "day" + ] + , 1 % Week <$ choice [ string' "weeks" + , string' "week" + ] + , 1 % Month <$ choice [ string' "months" + , string' "month" + ] + , 1 % Year <$ choice [ string' "years" + , string' "year" + ] + ] ++ + [ (% Second) <$> option 1 siPrefix <* string "s" + , (% Hour) <$> option 1 siPrefix <* string "h" + , (% Day) <$> option 1 siPrefix <* string "d" + , (% Year) <$> option 1 siPrefix <* choice [ string "a", string "yr", string "yrs" ] + ] + +siPrefix :: (StringParser s m, Fractional n) => m n +siPrefix = label "SI prefix" . choice $ map (\(Prefix p) -> multiplier p <$ string (show p)) + [ Prefix Deca, Prefix Hecto, Prefix Kilo, Prefix Mega, Prefix Giga + , Prefix Tera, Prefix Peta, Prefix Exa, Prefix Zetta, Prefix Yotta + , Prefix Deci, Prefix Centi, Prefix Milli, Prefix Micro, Prefix Nano + , Prefix Pico, Prefix Femto, Prefix Atto, Prefix Zepto, Prefix Yocto + ] diff --git a/lib/Postdelay/TimeSpec/Utils.hs b/lib/Postdelay/TimeSpec/Utils.hs new file mode 100644 index 0000000..e4ba732 --- /dev/null +++ b/lib/Postdelay/TimeSpec/Utils.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE RankNTypes, ConstraintKinds, TypeFamilies, FlexibleContexts, ScopedTypeVariables, ViewPatterns #-} + +module Postdelay.TimeSpec.Utils where + +import Control.Applicative +import Control.Monad +import Control.Lens + +import Data.Time +import Data.Time.Zones + +import Data.AdditiveGroup + +import Text.Megaparsec +import Text.Megaparsec.Prim (MonadParsec) +import qualified Text.Megaparsec.Lexer as L + + +type StringParser s m = (MonadParsec Dec s m, Token s ~ Char) + + +spaceConsumer :: StringParser s m => m () +spaceConsumer = L.space (void spaceChar) empty empty + +lexeme :: StringParser s m => m a -> m a +lexeme = L.lexeme spaceConsumer + +signed, optSigned :: (StringParser s m, AdditiveGroup n) => m n -> m n +signed = (<*>) (lexeme sign) +optSigned = (<*>) (option id $ lexeme sign) + +sign :: (StringParser s m, AdditiveGroup n) => m (n -> n) +sign = choice [ id <$ char '+' + , negateV <$ char '-' + ] diff --git a/lib/Postdelay/Utils.hs b/lib/Postdelay/Utils.hs deleted file mode 100644 index d716b4d..0000000 --- a/lib/Postdelay/Utils.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Postdelay.Utils - ( hoistParsecT - ) where - -import Control.Monad.Error.Class - -import Data.Functor -import Data.Either - -import Data.Functor.Identity -import Text.Parsec.Prim -import Text.Parsec.Error - -hoistParsecT :: (Monad m, Stream s Identity t, Stream s m t) => ParsecT s u Identity a -> ParsecT s u m a -hoistParsecT p = do - st <- getParserState - let res = runParser p' undefined "" undefined - p' = setParserState st >> ((,) <$> getState <*> p) - either (fail . show) (\(st', res) -> putState st' $> res) $ res -- cgit v1.2.3