Remind contexts and apply to time refs

.gitignore

@@ -11,3 +11,5 @@ stack-hie.yaml*
 .vscode/
 result
 *.txt
+stack-hie.yaml
+stack-hie.yaml.lock

package.yaml

@@ -110,6 +110,7 @@ tests:
     - tasty-hspec
     - tasty-hunit
     - tasty-quickcheck
+    - text
     - time
     - tztime
     - QuickCheck

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,13 +19,14 @@ 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.TimeReference (TimeReference(..))
+import TzBot.TimeContext (emptyTimeContext)
+import TzBot.TimeReference (TimeReference)
 import TzBot.Util (whenT, withMaybe)
 
 data MessageEventType = METMessage | METMessageEdited
@@ -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

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 text
+  , 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

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

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 ->