1{-# LANGUAGE ScopedTypeVariables #-}
2module Matterhorn.Emoji
3  ( EmojiCollection
4  , loadEmoji
5  , emptyEmojiCollection
6  , getMatchingEmoji
7  , matchesEmoji
8  )
9where
10
11import           Prelude ()
12import           Matterhorn.Prelude
13
14import qualified Control.Exception as E
15import           Control.Monad.Except
16import qualified Data.Aeson as A
17import qualified Data.ByteString.Lazy as BSL
18import qualified Data.Foldable as F
19import qualified Data.Text as T
20import qualified Data.Sequence as Seq
21
22import           Network.Mattermost.Types ( Session )
23import qualified Network.Mattermost.Endpoints as MM
24
25
26newtype EmojiData = EmojiData (Seq.Seq T.Text)
27
28-- | The collection of all emoji names we loaded from a JSON disk file.
29-- You might rightly ask: why don't we use a Trie here, for efficient
30-- lookups? The answer is that we need infix lookups; prefix matches are
31-- not enough. In practice it seems not to matter that much; despite the
32-- O(n) search we get good enough performance that we aren't worried
33-- about this. If at some point this becomes an issue, other data
34-- structures with good infix lookup performance should be identified
35-- (full-text search, perhaps?).
36newtype EmojiCollection = EmojiCollection [T.Text]
37
38instance A.FromJSON EmojiData where
39    parseJSON = A.withArray "EmojiData" $ \v -> do
40        aliasVecs <- forM v $ \val ->
41            flip (A.withObject "EmojiData Entry") val $ \obj -> do
42                as <- obj A..: "aliases"
43                forM as $ A.withText "Alias list element" return
44
45        return $ EmojiData $ mconcat $ F.toList aliasVecs
46
47emptyEmojiCollection :: EmojiCollection
48emptyEmojiCollection = EmojiCollection mempty
49
50-- | Load an EmojiCollection from a JSON disk file.
51loadEmoji :: FilePath -> IO (Either String EmojiCollection)
52loadEmoji path = runExceptT $ do
53    result <- lift $ E.try $ BSL.readFile path
54    case result of
55        Left (e::E.SomeException) -> throwError $ show e
56        Right bs -> do
57            EmojiData es <- ExceptT $ return $ A.eitherDecode bs
58            return $ EmojiCollection $ T.toLower <$> F.toList es
59
60-- | Look up matching emoji in the collection using the provided search
61-- string. This does a case-insensitive infix match. The search string
62-- may be provided with or without leading and trailing colons.
63lookupEmoji :: EmojiCollection -> T.Text -> [T.Text]
64lookupEmoji (EmojiCollection es) search =
65    filter (matchesEmoji search) es
66
67-- | Match a search string against an emoji.
68matchesEmoji :: T.Text
69             -- ^ The search string (will be converted to lowercase and
70             -- colons will be removed)
71             -> T.Text
72             -- ^ The emoji string (assumed to be lowercase and without
73             -- leading/trailing colons)
74             -> Bool
75matchesEmoji searchString e =
76    sanitizeEmojiSearch searchString `T.isInfixOf` e
77
78sanitizeEmojiSearch :: T.Text -> T.Text
79sanitizeEmojiSearch = stripColons . T.toLower . T.strip
80
81-- | Perform an emoji search against both the local EmojiCollection as
82-- well as the server's custom emoji. Return the results, sorted. If the
83-- empty string is specified, all local and all custom emoji will be
84-- included in the returned list.
85getMatchingEmoji :: Session -> EmojiCollection -> T.Text -> IO [T.Text]
86getMatchingEmoji session em rawSearchString = do
87    let localAlts = lookupEmoji em rawSearchString
88        sanitized = sanitizeEmojiSearch rawSearchString
89    customResult <- E.try $ case T.null sanitized of
90        True -> MM.mmGetListOfCustomEmoji Nothing Nothing session
91        False -> MM.mmSearchCustomEmoji sanitized session
92
93    let custom = case customResult of
94            Left (_::E.SomeException) -> []
95            Right result -> result
96
97    return $ sort $ (MM.emojiName <$> custom) <> localAlts
98
99stripColons :: T.Text -> T.Text
100stripColons t =
101    stripHeadColon $ stripTailColon t
102    where
103        stripHeadColon v = if ":" `T.isPrefixOf` v
104                           then T.tail v
105                           else v
106        stripTailColon v = if ":" `T.isSuffixOf` v
107                           then T.init v
108                           else v
109