{-# 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)
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
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
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
matchesEmoji :: T.Text
-> T.Text
-> 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
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