From 461920b28d6c4697047fefc5a98a6f00cdf32175 Mon Sep 17 00:00:00 2001 From: Yuri Romanowski Date: Fri, 17 Feb 2023 16:17:18 +0500 Subject: [PATCH] [#79] Add support for hyphenated intervals. Problem: when a user writes "10am-11am UTC ...", context is not shared between times, and second time can be skipped because every time should go after a space. Solution: Parse time references that are grouped via hyphen, slash, "and", "or" sharing their context: date ref, location ref, am/pm. --- .gitignore | 2 + package.yaml | 1 + src/TzBot/Parser.hs | 217 +++++++++++++++++++++++------ src/TzBot/ProcessEvents/Message.hs | 2 +- src/TzBot/TimeReference.hs | 38 ++++- src/TzBot/Util.hs | 7 + stack.yaml | 2 + test/Test/TzBot/ParserSpec.hs | 154 ++++++++++++++++++++ tzbot.cabal | 4 +- 9 files changed, 381 insertions(+), 46 deletions(-) create mode 100644 test/Test/TzBot/ParserSpec.hs diff --git a/.gitignore b/.gitignore index 676b4c7..ab9c6dd 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,5 @@ stack-hie.yaml* .vscode/ result *.txt +stack-hie.yaml +stack-hie.yaml.lock diff --git a/package.yaml b/package.yaml index 676b8e9..2538c35 100644 --- a/package.yaml +++ b/package.yaml @@ -110,6 +110,7 @@ tests: - tasty-hspec - tasty-hunit - tasty-quickcheck + - text - time - tztime - QuickCheck diff --git a/src/TzBot/Parser.hs b/src/TzBot/Parser.hs index 6586e33..4f47d53 100644 --- a/src/TzBot/Parser.hs +++ b/src/TzBot/Parser.hs @@ -9,6 +9,7 @@ module TzBot.Parser import Universum hiding (many, toList, try) import Data.Char (isUpper) +import Data.List qualified as L import Data.Map qualified as M import Data.String.Conversions (cs) import Data.Text qualified as T @@ -18,6 +19,7 @@ import Data.Time.Calendar.Compat (DayOfMonth, MonthOfYear, Year) import Data.Time.LocalTime (TimeOfDay(..)) import Data.Time.Zones.All (TZLabel, tzNameLabelMap) import Glider.NLP.Tokenizer (Token(..), tokenize) +import Text.Interpolation.Nyan (int, rmode') import Text.Megaparsec hiding (Token) import TzBot.Instances () @@ -212,17 +214,45 @@ type TzParser = Parsec Void [Token] >>> parseTimeRefs "7:30pm 2022/08/3" [TimeReference {trText = "7:30pm 2022/08/3", trTimeOfDay = 19:30:00, trDateRef = Just (DayOfMonthRef 3 (Just (8,Just 2022))), trLocationRef = Nothing}] ->>> parseTimeRefs "2022.8.03 7:30 pm " +>>> parseTimeRefs "2022.8.03 7:30 pm " [TimeReference {trText = "2022.8.03 7:30 pm", trTimeOfDay = 19:30:00, trDateRef = Just (DayOfMonthRef 3 (Just (8,Just 2022))), trLocationRef = Nothing}] >>> parseTimeRefs "7:30pm 2022.8.03 America/Havana" [TimeReference {trText = "7:30pm 2022.8.03 America/Havana", trTimeOfDay = 19:30:00, trDateRef = Just (DayOfMonthRef 3 (Just (8,Just 2022))), trLocationRef = Just (TimeZoneRef America__Havana)}] +>>> parseTimeRefs "tomorrow 10am -11 am" +[TimeReference {trText = "tomorrow 10am", trTimeOfDay = 10:00:00, trDateRef = Just (DaysFromToday 1), trLocationRef = Nothing},TimeReference {trText = "tomorrow 11 am", trTimeOfDay = 11:00:00, trDateRef = Just (DaysFromToday 1), trLocationRef = Nothing}] + +>>> parseTimeRefs "tomorrow 10am / 11 am" +[TimeReference {trText = "tomorrow 10am", trTimeOfDay = 10:00:00, trDateRef = Just (DaysFromToday 1), trLocationRef = Nothing},TimeReference {trText = "tomorrow 11 am", trTimeOfDay = 11:00:00, trDateRef = Just (DaysFromToday 1), trLocationRef = Nothing}] + +>>> parseTimeRefs "between 10am and 11:30am UTC" +[TimeReference {trText = "10am UTC", trTimeOfDay = 10:00:00, trDateRef = Nothing, trLocationRef = Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"}))},TimeReference {trText = "11:30am UTC", trTimeOfDay = 11:30:00, trDateRef = Nothing, trLocationRef = Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"}))}] + +>>> parseTimeRefs "Let's go on Wednesday at 10:00 or 11:00." +[TimeReference {trText = "on Wednesday at 10:00", trTimeOfDay = 10:00:00, trDateRef = Just (DayOfWeekRef Wednesday), trLocationRef = Nothing},TimeReference {trText = "on Wednesday 11:00", trTimeOfDay = 11:00:00, trDateRef = Just (DayOfWeekRef Wednesday), trLocationRef = Nothing}] + +>>> parseTimeRefs "10-11pm tomorrow works for me" +[TimeReference {trText = "10pm tomorrow", trTimeOfDay = 22:00:00, trDateRef = Just (DaysFromToday 1), trLocationRef = Nothing},TimeReference {trText = "11pm tomorrow", trTimeOfDay = 23:00:00, trDateRef = Just (DaysFromToday 1), trLocationRef = Nothing}] + +>>> parseTimeRefs "How about 10:00 or 11:00 pm tomorrow?" +[TimeReference {trText = "10:00 pm tomorrow", trTimeOfDay = 22:00:00, trDateRef = Just (DaysFromToday 1), trLocationRef = Nothing},TimeReference {trText = "11:00 pm tomorrow", trTimeOfDay = 23:00:00, trDateRef = Just (DaysFromToday 1), trLocationRef = Nothing}] + +>>> parseTimeRefs "7.30-8.30pm" +[TimeReference {trText = "7.30pm", trTimeOfDay = 19:30:00, trDateRef = Nothing, trLocationRef = Nothing},TimeReference {trText = "8.30pm", trTimeOfDay = 20:30:00, trDateRef = Nothing, trLocationRef = Nothing}] + +>>> parseTimeRefs "7.30am-8.30pm tomorrow" +[TimeReference {trText = "7.30am tomorrow", trTimeOfDay = 07:30:00, trDateRef = Just (DaysFromToday 1), trLocationRef = Nothing},TimeReference {trText = "8.30pm tomorrow", trTimeOfDay = 20:30:00, trDateRef = Just (DaysFromToday 1), trLocationRef = Nothing}] + +>>> parseTimeRefs "7.30-8.30" +[] + -} parseTimeRefs :: Text -> [TimeReference] parseTimeRefs = -- TODO use better error handling - fromMaybe [] + map matchedToPlain + . fromMaybe [] . parseMaybe timeRefsParser -- time reference can be either at the beginning or after a space . (Whitespace :) @@ -231,61 +261,118 @@ parseTimeRefs = -- | Parser for multiple 'TimeReference' s. -- -- This looks for all of them in the input and ignores everything surrounding. -timeRefsParser :: TzParser [TimeReference] +timeRefsParser :: TzParser [TimeReferenceMatched] timeRefsParser = choice' [ do - tr <- try timeRefParser + tr <- try timeRefConjugParser trs <- timeRefsParser - return $ tr : trs + return $ tr <> trs , anySingle >> timeRefsParser , takeRest >> pure [] ] --- | Parses a single 'TimeReference', consuming all input. -timeRefParser :: TzParser TimeReference +-- | Parses entries like @between 10am and 11am@ or +-- @10am-11am on thursday or 1pm-2pm on wednesday@ +timeRefConjugParser :: TzParser [TimeReferenceMatched] +timeRefConjugParser = do + firstConjugComponent <- timeRefParser + let conjugParser conjWord = do + optional' space + _ <- word' conjWord + -- no space here before `timeRefParser` requires a space before the contents + secondConjugComponent <- timeRefParser + pure $ unifyConjugComponents $ firstConjugComponent <> secondConjugComponent + + unifyConjugComponents :: [TimeReferenceMatched] -> [TimeReferenceMatched] + unifyConjugComponents lst = do + let getUnique :: Eq a => (TimeReferenceMatched -> Maybe a) -> Maybe a + getUnique getter = do + let many = L.nub $ mapMaybe getter lst + case many of + [item] -> Just item + _ -> Nothing + let locRef = getUnique trLocationRef + dateRef = getUnique trDateRef + -- TODO: use lenses + flip map lst $ + (whenJustFunc locRef \l tr -> addLocationIfMissing l tr) + . whenJustFunc dateRef \d tr -> addDateIfMissing d tr + + choice' + [ conjugParser "and" + , conjugParser "or" + , pure firstConjugComponent + ] + +addLocationIfMissing + :: Matched LocationReference + -> TimeReferenceMatched + -> TimeReferenceMatched +addLocationIfMissing l tr = + if isNothing (trLocationRef tr) + then tr { trLocationRef = Just l, trText = [int||#{trText tr} (#{mtText l})|] } + else tr + +addDateIfMissing + :: Matched DateReference + -> TimeReferenceMatched + -> TimeReferenceMatched +addDateIfMissing d tr = + if isNothing (trDateRef tr) + then tr { trDateRef = Just d, trText = [int||#{trText tr} (#{mtText d})|] } + else tr + +-- | Parses coupled 'TimeReference's, collecting the source text. +timeRefParser :: TzParser [TimeReferenceMatched] timeRefParser = do _ <- space - (newTrText, timeReference) <- match timeRefParser' - return timeReference { trText = concatTokens newTrText } - --- | Parses a single 'TimeReference', but does not collect the source text. -timeRefParser' :: TzParser TimeReference -timeRefParser' = do - let trText = "" - precBuilder <- fromMaybe builderInit <$> do + (precText, precBuilder) <- match $ fromMaybe builderInit <$> do res <- optional' (builderParser False builderInit) optional' spacedComma pure res - trTimeOfDay <- timeOfDayParser - builder <- fromMaybe builderInit <$> optional' (builderParser True precBuilder) + timeEntry <- timeEntryParser + (afterText, builder) <- match $ fromMaybe builderInit <$> optional' (builderParser True precBuilder) let trLocationRef = trbLocRef builder trDateRef = trbDateRef builder - pure TimeReference {..} + let mkTrText refText = + T.concat [concatTokens precText, refText, concatTokens afterText] + let mkTimeReference todWithText = TimeReference + { trText = mkTrText $ mtText todWithText + , trTimeOfDay = mtValue todWithText + , trDateRef + , trLocationRef + } + pure $ map mkTimeReference case timeEntry of + TESingle todwt -> [todwt] + TEPair todwt todwt' -> [todwt, todwt'] ---------------------------------------------------------------------------- ---- Collecting of optional time contexts ---------------------------------------------------------------------------- data ContextBuilder = ContextBuilder - { trbDateRef :: Maybe DateReference - , trbLocRef :: Maybe LocationReference + { trbDateRef :: Maybe (Matched DateReference) + , trbLocRef :: Maybe (Matched LocationReference) } deriving stock (Show, Eq) builderInit :: ContextBuilder builderInit = ContextBuilder Nothing Nothing data SumContextBuilder - = SCBDate DateReference - | SCBLocRef LocationReference + = SCBDate (Matched DateReference) + | SCBLocRef (Matched LocationReference) sumBuilderParser :: TzParser SumContextBuilder sumBuilderParser = - choice' [SCBDate <$> dateRefParser, SCBLocRef <$> locRefParser] + choice' + [ SCBDate . matched <$> match dateRefParser + , SCBLocRef . matched <$> match locRefParser + ] builderParser :: Bool -> ContextBuilder -> TzParser ContextBuilder builderParser allowSpace b = do sumB <- optional' - (when allowSpace (void $ optional' spacedComma) >> sumBuilderParser) - case sumB of + (when allowSpace (void $ optional' spacedComma) >> matched <$> match sumBuilderParser) + case fmap mtValue sumB of Just (SCBDate dr) -> do when (isJust $ trbDateRef b) empty builderParser True b { trbDateRef = Just dr } @@ -295,11 +382,56 @@ builderParser allowSpace b = do Nothing -> pure b ---------------------------------------------------------------------------- +matched :: ([Token], a) -> Matched a +matched (ts, val) = Matched (concatTokens ts) val + +data TimeEntry + = TESingle (Matched TimeOfDay) + -- ^ E.g. @10am@ + | TEPair (Matched TimeOfDay) (Matched TimeOfDay) + -- ^ E.g. @10am-11am@ + +timeEntryParser :: TzParser TimeEntry +timeEntryParser = do + let todWithTextParser = matched <$> match timeOfDayParser + firstRef <- todWithTextParser + let delimitedPair :: TzParser a -> TzParser TimeEntry + delimitedPair delim = do + optional' space + delim + optional' space + secondRef <- todWithTextParser + let getIsAm + :: Matched (Maybe (TimeOfDay, Maybe $ Matched Bool), Bool -> TimeOfDay) + -> Maybe (Matched Bool) + getIsAm ref = fst (mtValue ref) >>= snd + let isAmOptions = mapMaybe getIsAm [firstRef, secondRef] + let applyIsAm + :: Matched Bool + -> Matched (Maybe (TimeOfDay, Maybe $ Matched Bool), Bool -> TimeOfDay) + -> Matched TimeOfDay + applyIsAm isAm ref = do + let shouldAppend = isNothing $ getIsAm ref + whenFunc shouldAppend (modifyText (<> mtText isAm)) $ fmap (($ mtValue isAm) . snd) ref + extractDefaultResult :: Matched (Maybe (TimeOfDay, a), b) -> Maybe (Matched TimeOfDay) + extractDefaultResult ref = traverse (fmap fst . fst) ref + case isAmOptions of + [isAm] -> pure $ (TEPair `on` applyIsAm isAm) firstRef secondRef + _ -> maybe empty pure $ TEPair <$> extractDefaultResult firstRef <*> extractDefaultResult secondRef + + choice' + [ delimitedPair (punct '-') + , delimitedPair (punct '/') + , delimitedPair (word' "or") + , delimitedPair (word' "and") + , TESingle <$> traverse (\(mbRes, _) -> maybe empty (pure . fst) mbRes) firstRef + ] + -- | Parses a 'TimeOfDay'. -- -- This is permissive in the space, as it allows none to be between the time and -- the AM/PM. -timeOfDayParser :: TzParser TimeOfDay +timeOfDayParser :: TzParser (Maybe (TimeOfDay, Maybe (Matched Bool)), Bool -> TimeOfDay) timeOfDayParser = do _ <- optional' (relationPreposition >> space) hour <- hourParser @@ -328,19 +460,25 @@ timeOfDayParser = do , pure (Nothing, True) ] - isAm <- if isAmRequired - then isAmParser - else fromMaybe True <$> optional' isAmParser + let mkTime isAm = do + let todSec = 0 + todHour + | isAm = hour + -- pm here + | hour < 12 = hour + 12 + -- ignore pm if hour > 12 + | otherwise = hour + todMin = fromMaybe 0 maybeMin + TimeOfDay {..} + + mbIsAm <- optional' $ matched <$> match isAmParser + case mbIsAm of + Just isAm -> pure (Just (mkTime $ mtValue isAm, Just isAm), mkTime) + Nothing -> + if isAmRequired + then pure (Nothing, mkTime) + else pure (Just (mkTime True, Nothing), mkTime) - let todSec = 0 - todHour - | isAm = hour - -- pm here - | hour < 12 = hour + 12 - -- ignore pm if hour > 12 - | otherwise = hour - todMin = fromMaybe 0 maybeMin - pure TimeOfDay {..} isAmParser :: TzParser Bool isAmParser = optional' space >> @@ -517,8 +655,7 @@ isPossibleTimezoneAbbrev w = T.all isUpper w && T.length w >= 2 && T.length w <= 5 - && w /= "AM" - && w /= "PM" + && not (w `elem` ["AM", "PM", "OR", "AND"]) -------------------------------------------------------------------------------- -- Storages diff --git a/src/TzBot/ProcessEvents/Message.hs b/src/TzBot/ProcessEvents/Message.hs index 43257ef..983204c 100644 --- a/src/TzBot/ProcessEvents/Message.hs +++ b/src/TzBot/ProcessEvents/Message.hs @@ -25,7 +25,7 @@ import TzBot.Slack import TzBot.Slack.API import TzBot.Slack.Events import TzBot.Slack.Fixtures qualified as Fixtures -import TzBot.TimeReference (TimeReference(..)) +import TzBot.TimeReference (TimeReference) import TzBot.Util (whenT, withMaybe) data MessageEventType = METMessage | METMessageEdited diff --git a/src/TzBot/TimeReference.hs b/src/TzBot/TimeReference.hs index f6d5c89..60d3e38 100644 --- a/src/TzBot/TimeReference.hs +++ b/src/TzBot/TimeReference.hs @@ -33,14 +33,44 @@ We use this type alias to make this distinction a bit more clear. -} type TimeReferenceText = Text +-- | Datatype for keeping value together with its parsed text (as a sequence of tokens) +data Matched a = Matched + { mtText :: Text + -- ^ Consumed tokens + , mtValue :: a + -- ^ Parsed value + } deriving stock (Show, Eq, Generic, Functor, Foldable, Traversable) + +-- TODO: use lenses +modifyText :: (Text -> Text) -> Matched a -> Matched a +modifyText f Matched {..} = Matched {mtText = f mtText, ..} + +type family WhetherMatched f x where + WhetherMatched Identity x = x + WhetherMatched Matched x = Matched x + -- | A reference to a point in time, e.g. "tuesday at 10am", "3pm CST on July 7th" -data TimeReference = TimeReference +data TimeReferenceGeneric f = TimeReference { trText :: TimeReferenceText -- ^ The original section of the text from where this `TimeReference` was parsed. , trTimeOfDay :: TimeOfDay - , trDateRef :: Maybe DateReference - , trLocationRef :: Maybe LocationReference + , trDateRef :: Maybe (WhetherMatched f DateReference) + , trLocationRef :: Maybe (WhetherMatched f LocationReference) + } + +deriving stock instance Show TimeReference +deriving stock instance Eq TimeReference +deriving stock instance Show TimeReferenceMatched +deriving stock instance Eq TimeReferenceMatched + +type TimeReference = TimeReferenceGeneric Identity +type TimeReferenceMatched = TimeReferenceGeneric Matched + +matchedToPlain :: TimeReferenceMatched -> TimeReference +matchedToPlain TimeReference {..} = TimeReference + { trDateRef = fmap mtValue trDateRef + , trLocationRef = fmap mtValue trLocationRef + , .. } - deriving stock (Eq, Show) getTzLabelMaybe :: TZLabel -> TimeReference -> Maybe TZLabel getTzLabelMaybe senderTz timeRef = case trLocationRef timeRef of diff --git a/src/TzBot/Util.hs b/src/TzBot/Util.hs index 8d7c6ea..f16badf 100644 --- a/src/TzBot/Util.hs +++ b/src/TzBot/Util.hs @@ -213,3 +213,10 @@ secondsPerMinute = 60 tztimeOffset :: TZTime -> Offset tztimeOffset = Offset . timeZoneMinutes . tzTimeOffset + +whenJustFunc :: Maybe b -> (b -> a -> a) -> a -> a +whenJustFunc Nothing _f = id +whenJustFunc (Just b) f = f b + +whenFunc :: Bool -> (a -> a) -> a -> a +whenFunc b f = if b then f else id diff --git a/stack.yaml b/stack.yaml index 59a248c..8a8b230 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,6 +7,8 @@ resolver: lts-19.23 packages: - . +system-ghc: true + extra-deps: - git: https://github.com/serokell/nyan-interpolation.git commit: 5e158057b167275d2150454e2bb731cfe686ea7a diff --git a/test/Test/TzBot/ParserSpec.hs b/test/Test/TzBot/ParserSpec.hs new file mode 100644 index 0000000..f7e30e4 --- /dev/null +++ b/test/Test/TzBot/ParserSpec.hs @@ -0,0 +1,154 @@ +-- SPDX-FileCopyrightText: 2022 Serokell +-- +-- SPDX-License-Identifier: MPL-2.0 + +module Test.TzBot.ParserSpec + ( test_parserSpec + ) where + +import Universum + +import Data.Text qualified as T +import Data.Time (DayOfWeek(..), TimeOfDay(..), defaultTimeLocale, formatTime) +import Test.Tasty +import Test.Tasty.HUnit (Assertion, assertFailure, testCase) +import Test.Tasty.Runners (TestTree(TestGroup)) +import Text.Interpolation.Nyan (int, rmode', rmode's) + +import TzBot.Parser (parseTimeRefs) +import TzBot.TimeReference + (DateReference(..), LocationReference(..), TimeReference, TimeReferenceGeneric(..), + TimeZoneAbbreviationInfo(..)) + +{- | This test suite contains only tests whose output is too big + - to be placed in doctests + -} +test_parserSpec :: TestTree +test_parserSpec = TestGroup "ParserBig" + [ testCase "First slashed term contains all references, second slashed term contains no refs" $ + mkTestCase + "How about Wednesday at 10:00 / 11:00 UTC or 14:00 / 15:00" + [ TimeReference + "Wednesday at 10:00 UTC" + (TimeOfDay 10 00 00) + (Just (DayOfWeekRef Wednesday)) + (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"}))) + , TimeReference + "Wednesday 11:00 UTC" + (TimeOfDay 11 00 00) + (Just (DayOfWeekRef Wednesday)) + (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"}))) + , TimeReference + "14:00 (Wednesday) (UTC)" + (TimeOfDay 14 00 00) + (Just (DayOfWeekRef Wednesday)) + (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"}))) + , TimeReference + "15:00 (Wednesday) (UTC)" + (TimeOfDay 15 00 00) + (Just (DayOfWeekRef Wednesday)) + (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"}))) + ] + , testCase "First slashed term has day of week, second has also UTC" $ + mkTestCase + "How about Wednesday at 10:00 / 11:00 OR 14:00 / 15:00 at Thursday UTC" + [ TimeReference + "Wednesday at 10:00 (UTC)" + (TimeOfDay 10 00 00) + (Just (DayOfWeekRef Wednesday)) + (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"}))) + , TimeReference + "Wednesday 11:00 (UTC)" + (TimeOfDay 11 00 00) + (Just (DayOfWeekRef Wednesday)) + (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"}))) + , TimeReference + "14:00 at Thursday UTC" + (TimeOfDay 14 00 00) + (Just (DayOfWeekRef Thursday)) + (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"}))) + , TimeReference + "15:00 at Thursday UTC" + (TimeOfDay 15 00 00) + (Just (DayOfWeekRef Thursday)) + (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"}))) + ] + , testCase "Some hyphenated intervals" $ + mkTestCase + "Hi guys! Let’s have a sync call tomorrow? Almost every time from 7am-2pm UTC works (except 10:30am - 12pm UTC)" + [ TimeReference + "7am UTC" + (TimeOfDay 07 00 00) + (Nothing) + (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"}))) + , TimeReference + "2pm UTC" + (TimeOfDay 14 00 00) + (Nothing) + (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"}))) + , TimeReference + "10:30am UTC" + (TimeOfDay 10 30 00) + (Nothing) + (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"}))) + , TimeReference + "12pm UTC" + (TimeOfDay 12 00 00) + (Nothing) + (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"}))) + ] + ] + +mkTestCase :: HasCallStack => Text -> [TimeReference] -> Assertion +mkTestCase input expectedRefs = do + let outputRefs = parseTimeRefs input + assertRefPairs expectedRefs outputRefs + +assertRefPairs :: HasCallStack => [TimeReference] -> [TimeReference] -> Assertion +assertRefPairs [] [] = pass +assertRefPairs [] os = + assertFailure + [int|| + Expected no more time references, but got + #{prettyPrintList os} + |] +assertRefPairs es [] = + assertFailure + [int|| + Expected more time references #{prettyPrintList es} + |] +assertRefPairs (e : es) (o : os) = + assertRefPair e o >> assertRefPairs es os + +prettyPrintTimeReference :: Char -> TimeReference -> Text +prettyPrintTimeReference start TimeReference {..} = + [int|s| + #{start} TimeReference + #s{trText} + (#{renderTimeOfDay trTimeOfDay}) + (#s{trDateRef}) + (#s{trLocationRef}) + |] + where + renderTimeOfDay (t :: TimeOfDay) = formatTime defaultTimeLocale "TimeOfDay %H %M %S" t + +prettyPrintList :: [TimeReference] -> Text +prettyPrintList [] = "Empty list" +prettyPrintList (t : ts) = + T.unlines $ prettyPrintTimeReference '[' t + : map (prettyPrintTimeReference ',') ts + <> ["]"] + +assertRefPair :: HasCallStack => TimeReference -> TimeReference -> Assertion +assertRefPair expTr outTr = do + assertUnit "Text" trText + assertUnit "Date reference" trDateRef + assertUnit "Location reference" trLocationRef + assertUnit "Time of day" trTimeOfDay + where + assertUnit :: (Show a, Eq a) => Text -> (TimeReference -> a) -> Assertion + assertUnit note getter = do + let expUnit = getter expTr + outUnit = getter outTr + when (expUnit /= outUnit) $ + assertFailure [int||#{note}: expected #s{expUnit} but got #s{outUnit}|] diff --git a/tzbot.cabal b/tzbot.cabal index 5adc9da..5ba7290 100644 --- a/tzbot.cabal +++ b/tzbot.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7. +-- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack @@ -301,6 +301,7 @@ test-suite tzbot-test Test.TzBot.GetTimeshiftsSpec Test.TzBot.HandleTooManyRequests Test.TzBot.MessageBlocksSpec + Test.TzBot.ParserSpec Test.TzBot.RenderSpec Test.TzBot.TimeReferenceToUtcSpec Tree @@ -376,6 +377,7 @@ test-suite tzbot-test , tasty-hspec , tasty-hunit , tasty-quickcheck + , text , time , tzbot , tztime