{-# LANGUAGE TupleSections #-}
module Matterhorn.State.ReactionEmojiListOverlay
  ( enterReactionEmojiListOverlayMode

  , reactionEmojiListSelectDown
  , reactionEmojiListSelectUp
  , reactionEmojiListPageDown
  , reactionEmojiListPageUp
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import qualified Brick.Widgets.List as L
import qualified Data.Vector as Vec
import qualified Data.Text as T
import qualified Data.Map as M
import qualified Data.Set as Set
import           Data.Function ( on )
import           Data.List ( nubBy )
import           Lens.Micro.Platform ( to )

import           Network.Mattermost.Types
import           Network.Mattermost.Endpoints ( mmPostReaction, mmDeleteReaction )

import           Matterhorn.Emoji
import           Matterhorn.State.ListOverlay
import           Matterhorn.State.MessageSelect
import           Matterhorn.State.Async
import           Matterhorn.Types


enterReactionEmojiListOverlayMode :: MH ()
enterReactionEmojiListOverlayMode :: MH ()
enterReactionEmojiListOverlayMode = do
    Maybe Message
selectedMessage <- Getting (Maybe Message) ChatState (Maybe Message)
-> MH (Maybe Message)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((ChatState -> Maybe Message)
-> SimpleGetter ChatState (Maybe Message)
forall s a. (s -> a) -> SimpleGetter s a
to ChatState -> Maybe Message
getSelectedMessage)
    case Maybe Message
selectedMessage of
        Maybe Message
Nothing -> () -> MH ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Message
msg -> do
            TeamId
tId <- Getting TeamId ChatState TeamId -> MH TeamId
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting TeamId ChatState TeamId
SimpleGetter ChatState TeamId
csCurrentTeamId
            EmojiCollection
em <- Getting EmojiCollection ChatState EmojiCollection
-> MH EmojiCollection
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((ChatResources -> Const EmojiCollection ChatResources)
-> ChatState -> Const EmojiCollection ChatState
Lens' ChatState ChatResources
csResources((ChatResources -> Const EmojiCollection ChatResources)
 -> ChatState -> Const EmojiCollection ChatState)
-> ((EmojiCollection -> Const EmojiCollection EmojiCollection)
    -> ChatResources -> Const EmojiCollection ChatResources)
-> Getting EmojiCollection ChatState EmojiCollection
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(EmojiCollection -> Const EmojiCollection EmojiCollection)
-> ChatResources -> Const EmojiCollection ChatResources
Lens' ChatResources EmojiCollection
crEmoji)
            UserId
myId <- (ChatState -> UserId) -> MH UserId
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ChatState -> UserId
myUserId
            Lens' ChatState (ListOverlayState (Bool, Text) ())
-> Mode
-> ()
-> ((Bool, Text) -> MH Bool)
-> (() -> Session -> Text -> IO (Vector (Bool, Text)))
-> MH ()
forall a b.
Lens' ChatState (ListOverlayState a b)
-> Mode
-> b
-> (a -> MH Bool)
-> (b -> Session -> Text -> IO (Vector a))
-> MH ()
enterListOverlayMode (TeamId -> Lens' ChatState TeamState
csTeam(TeamId
tId)((TeamState -> f TeamState) -> ChatState -> f ChatState)
-> ((ListOverlayState (Bool, Text) ()
     -> f (ListOverlayState (Bool, Text) ()))
    -> TeamState -> f TeamState)
-> (ListOverlayState (Bool, Text) ()
    -> f (ListOverlayState (Bool, Text) ()))
-> ChatState
-> f ChatState
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ListOverlayState (Bool, Text) ()
 -> f (ListOverlayState (Bool, Text) ()))
-> TeamState -> f TeamState
Lens' TeamState (ListOverlayState (Bool, Text) ())
tsReactionEmojiListOverlay) Mode
ReactionEmojiListOverlay
                () (Bool, Text) -> MH Bool
enterHandler (UserId
-> Message
-> EmojiCollection
-> ()
-> Session
-> Text
-> IO (Vector (Bool, Text))
fetchResults UserId
myId Message
msg EmojiCollection
em)

enterHandler :: (Bool, T.Text) -> MH Bool
enterHandler :: (Bool, Text) -> MH Bool
enterHandler (Bool
mine, Text
e) = do
    Session
session <- MH Session
getSession
    UserId
myId <- (ChatState -> UserId) -> MH UserId
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ChatState -> UserId
myUserId

    Maybe Message
selectedMessage <- Getting (Maybe Message) ChatState (Maybe Message)
-> MH (Maybe Message)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((ChatState -> Maybe Message)
-> SimpleGetter ChatState (Maybe Message)
forall s a. (s -> a) -> SimpleGetter s a
to ChatState -> Maybe Message
getSelectedMessage)
    case Maybe Message
selectedMessage of
        Maybe Message
Nothing -> Bool -> MH Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just Message
m -> do
            case Message
mMessage -> 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 of
                Maybe Post
Nothing -> Bool -> MH Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                Just Post
p -> do
                    case Bool
mine of
                        Bool
False ->
                            AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
Preempt (IO (Maybe (MH ())) -> MH ()) -> IO (Maybe (MH ())) -> MH ()
forall a b. (a -> b) -> a -> b
$ do
                                PostId -> UserId -> Text -> Session -> IO ()
mmPostReaction (Post -> PostId
postId Post
p) UserId
myId Text
e Session
session
                                Maybe (MH ()) -> IO (Maybe (MH ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MH ())
forall a. Maybe a
Nothing
                        Bool
True ->
                            AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
Preempt (IO (Maybe (MH ())) -> MH ()) -> IO (Maybe (MH ())) -> MH ()
forall a b. (a -> b) -> a -> b
$ do
                                PostId -> UserId -> Text -> Session -> IO ()
mmDeleteReaction (Post -> PostId
postId Post
p) UserId
myId Text
e Session
session
                                Maybe (MH ()) -> IO (Maybe (MH ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MH ())
forall a. Maybe a
Nothing
                    Bool -> MH Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

fetchResults :: UserId
             -- ^ My user ID, so we can see which reactions I haven't
             -- posted
             -> Message
             -- ^ The selected message, so we can include its current
             -- reactions in the list
             -> EmojiCollection
             -- ^ The emoji collection
             -> ()
             -- ^ The scope to search
             -> Session
             -- ^ The connection session
             -> Text
             -- ^ The search string
             -> IO (Vec.Vector (Bool, T.Text))
fetchResults :: UserId
-> Message
-> EmojiCollection
-> ()
-> Session
-> Text
-> IO (Vector (Bool, Text))
fetchResults UserId
myId Message
msg EmojiCollection
em () Session
session Text
searchString = do
    let currentReactions :: [(Bool, Text)]
currentReactions = [ (UserId
myId UserId -> Set UserId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set UserId
uIds, Text
k)
                           | (Text
k, Set UserId
uIds) <- Map Text (Set UserId) -> [(Text, Set UserId)]
forall k a. Map k a -> [(k, a)]
M.toList (Message
msgMessage
-> Getting (Map Text (Set UserId)) Message (Map Text (Set UserId))
-> Map Text (Set UserId)
forall s a. s -> Getting a s a -> a
^.Getting (Map Text (Set UserId)) Message (Map Text (Set UserId))
Lens' Message (Map Text (Set UserId))
mReactions)
                           ]
        matchingCurrentOtherReactions :: [(Bool, Text)]
matchingCurrentOtherReactions = [ (Bool
mine, Text
r) | (Bool
mine, Text
r) <- [(Bool, Text)]
currentReactions
                                        , Text -> Text -> Bool
matchesEmoji Text
searchString Text
r
                                        , Bool -> Bool
not Bool
mine
                                        ]
        matchingCurrentMyReactions :: [(Bool, Text)]
matchingCurrentMyReactions = [ (Bool
mine, Text
r) | (Bool
mine, Text
r) <- [(Bool, Text)]
currentReactions
                                     , Text -> Text -> Bool
matchesEmoji Text
searchString Text
r
                                     , Bool
mine
                                     ]
    [Text]
serverMatches <- Session -> EmojiCollection -> Text -> IO [Text]
getMatchingEmoji Session
session EmojiCollection
em Text
searchString
    Vector (Bool, Text) -> IO (Vector (Bool, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (Vector (Bool, Text) -> IO (Vector (Bool, Text)))
-> Vector (Bool, Text) -> IO (Vector (Bool, Text))
forall a b. (a -> b) -> a -> b
$ [(Bool, Text)] -> Vector (Bool, Text)
forall a. [a] -> Vector a
Vec.fromList ([(Bool, Text)] -> Vector (Bool, Text))
-> [(Bool, Text)] -> Vector (Bool, Text)
forall a b. (a -> b) -> a -> b
$ ((Bool, Text) -> (Bool, Text) -> Bool)
-> [(Bool, Text)] -> [(Bool, Text)]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Text -> Text -> Bool)
-> ((Bool, Text) -> Text) -> (Bool, Text) -> (Bool, Text) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Bool, Text) -> Text
forall a b. (a, b) -> b
snd) ([(Bool, Text)] -> [(Bool, Text)])
-> [(Bool, Text)] -> [(Bool, Text)]
forall a b. (a -> b) -> a -> b
$
        [(Bool, Text)]
matchingCurrentOtherReactions [(Bool, Text)] -> [(Bool, Text)] -> [(Bool, Text)]
forall a. Semigroup a => a -> a -> a
<> [(Bool, Text)]
matchingCurrentMyReactions [(Bool, Text)] -> [(Bool, Text)] -> [(Bool, Text)]
forall a. Semigroup a => a -> a -> a
<> ((Bool
False,) (Text -> (Bool, Text)) -> [Text] -> [(Bool, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
serverMatches)

-- | Move the selection up in the emoji list overlay by one emoji.
reactionEmojiListSelectUp :: MH ()
reactionEmojiListSelectUp :: MH ()
reactionEmojiListSelectUp = (List Name (Bool, Text) -> List Name (Bool, Text)) -> MH ()
reactionEmojiListMove List Name (Bool, Text) -> List Name (Bool, Text)
forall (t :: * -> *) n e.
(Foldable t, Splittable t) =>
GenericList n t e -> GenericList n t e
L.listMoveUp

-- | Move the selection down in the emoji list overlay by one emoji.
reactionEmojiListSelectDown :: MH ()
reactionEmojiListSelectDown :: MH ()
reactionEmojiListSelectDown = (List Name (Bool, Text) -> List Name (Bool, Text)) -> MH ()
reactionEmojiListMove List Name (Bool, Text) -> List Name (Bool, Text)
forall (t :: * -> *) n e.
(Foldable t, Splittable t) =>
GenericList n t e -> GenericList n t e
L.listMoveDown

-- | Move the selection up in the emoji list overlay by a page of emoji
-- (ReactionEmojiListPageSize).
reactionEmojiListPageUp :: MH ()
reactionEmojiListPageUp :: MH ()
reactionEmojiListPageUp = (List Name (Bool, Text) -> List Name (Bool, Text)) -> MH ()
reactionEmojiListMove (Int -> List Name (Bool, Text) -> List Name (Bool, Text)
forall (t :: * -> *) n e.
(Foldable t, Splittable t) =>
Int -> GenericList n t e -> GenericList n t e
L.listMoveBy (-Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
reactionEmojiListPageSize))

-- | Move the selection down in the emoji list overlay by a page of emoji
-- (ReactionEmojiListPageSize).
reactionEmojiListPageDown :: MH ()
reactionEmojiListPageDown :: MH ()
reactionEmojiListPageDown = (List Name (Bool, Text) -> List Name (Bool, Text)) -> MH ()
reactionEmojiListMove (Int -> List Name (Bool, Text) -> List Name (Bool, Text)
forall (t :: * -> *) n e.
(Foldable t, Splittable t) =>
Int -> GenericList n t e -> GenericList n t e
L.listMoveBy Int
reactionEmojiListPageSize)

-- | Transform the emoji list results in some way, e.g. by moving the
-- cursor, and then check to see whether the modification warrants a
-- prefetch of more search results.
reactionEmojiListMove :: (L.List Name (Bool, T.Text) -> L.List Name (Bool, T.Text)) -> MH ()
reactionEmojiListMove :: (List Name (Bool, Text) -> List Name (Bool, Text)) -> MH ()
reactionEmojiListMove = Lens' ChatState (ListOverlayState (Bool, Text) ())
-> (List Name (Bool, Text) -> List Name (Bool, Text)) -> MH ()
forall a b.
Lens' ChatState (ListOverlayState a b)
-> (List Name a -> List Name a) -> MH ()
listOverlayMove ((TeamState -> f TeamState) -> ChatState -> f ChatState
Lens' ChatState TeamState
csCurrentTeam((TeamState -> f TeamState) -> ChatState -> f ChatState)
-> ((ListOverlayState (Bool, Text) ()
     -> f (ListOverlayState (Bool, Text) ()))
    -> TeamState -> f TeamState)
-> (ListOverlayState (Bool, Text) ()
    -> f (ListOverlayState (Bool, Text) ()))
-> ChatState
-> f ChatState
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(ListOverlayState (Bool, Text) ()
 -> f (ListOverlayState (Bool, Text) ()))
-> TeamState -> f TeamState
Lens' TeamState (ListOverlayState (Bool, Text) ())
tsReactionEmojiListOverlay)

-- | The number of emoji in a "page" for cursor movement purposes.
reactionEmojiListPageSize :: Int
reactionEmojiListPageSize :: Int
reactionEmojiListPageSize = Int
10