module Matterhorn.State.ThreadWindow
( openThreadWindow
, closeThreadWindow
)
where
import Prelude ()
import Matterhorn.Prelude
import qualified Data.HashMap.Strict as HM
import Lens.Micro.Platform ( (.=), _Just )
import Network.Mattermost.Types (TeamId, PostId, ChannelId)
import qualified Network.Mattermost.Types as MM
import qualified Network.Mattermost.Endpoints as MM
import Network.Mattermost.Lenses
import Matterhorn.Types
import Matterhorn.State.Common
import Matterhorn.State.Teams ( newThreadInterface )
import {-# SOURCE #-} Matterhorn.State.Messages
openThreadWindow :: TeamId -> ChannelId -> PostId -> MH ()
openThreadWindow :: TeamId -> ChannelId -> PostId -> MH ()
openThreadWindow TeamId
tId ChannelId
cId PostId
pId = do
Maybe PostId
mPid <- Getting (First PostId) ChatState PostId -> MH (Maybe PostId)
forall s (m :: * -> *) a.
MonadState s m =>
Getting (First a) s a -> m (Maybe a)
preuse (TeamId -> Lens' ChatState (Maybe ThreadInterface)
maybeThreadInterface(TeamId
tId)((Maybe ThreadInterface
-> Const (First PostId) (Maybe ThreadInterface))
-> ChatState -> Const (First PostId) ChatState)
-> ((PostId -> Const (First PostId) PostId)
-> Maybe ThreadInterface
-> Const (First PostId) (Maybe ThreadInterface))
-> Getting (First PostId) ChatState PostId
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ThreadInterface -> Const (First PostId) ThreadInterface)
-> Maybe ThreadInterface
-> Const (First PostId) (Maybe ThreadInterface)
forall a a' (f :: * -> *).
Applicative f =>
(a -> f a') -> Maybe a -> f (Maybe a')
_Just((ThreadInterface -> Const (First PostId) ThreadInterface)
-> Maybe ThreadInterface
-> Const (First PostId) (Maybe ThreadInterface))
-> ((PostId -> Const (First PostId) PostId)
-> ThreadInterface -> Const (First PostId) ThreadInterface)
-> (PostId -> Const (First PostId) PostId)
-> Maybe ThreadInterface
-> Const (First PostId) (Maybe ThreadInterface)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PostId -> Const (First PostId) PostId)
-> ThreadInterface -> Const (First PostId) ThreadInterface
forall n i1 i2 (f :: * -> *).
Functor f =>
(i1 -> f i2) -> MessageInterface n i1 -> f (MessageInterface n i2)
miRootPostId)
Bool -> MH () -> MH ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Maybe PostId
mPid Maybe PostId -> Maybe PostId -> Bool
forall a. Eq a => a -> a -> Bool
== PostId -> Maybe PostId
forall a. a -> Maybe a
Just PostId
pId)) (MH () -> MH ()) -> MH () -> MH ()
forall a b. (a -> b) -> a -> b
$ do
AsyncPriority
-> (Session -> IO Posts) -> (Posts -> Maybe (MH ())) -> MH ()
forall a.
AsyncPriority -> (Session -> IO a) -> (a -> Maybe (MH ())) -> MH ()
doAsyncMM AsyncPriority
Preempt Session -> IO Posts
getThread Posts -> Maybe (MH ())
processThread
where getThread :: Session -> IO Posts
getThread Session
session = PostId -> Session -> IO Posts
MM.mmGetThread PostId
pId Session
session
processThread :: Posts -> Maybe (MH ())
processThread Posts
posts = MH () -> Maybe (MH ())
forall a. a -> Maybe a
Just (MH () -> Maybe (MH ())) -> MH () -> Maybe (MH ())
forall a b. (a -> b) -> a -> b
$ do
let numPosts :: Int
numPosts = HashMap PostId Post -> Int
forall k v. HashMap k v -> Int
HM.size (Posts -> HashMap PostId Post
MM.postsPosts Posts
posts)
Bool -> MH () -> MH ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numPosts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (MH () -> MH ()) -> MH () -> MH ()
forall a b. (a -> b) -> a -> b
$ do
BChan MHEvent
eventQueue <- Getting (BChan MHEvent) ChatState (BChan MHEvent)
-> MH (BChan MHEvent)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((ChatResources -> Const (BChan MHEvent) ChatResources)
-> ChatState -> Const (BChan MHEvent) ChatState
Lens' ChatState ChatResources
csResources((ChatResources -> Const (BChan MHEvent) ChatResources)
-> ChatState -> Const (BChan MHEvent) ChatState)
-> ((BChan MHEvent -> Const (BChan MHEvent) (BChan MHEvent))
-> ChatResources -> Const (BChan MHEvent) ChatResources)
-> Getting (BChan MHEvent) ChatState (BChan MHEvent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(BChan MHEvent -> Const (BChan MHEvent) (BChan MHEvent))
-> ChatResources -> Const (BChan MHEvent) ChatResources
Lens' ChatResources (BChan MHEvent)
crEventQueue)
Messages
msgs <- Maybe TeamId -> Posts -> MH Messages
installMessagesFromPosts (TeamId -> Maybe TeamId
forall a. a -> Maybe a
Just TeamId
tId) Posts
posts
(Post -> MH PostProcessMessageAdd) -> [Post] -> MH ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> Bool -> PostToAdd -> MH PostProcessMessageAdd
addMessageToState Bool
False Bool
False (PostToAdd -> MH PostProcessMessageAdd)
-> (Post -> PostToAdd) -> Post -> MH PostProcessMessageAdd
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Post -> PostToAdd
OldPost)
[ (Posts
postsPosts
-> Getting (HashMap PostId Post) Posts (HashMap PostId Post)
-> HashMap PostId Post
forall s a. s -> Getting a s a -> a
^.Getting (HashMap PostId Post) Posts (HashMap PostId Post)
Lens' Posts (HashMap PostId Post)
postsPostsL) HashMap PostId Post -> PostId -> Post
forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
HM.! PostId
p
| PostId
p <- Seq PostId -> [PostId]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Posts
postsPosts -> Getting (Seq PostId) Posts (Seq PostId) -> Seq PostId
forall s a. s -> Getting a s a -> a
^.Getting (Seq PostId) Posts (Seq PostId)
Lens' Posts (Seq PostId)
postsOrderL)
]
ChatState
st <- Getting ChatState ChatState ChatState -> MH ChatState
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting ChatState ChatState ChatState
forall a. a -> a
id
case ChatState -> PostId -> Maybe Message
getMessageForPostId ChatState
st PostId
pId of
Just Message
rootMsg | Just Post
rootPost <- Message
rootMsgMessage -> Getting (Maybe Post) Message (Maybe Post) -> Maybe Post
forall s a. s -> Getting a s a -> a
^.Getting (Maybe Post) Message (Maybe Post)
Lens' Message (Maybe Post)
mOriginalPost -> do
Maybe Aspell
checker <- Getting (Maybe Aspell) ChatState (Maybe Aspell)
-> MH (Maybe Aspell)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((ChatResources -> Const (Maybe Aspell) ChatResources)
-> ChatState -> Const (Maybe Aspell) ChatState
Lens' ChatState ChatResources
csResources((ChatResources -> Const (Maybe Aspell) ChatResources)
-> ChatState -> Const (Maybe Aspell) ChatState)
-> ((Maybe Aspell -> Const (Maybe Aspell) (Maybe Aspell))
-> ChatResources -> Const (Maybe Aspell) ChatResources)
-> Getting (Maybe Aspell) ChatState (Maybe Aspell)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe Aspell -> Const (Maybe Aspell) (Maybe Aspell))
-> ChatResources -> Const (Maybe Aspell) ChatResources
Lens' ChatResources (Maybe Aspell)
crSpellChecker)
ThreadInterface
ti <- IO ThreadInterface -> MH ThreadInterface
forall a. IO a -> MH a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadInterface -> MH ThreadInterface)
-> IO ThreadInterface -> MH ThreadInterface
forall a b. (a -> b) -> a -> b
$ Maybe Aspell
-> BChan MHEvent
-> TeamId
-> ChannelId
-> Message
-> Post
-> Messages
-> IO ThreadInterface
newThreadInterface Maybe Aspell
checker BChan MHEvent
eventQueue TeamId
tId ChannelId
cId Message
rootMsg Post
rootPost Messages
msgs
TeamId -> Lens' ChatState TeamState
csTeam(TeamId
tId)((TeamState -> Identity TeamState)
-> ChatState -> Identity ChatState)
-> ((Maybe ThreadInterface -> Identity (Maybe ThreadInterface))
-> TeamState -> Identity TeamState)
-> (Maybe ThreadInterface -> Identity (Maybe ThreadInterface))
-> ChatState
-> Identity ChatState
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe ThreadInterface -> Identity (Maybe ThreadInterface))
-> TeamState -> Identity TeamState
Lens' TeamState (Maybe ThreadInterface)
tsThreadInterface ((Maybe ThreadInterface -> Identity (Maybe ThreadInterface))
-> ChatState -> Identity ChatState)
-> Maybe ThreadInterface -> MH ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= ThreadInterface -> Maybe ThreadInterface
forall a. a -> Maybe a
Just ThreadInterface
ti
TeamId -> Lens' ChatState TeamState
csTeam(TeamId
tId)((TeamState -> Identity TeamState)
-> ChatState -> Identity ChatState)
-> ((MessageInterfaceFocus -> Identity MessageInterfaceFocus)
-> TeamState -> Identity TeamState)
-> (MessageInterfaceFocus -> Identity MessageInterfaceFocus)
-> ChatState
-> Identity ChatState
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(MessageInterfaceFocus -> Identity MessageInterfaceFocus)
-> TeamState -> Identity TeamState
Lens' TeamState MessageInterfaceFocus
tsMessageInterfaceFocus ((MessageInterfaceFocus -> Identity MessageInterfaceFocus)
-> ChatState -> Identity ChatState)
-> MessageInterfaceFocus -> MH ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= MessageInterfaceFocus
FocusThread
Maybe ChannelId
mcId <- Getting (Maybe ChannelId) ChatState (Maybe ChannelId)
-> MH (Maybe ChannelId)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (TeamId -> SimpleGetter ChatState (Maybe ChannelId)
csCurrentChannelId(TeamId
tId))
case Maybe ChannelId
mcId of
Just ChannelId
curId -> ChannelId -> MH ()
invalidateChannelRenderingCache ChannelId
curId
Maybe ChannelId
Nothing -> () -> MH ()
forall a. a -> MH a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe Message
_ -> [Char] -> MH ()
forall a. HasCallStack => [Char] -> a
error [Char]
"BUG: openThreadWindow failed to find the root message"
closeThreadWindow :: TeamId -> MH ()
closeThreadWindow :: TeamId -> MH ()
closeThreadWindow TeamId
tId = do
TeamId -> Lens' ChatState TeamState
csTeam(TeamId
tId)((TeamState -> Identity TeamState)
-> ChatState -> Identity ChatState)
-> ((Maybe ThreadInterface -> Identity (Maybe ThreadInterface))
-> TeamState -> Identity TeamState)
-> (Maybe ThreadInterface -> Identity (Maybe ThreadInterface))
-> ChatState
-> Identity ChatState
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe ThreadInterface -> Identity (Maybe ThreadInterface))
-> TeamState -> Identity TeamState
Lens' TeamState (Maybe ThreadInterface)
tsThreadInterface ((Maybe ThreadInterface -> Identity (Maybe ThreadInterface))
-> ChatState -> Identity ChatState)
-> Maybe ThreadInterface -> MH ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe ThreadInterface
forall a. Maybe a
Nothing
TeamId -> Lens' ChatState TeamState
csTeam(TeamId
tId)((TeamState -> Identity TeamState)
-> ChatState -> Identity ChatState)
-> ((MessageInterfaceFocus -> Identity MessageInterfaceFocus)
-> TeamState -> Identity TeamState)
-> (MessageInterfaceFocus -> Identity MessageInterfaceFocus)
-> ChatState
-> Identity ChatState
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(MessageInterfaceFocus -> Identity MessageInterfaceFocus)
-> TeamState -> Identity TeamState
Lens' TeamState MessageInterfaceFocus
tsMessageInterfaceFocus ((MessageInterfaceFocus -> Identity MessageInterfaceFocus)
-> ChatState -> Identity ChatState)
-> MessageInterfaceFocus -> MH ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= MessageInterfaceFocus
FocusCurrentChannel
Maybe ChannelId
mcId <- Getting (Maybe ChannelId) ChatState (Maybe ChannelId)
-> MH (Maybe ChannelId)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (TeamId -> SimpleGetter ChatState (Maybe ChannelId)
csCurrentChannelId(TeamId
tId))
case Maybe ChannelId
mcId of
Just ChannelId
curId -> ChannelId -> MH ()
invalidateChannelRenderingCache ChannelId
curId
Maybe ChannelId
Nothing -> () -> MH ()
forall a. a -> MH a
forall (m :: * -> *) a. Monad m => a -> m a
return ()