{-# 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
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 = String -> (Array -> Parser EmojiData) -> Value -> Parser EmojiData
forall a. String -> (Array -> Parser a) -> Value -> Parser a
A.withArray String
"EmojiData" ((Array -> Parser EmojiData) -> Value -> Parser EmojiData)
-> (Array -> Parser EmojiData) -> Value -> Parser EmojiData
forall a b. (a -> b) -> a -> b
$ \Array
v -> do
        Vector (Seq Text)
aliasVecs <- Array -> (Value -> Parser (Seq Text)) -> Parser (Vector (Seq Text))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Array
v ((Value -> Parser (Seq Text)) -> Parser (Vector (Seq Text)))
-> (Value -> Parser (Seq Text)) -> Parser (Vector (Seq Text))
forall a b. (a -> b) -> a -> b
$ \Value
val ->
            ((Object -> Parser (Seq Text)) -> Value -> Parser (Seq Text))
-> Value -> (Object -> Parser (Seq Text)) -> Parser (Seq Text)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String
-> (Object -> Parser (Seq Text)) -> Value -> Parser (Seq Text)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"EmojiData Entry") Value
val ((Object -> Parser (Seq Text)) -> Parser (Seq Text))
-> (Object -> Parser (Seq Text)) -> Parser (Seq Text)
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
                Seq Value
as <- Object
obj Object -> Text -> Parser (Seq Value)
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"aliases"
                Seq Value -> (Value -> Parser Text) -> Parser (Seq Text)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Seq Value
as ((Value -> Parser Text) -> Parser (Seq Text))
-> (Value -> Parser Text) -> Parser (Seq Text)
forall a b. (a -> b) -> a -> b
$ String -> (Text -> Parser Text) -> Value -> Parser Text
forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
"Alias list element" Text -> Parser Text
forall (m :: * -> *) a. Monad m => a -> m a
return

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

emptyEmojiCollection :: EmojiCollection
emptyEmojiCollection :: EmojiCollection
emptyEmojiCollection = [Text] -> EmojiCollection
EmojiCollection [Text]
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 = ExceptT String IO EmojiCollection
-> IO (Either String EmojiCollection)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO EmojiCollection
 -> IO (Either String EmojiCollection))
-> ExceptT String IO EmojiCollection
-> IO (Either String EmojiCollection)
forall a b. (a -> b) -> a -> b
$ do
    Either SomeException ByteString
result <- IO (Either SomeException ByteString)
-> ExceptT String IO (Either SomeException ByteString)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either SomeException ByteString)
 -> ExceptT String IO (Either SomeException ByteString))
-> IO (Either SomeException ByteString)
-> ExceptT String IO (Either SomeException ByteString)
forall a b. (a -> b) -> a -> b
$ IO ByteString -> IO (Either SomeException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO ByteString -> IO (Either SomeException ByteString))
-> IO ByteString -> IO (Either SomeException ByteString)
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) -> String -> ExceptT String IO EmojiCollection
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> ExceptT String IO EmojiCollection)
-> String -> ExceptT String IO EmojiCollection
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
        Right ByteString
bs -> do
            EmojiData Seq Text
es <- IO (Either String EmojiData) -> ExceptT String IO EmojiData
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (IO (Either String EmojiData) -> ExceptT String IO EmojiData)
-> IO (Either String EmojiData) -> ExceptT String IO EmojiData
forall a b. (a -> b) -> a -> b
$ Either String EmojiData -> IO (Either String EmojiData)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String EmojiData -> IO (Either String EmojiData))
-> Either String EmojiData -> IO (Either String EmojiData)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String EmojiData
forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode ByteString
bs
            EmojiCollection -> ExceptT String IO EmojiCollection
forall (m :: * -> *) a. Monad m => a -> m a
return (EmojiCollection -> ExceptT String IO EmojiCollection)
-> EmojiCollection -> ExceptT String IO EmojiCollection
forall a b. (a -> b) -> a -> b
$ [Text] -> EmojiCollection
EmojiCollection ([Text] -> EmojiCollection) -> [Text] -> EmojiCollection
forall a b. (a -> b) -> a -> b
$ Text -> Text
T.toLower (Text -> Text) -> [Text] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq Text -> [Text]
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 =
    (Text -> Bool) -> [Text] -> [Text]
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 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower (Text -> Text) -> (Text -> Text) -> Text -> Text
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 <- IO [Emoji] -> IO (Either SomeException [Emoji])
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO [Emoji] -> IO (Either SomeException [Emoji]))
-> IO [Emoji] -> IO (Either SomeException [Emoji])
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 Maybe Integer
forall a. Maybe a
Nothing Maybe Integer
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 (_::E.SomeException) -> []
            Right [Emoji]
result -> [Emoji]
result

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

stripColons :: T.Text -> T.Text
stripColons :: Text -> Text
stripColons Text
t =
    Text -> Text
stripHeadColon (Text -> Text) -> Text -> Text
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