[#82] Remind time contexts and apply to time references

Problem: Sometimes, context of a time reference can be spread over one
sentence, several different sentences or even several different messages.

Solution: Parse contexts alone, remind them and apply to context-free time
references when encountered; track a context during thread evolution.

src/TzBot/BotMain.hs

@@ -92,8 +92,12 @@ run opts = do
       managed $ withTzCacheDefault defaultMessageInfoCachingTime
     bsReportEntries <-
       managed $ withTzCacheDefault cCacheReportDialog
-    -- auto-acknowledge received messages
+
+    let defaultConversationStateCachingTime = hour 12
+    bsConversationStateCache <-
+      managed $ withTzCacheDefault defaultConversationStateCachingTime
     (bsLogNamespace, bsLogContext, bsLogEnv) <- managed $ withLogger cLogLevel
+    -- auto-acknowledge received messages
     liftIO $ runSocketMode sCfg $ handler gracefulShutdownContainer BotState {..}
 
 withFeedbackConfig :: BotConfig -> (FeedbackConfig -> IO a) -> IO a

src/TzBot/ProcessEvents/Common.hs

@@ -4,7 +4,7 @@
 
 module TzBot.ProcessEvents.Common
   ( openModalCommon
-  , getTimeReferencesFromMessage
+  , getTimeReferencesAndNewStateFromMessage
 
     -- * exported for tests
   , ignoreCodeBlocksManually
@@ -18,15 +18,17 @@ import Data.Text qualified as T
 import Fmt (listF)
 import Text.Interpolation.Nyan (int, rmode')
 
+import TzBot.Cache qualified as Cache
 import TzBot.Feedback.Dialog (insertDialogEntry)
 import TzBot.Feedback.Dialog.Types
 import TzBot.Logger
 import TzBot.Parser (parseTimeRefs)
 import TzBot.Render (TranslationPairs, asForModalM, renderAllTP, renderTemplate)
-import TzBot.Slack (BotM, getUserCached, startModal)
+import TzBot.Slack (BotM, BotState(bsMessageCache), getUserCached, startModal)
 import TzBot.Slack.API
 import TzBot.Slack.API.MessageBlock
   (UnknownBlockElementLevel2Error(ubeType), extractPieces, splitExtractErrors)
+import TzBot.TimeContext
 import TzBot.TimeReference (TimeReference)
 import TzBot.Util (WithUnknown(unUnknown))
 
@@ -45,7 +47,9 @@ openModalCommon
 openModalCommon message channelId whoTriggeredId triggerId mkModalFunc = do
   let msgText = mText message
       msgTimestamp = mTs message
-  mbTimeRefs <- nonEmpty <$> getTimeReferencesFromMessage message
+  mbTimeRefs <- fmap (nonEmpty . fst) $
+    asks bsMessageCache >>= Cache.fetchWithCache msgId \_ ->
+      getTimeReferencesAndNewStateFromMessage emptyTimeContext message
   sender <- getUserCached $ mUser message
   translationPairs <- fmap join $ forM mbTimeRefs $ \neTimeRefs -> do
       whoTriggered <- getUserCached whoTriggeredId
@@ -66,14 +70,22 @@ openModalCommon message channelId whoTriggeredId triggerId mkModalFunc = do
   insertDialogEntry guid metadata
   let modal = mkModalFunc msgText translationPairs guid
   startModal $ OpenViewReq modal triggerId
+  where
+    msgId = mMessageId message
 
 -- | Extract separate text pieces from the Slack message that can contain
 -- the whole time reference and try to find time references inside them.
-getTimeReferencesFromMessage
-  :: Message
-  -> BotM [TimeReference]
-getTimeReferencesFromMessage message =
-  concatMap parseTimeRefs <$> getTextPiecesFromMessage message
+-- Old context (date, timezone, offset, etc.) is used for processing
+-- and new one is produced.
+getTimeReferencesAndNewStateFromMessage
+  :: TimeContext
+  -> Message
+  -> BotM ([TimeReference], TimeContext)
+getTimeReferencesAndNewStateFromMessage oldState message = do
+  pieces <- getTextPiecesFromMessage message
+  pure $
+    first concat $
+      runState (mapM parseTimeRefs pieces) oldState
 
 -- | Extract separate text pieces from the Slack message that can contain
 -- the whole time reference. The main way is analyzing the message's block

src/TzBot/ProcessEvents/Message.hs

@@ -19,12 +19,13 @@ import UnliftIO qualified
 import TzBot.Cache qualified as Cache
 import TzBot.Config (Config(..))
 import TzBot.Logger
-import TzBot.ProcessEvents.Common (getTimeReferencesFromMessage)
+import TzBot.ProcessEvents.Common
 import TzBot.Render
 import TzBot.Slack
 import TzBot.Slack.API
 import TzBot.Slack.Events
 import TzBot.Slack.Fixtures qualified as Fixtures
+import TzBot.TimeContext (emptyTimeContext)
 import TzBot.TimeReference (TimeReference)
 import TzBot.Util (whenT, withMaybe)
 
@@ -80,19 +81,16 @@ processMessageEvent evt =
   katipAddContext (MessageContext msgId) $
   whenJustM (filterMessageTypeWithLog evt) $ \mEventType ->
   whenJustM (withSenderNotBot evt) $ \sender -> do
-    timeRefs <- getTimeReferencesFromMessage msg
-    processMessageEvent' evt mEventType sender timeRefs
+    processMessageEvent' evt mEventType sender
   where
-  msg = meMessage evt
   msgId = mMessageId $ meMessage evt
 
 processMessageEvent'
   :: MessageEvent
   -> MessageEventType
   -> User
-  -> [TimeReference]
   -> BotM ()
-processMessageEvent' evt mEventType sender timeRefs =
+processMessageEvent' evt mEventType sender =
   case meChannelType evt of
     Just CTDirectChannel -> handleDirectMessage
     _ -> case mEventType of
@@ -155,25 +153,52 @@ processMessageEvent' evt mEventType sender timeRefs =
           }
     sendEphemeralMessage req
 
+  -- threadId is the same as its parent's messageId,
+  -- so use messageId if there's no thread yet
+  getMessageThreadId :: ThreadId
+  getMessageThreadId = fromMaybe (ThreadId $ unMessageId msgId) mbThreadId
+
   handleMessageChanged :: BotM ()
   handleMessageChanged = katipAddNamespaceText "edit" do
     messageRefsCache <- asks bsMessageCache
-    mbMessageRefs <- Cache.lookup msgId messageRefsCache
+    convStateCache <- asks bsConversationStateCache
+    mbMessageRefsAndState <- Cache.lookup msgId messageRefsCache
     -- if not found or expired, just ignore this message
     -- it's too old or just didn't contain any time refs
-    whenJust mbMessageRefs $ \oldRefs -> do
-      let newRefsFound = not $ all (`elem` oldRefs) timeRefs
+    whenJust mbMessageRefsAndState $ \(oldRefs, stateBefore) -> do
+      (newRefs, stateAfter) <-
+        getTimeReferencesAndNewStateFromMessage stateBefore msg
+      mbConversationState <- Cache.lookup getMessageThreadId convStateCache
+      -- If the conversation state was defined after processing this
+      -- message, we should update it.
+      whenJust mbConversationState \(lastMsgId, _conversationState) ->
+        when (lastMsgId == msgId) $
+          Cache.insert getMessageThreadId (msgId, stateAfter) convStateCache
+
+      let newRefsFound = not $ all (`elem` oldRefs) newRefs
       -- no new references found, ignoring
-      when newRefsFound $ withNonEmptyTimeRefs timeRefs \neTimeRefs -> do
-        Cache.insert msgId timeRefs messageRefsCache
+      when newRefsFound $ withNonEmptyTimeRefs newRefs \neTimeRefs -> do
+        -- This cache always keeps only "before" state in order to correctly
+        -- translate further edits.
+        Cache.insert msgId (newRefs, stateBefore) messageRefsCache
         permalink <- getMessagePermalinkCached channelId msgId
         handleChannelMessageCommon (Just permalink) neTimeRefs
 
   handleNewMessage :: BotM ()
   handleNewMessage = do
-    withNonEmptyTimeRefs timeRefs $ \neTimeRefs -> do
+    convStateCache <- asks bsConversationStateCache
+    conversationState <-
+      fmap (fromMaybe emptyTimeContext . fmap snd . join) $
+        traverse (\t -> Cache.lookup t convStateCache) mbThreadId
+    (timeRefs, newState) <-
+      getTimeReferencesAndNewStateFromMessage conversationState msg
+    when (not $ null timeRefs) $
       -- save message only if time references are present
-      asks bsMessageCache >>= Cache.insert msgId timeRefs
+      asks bsMessageCache >>= Cache.insert msgId (timeRefs, newState)
+    Cache.insert getMessageThreadId (msgId, newState) convStateCache
+    asks bsMessageCache >>= Cache.insert msgId (timeRefs, conversationState)
+
+    withNonEmptyTimeRefs timeRefs $ \neTimeRefs -> do
       handleChannelMessageCommon Nothing neTimeRefs
 
   handleChannelMessageCommon :: Maybe Text -> NonEmpty TimeReference -> BotM ()
@@ -195,8 +220,9 @@ processMessageEvent' evt mEventType sender timeRefs =
     ephemeralsMailing channelId sendActionLocal
 
   handleDirectMessage :: BotM ()
-  handleDirectMessage =
-    when (mEventType /= METMessageEdited) $
+  handleDirectMessage = when (mEventType /= METMessageEdited) $ do
+    (timeRefs, _stateAfter) <-
+      getTimeReferencesAndNewStateFromMessage emptyTimeContext msg
     withNonEmptyTimeRefs timeRefs $ \neTimeRefs -> do
     -- According to
     -- https://forums.slackcommunity.com/s/question/0D53a00008vsItQCAU

src/TzBot/RunMonad.hs

@@ -17,6 +17,7 @@ import TzBot.Cache (TzCache)
 import TzBot.Config.Types (BotConfig)
 import TzBot.Feedback.Dialog.Types (ReportDialogEntry, ReportDialogId)
 import TzBot.Slack.API
+import TzBot.TimeContext (TimeContext)
 import TzBot.TimeReference
 import TzBot.Util (postfixFields)
 
@@ -32,8 +33,13 @@ data BotState = BotState
   , bsUserInfoCache  :: TzCache UserId User
   , bsConversationMembersCache :: TzCache ChannelId (S.Set UserId)
   , bsReportEntries  :: TzCache ReportDialogId ReportDialogEntry
-  , bsMessageCache   :: TzCache MessageId [TimeReference]
+  , bsMessageCache   :: TzCache MessageId ([TimeReference], TimeContext)
+    -- ^ Used for keeping relevant time references and conversation state
+    -- that was _before_ this message, i.e. applied to time refs of this message.
   , bsMessageLinkCache :: TzCache MessageId Text
+  , bsConversationStateCache :: TzCache ThreadId (MessageId, TimeContext)
+    -- ^ State of a thread: current state and ID of a message which is origin
+    -- of that state
   , bsLogNamespace   :: K.Namespace
   , bsLogContext     :: K.LogContexts
   , bsLogEnv         :: K.LogEnv

src/TzBot/Slack/API.hs

@@ -194,7 +194,7 @@ instance FromJSON ChannelType where
 
 newtype ThreadId = ThreadId { unThreadId :: Text }
   deriving stock (Eq, Show)
-  deriving newtype (ToHttpApiData, FromJSON, ToJSON, Buildable)
+  deriving newtype (ToHttpApiData, FromJSON, ToJSON, Buildable, Hashable)
 
 newtype MessageId = MessageId { unMessageId :: Text }
   deriving stock (Eq, Show, Ord)

src/TzBot/TZ.hs

@@ -24,7 +24,8 @@ import Data.Time.Zones.Types (TZ(..))
 import Data.Vector qualified as VB
 import Data.Vector.Unboxed qualified as VU
 
-import TzBot.TimeReference (DateReference(..), TimeRefSuccess(..), TimeReference(..))
+import TzBot.TimeReference
+  (DateReference(..), TimeRefSuccess(..), TimeReference, TimeReferenceGeneric(..))
 import TzBot.Util (NamedOffset, Offset(..))
 
 -- | Represents a specific change in offset.

src/TzBot/TimeContext.hs

@@ -0,0 +1,23 @@
+
+-- SPDX-FileCopyrightText: 2022 Serokell <https://serokell.io/>
+--
+-- SPDX-License-Identifier: MPL-2.0
+
+module TzBot.TimeContext where
+
+import Universum hiding (many, toList, try)
+
+import Control.Lens.TH (makeLensesWith)
+import TzBot.Instances ()
+import TzBot.TimeReference
+import TzBot.Util
+
+data TimeContext = TimeContext
+  { tcCurrentDateRef :: Maybe (Matched DateReference)
+  , tcCurrentLocRef :: Maybe (Matched LocationReference)
+  } deriving stock (Show, Eq, Generic)
+
+emptyTimeContext :: TimeContext
+emptyTimeContext = TimeContext Nothing Nothing
+
+makeLensesWith postfixFields ''TimeContext

test/Test/TzBot/GetTimeshiftsSpec.hs

@@ -18,7 +18,7 @@ import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=))
 import Text.Interpolation.Nyan
 
