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