{-# LANGUAGE ScopedTypeVariables #-}
module Matterhorn.Emoji
  ( EmojiCollection
  , loadEmoji
  , emptyEmojiCollection
  , getMatchingEmoji
  , matchesEmoji
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import qualified Control.Exception as E
import           Control.Monad.Except ( MonadError(..), ExceptT(..), runExceptT )
import           Control.Monad.Trans ( MonadTrans(..) )
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Foldable as F
import qualified Data.Text as T
import qualified Data.Sequence as Seq

import           Network.Mattermost.Types ( Session )
import qualified Network.Mattermost.Endpoints as MM


newtype EmojiData = EmojiData (Seq.Seq T.Text)

-- | The collection of all emoji names we loaded from a JSON disk file.
-- You might rightly ask: why don't we use a Trie here, for efficient
-- lookups? The answer is that we need infix lookups; prefix matches are
-- not enough. In practice it seems not to matter that much; despite the
-- O(n) search we get good enough performance that we aren't worried
-- about this. If at some point this becomes an issue, other data
-- structures with good infix lookup performance should be identified
-- (full-text search, perhaps?).
newtype EmojiCollection = EmojiCollection [T.Text]

instance A.FromJSON EmojiData where
    parseJSON :: Value -> Parser EmojiData
parseJSON = forall a. String -> (Array -> Parser a) -> Value -> Parser a
A.withArray String
"EmojiData" forall a b. (a -> b) -> a -> b
$ \Array
v -> do
        Vector (Seq Text)
aliasVecs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Array
v forall a b. (a -> b) -> a -> b
$ \Value
val ->
            forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"EmojiData Entry") Value
val forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
                Seq Value
as <- Object
obj forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"short_names"
                forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Seq Value
as forall a b. (a -> b) -> a -> b
$ forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
"Alias list element" forall (m :: * -> *) a. Monad m => a -> m a
return

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Seq Text -> EmojiData
EmojiData forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Vector (Seq Text)
aliasVecs

emptyEmojiCollection :: EmojiCollection
emptyEmojiCollection :: EmojiCollection
emptyEmojiCollection = [Text] -> EmojiCollection
EmojiCollection forall a. Monoid a => a
mempty

-- | Load an EmojiCollection from a JSON disk file.
loadEmoji :: FilePath -> IO (Either String EmojiCollection)
loadEmoji :: String -> IO (Either String EmojiCollection)
loadEmoji String
path = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
    Either SomeException ByteString
result <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
E.try forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BSL.readFile String
path
    case Either SomeException ByteString
result of
        Left (SomeException
e::E.SomeException) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
e
        Right ByteString
bs -> do
            EmojiData Seq Text
es <- forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode ByteString
bs
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Text] -> EmojiCollection
EmojiCollection forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Seq Text
es

-- | Look up matching emoji in the collection using the provided search
-- string. This does a case-insensitive infix match. The search string
-- may be provided with or without leading and trailing colons.
lookupEmoji :: EmojiCollection -> T.Text -> [T.Text]
lookupEmoji :: EmojiCollection -> Text -> [Text]
lookupEmoji (EmojiCollection [Text]
es) Text
search =
    forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
matchesEmoji Text
search) [Text]
es

-- | Match a search string against an emoji.
matchesEmoji :: T.Text
             -- ^ The search string (will be converted to lowercase and
             -- colons will be removed)
             -> T.Text
             -- ^ The emoji string (assumed to be lowercase and without
             -- leading/trailing colons)
             -> Bool
matchesEmoji :: Text -> Text -> Bool
matchesEmoji Text
searchString Text
e =
    Text -> Text
sanitizeEmojiSearch Text
searchString Text -> Text -> Bool
`T.isInfixOf` Text
e

sanitizeEmojiSearch :: T.Text -> T.Text
sanitizeEmojiSearch :: Text -> Text
sanitizeEmojiSearch = Text -> Text
stripColons forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip

-- | Perform an emoji search against both the local EmojiCollection as
-- well as the server's custom emoji. Return the results, sorted. If the
-- empty string is specified, all local and all custom emoji will be
-- included in the returned list.
getMatchingEmoji :: Session -> EmojiCollection -> T.Text -> IO [T.Text]
getMatchingEmoji :: Session -> EmojiCollection -> Text -> IO [Text]
getMatchingEmoji Session
session EmojiCollection
em Text
rawSearchString = do
    let localAlts :: [Text]
localAlts = EmojiCollection -> Text -> [Text]
lookupEmoji EmojiCollection
em Text
rawSearchString
        sanitized :: Text
sanitized = Text -> Text
sanitizeEmojiSearch Text
rawSearchString
    Either SomeException [Emoji]
customResult <- forall e a. Exception e => IO a -> IO (Either e a)
E.try forall a b. (a -> b) -> a -> b
$ case Text -> Bool
T.null Text
sanitized of
        Bool
True -> Maybe Integer -> Maybe Integer -> Session -> IO [Emoji]
MM.mmGetListOfCustomEmoji forall a. Maybe a
Nothing forall a. Maybe a
Nothing Session
session
        Bool
False -> Text -> Session -> IO [Emoji]
MM.mmSearchCustomEmoji Text
sanitized Session
session

    let custom :: [Emoji]
custom = case Either SomeException [Emoji]
customResult of
            Left (SomeException
_::E.SomeException) -> []
            Right [Emoji]
result -> [Emoji]
result

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ (Emoji -> Text
MM.emojiName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Emoji]
custom) forall a. Semigroup a => a -> a -> a
<> [Text]
localAlts

stripColons :: T.Text -> T.Text
stripColons :: Text -> Text
stripColons Text
t =
    Text -> Text
stripHeadColon forall a b. (a -> b) -> a -> b
$ Text -> Text
stripTailColon Text
t
    where
        stripHeadColon :: Text -> Text
stripHeadColon Text
v = if Text
":" Text -> Text -> Bool
`T.isPrefixOf` Text
v
                           then Text -> Text
T.tail Text
v
                           else Text
v
        stripTailColon :: Text -> Text
stripTailColon Text
v = if Text
":" Text -> Text -> Bool
`T.isSuffixOf` Text
v
                           then Text -> Text
T.init Text
v
                           else Text
v