-import TzBot.Parser (parseTimeRefs)
+import TzBot.Parser (parseWithEmptyContext)
 import TzBot.TZ (TimeShift(..), checkForTimeshifts, checkForTimeshifts')
 import TzBot.TimeReference (TimeReferenceToUTCResult(..), timeReferenceToUTC)
 import TzBot.Util
@@ -120,7 +120,7 @@ test_checkForTimeshifts =
   where
     check :: UTCTime -> Text -> TZLabel -> TZLabel -> [TimeShift] -> Assertion
     check now input senderTimeZone receiverTimeZone expectedTimeShifts = do
-      case parseTimeRefs input of
+      case parseWithEmptyContext input of
         [timeRef] ->
           case timeReferenceToUTC senderTimeZone now timeRef of
             TRTUSuccess timeRefSuccess ->

test/Test/TzBot/ParserSpec.hs

@@ -15,7 +15,7 @@ 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.Parser (parseWithEmptyContext)
 import TzBot.TimeReference
   (DateReference(..), LocationReference(..), TimeReference, TimeReferenceGeneric(..),
   TimeZoneAbbreviationInfo(..))
@@ -73,35 +73,68 @@ test_parserSpec = TestGroup "ParserBig"
           (Just (DayOfWeekRef Thursday))
           (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"})))
       ]
-  , testCase "Some hyphenated intervals" $
+  , testCase "Some hyphenated intervals, separate date reference" $
     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"
+          "7am UTC (tomorrow)"
           (TimeOfDay 07 00 00)
-          (Nothing)
+          (Just (DaysFromToday 1))
           (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"})))
       , TimeReference
-          "2pm UTC"
+          "2pm UTC (tomorrow)"
           (TimeOfDay 14 00 00)
-          (Nothing)
+          (Just (DaysFromToday 1))
           (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"})))
       , TimeReference
-          "10:30am UTC"
+          "10:30am UTC (tomorrow)"
           (TimeOfDay 10 30 00)
-          (Nothing)
+          (Just (DaysFromToday 1))
           (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"})))
       , TimeReference
-          "12pm UTC"
+          "12pm UTC (tomorrow)"
           (TimeOfDay 12 00 00)
-          (Nothing)
+          (Just (DaysFromToday 1))
+          (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"})))
+      ]
+  , testCase "Pick last date reference" $
+    mkTestCase
+      "I wanted to meet tomorrow, but seems it's not possible... maybe 3rd march? Let's try something between 10am and 11am UTC"
+      [ TimeReference
+          "10am UTC (3rd march)"
+          (TimeOfDay 10 00 00)
+          (Just (DayOfMonthRef 3 (Just (3,Nothing))))
+          (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"})))
+      , TimeReference
+          "11am UTC (3rd march)"
+          (TimeOfDay 11 00 00)
+          (Just (DayOfMonthRef 3 (Just (3,Nothing))))
+          (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"})))
+      ]
+  , testCase "Using location reference from previous full time reference" $
+    mkTestCase
+      "How about tomorrow 8am-12am UTC? For me 9am is the most perfect time"
+      [ TimeReference
+          "tomorrow 8am UTC"
+          (TimeOfDay 08 00 00)
+          (Just (DaysFromToday 1))
+          (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"})))
+      , TimeReference
+          "tomorrow 12am UTC"
+          (TimeOfDay 12 00 00)
+          (Just (DaysFromToday 1))
+          (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"})))
+      , TimeReference
+          "9am (tomorrow) (UTC)"
+          (TimeOfDay 09 00 00)
+          (Just (DaysFromToday 1))
           (Just (TimeZoneAbbreviationRef (TimeZoneAbbreviationInfo {tzaiAbbreviation = "UTC", tzaiOffsetMinutes = 0, tzaiFullName = "UTC"})))
       ]
   ]
 
 mkTestCase :: HasCallStack => Text -> [TimeReference] -> Assertion
 mkTestCase input expectedRefs = do
-  let outputRefs = parseTimeRefs input
+  let outputRefs = parseWithEmptyContext input
   assertRefPairs expectedRefs outputRefs
 
 assertRefPairs :: HasCallStack => [TimeReference] -> [TimeReference] -> Assertion

test/Test/TzBot/RenderSpec.hs

@@ -18,7 +18,7 @@ import Test.Tasty (TestTree)
 import Test.Tasty.HUnit (Assertion, testCase, (@?=))
 import Test.Tasty.Runners (TestTree(..))
 
-import TzBot.Parser (parseTimeRefs)
+import TzBot.Parser (parseWithEmptyContext)
 import TzBot.Render
 import TzBot.Slack.API
 
@@ -246,7 +246,7 @@ translWithCommonNote q w e = TranslationPair q w (Just e) (Just e)
 
 mkTestCase :: ModalFlag -> UTCTime -> Text -> User -> User -> [TranslationPair] -> Assertion
 mkTestCase modalFlag eventTimestamp refText sender otherUser expectedOtherUserTransl = do
-  let [timeRef] = parseTimeRefs refText
+  let [timeRef] = parseWithEmptyContext refText
       ephemeralTemplate =
         renderTemplate modalFlag eventTimestamp sender $
           NE.singleton timeRef

tzbot.cabal

@@ -1,6 +1,6 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.1.
+-- This file has been generated from package.yaml by hpack version 0.34.7.
 --
 -- see: https://github.com/sol/hpack
 
@@ -54,6 +54,7 @@ library
       TzBot.Slack.Events.ViewPayload
       TzBot.Slack.Fixtures
       TzBot.Slack.Modal
+      TzBot.TimeContext
       TzBot.TimeReference
       TzBot.TZ
       TzBot.Util