{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Emoji
( emojis
, emojiFromAlias
, aliasesFromEmoji
, replaceEmojis
, baseEmojis
, zwjEmojis
) where

import Prelude
import Data.Char (chr, ord)
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text as T
import Data.Bifunctor (first)
import Trie as Trie
import Data.List (foldl')

emojiMap :: M.Map Text Text
emojiMap :: Map Text Text
emojiMap = [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, Text)]
emojis

emojiAliasMap :: M.Map Text [Text]
emojiAliasMap :: Map Text [Text]
emojiAliasMap =
  (Map Text [Text] -> (Text, Text) -> Map Text [Text])
-> Map Text [Text] -> [(Text, Text)] -> Map Text [Text]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map Text [Text]
m (Text
alias, Text
s) -> (Maybe [Text] -> Maybe [Text])
-> Text -> Map Text [Text] -> Map Text [Text]
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (Text -> Maybe [Text] -> Maybe [Text]
forall {a}. a -> Maybe [a] -> Maybe [a]
go Text
alias) Text
s Map Text [Text]
m) Map Text [Text]
forall a. Monoid a => a
mempty [(Text, Text)]
emojis
    where
     go :: a -> Maybe [a] -> Maybe [a]
go a
alias Maybe [a]
Nothing   = [a] -> Maybe [a]
forall a. a -> Maybe a
Just [a
alias]
     go a
alias (Just [a]
as) = [a] -> Maybe [a]
forall a. a -> Maybe a
Just (a
aliasa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
as)

-- | Lookup an emoji given its alias.
emojiFromAlias :: Text -> Maybe Text
emojiFromAlias :: Text -> Maybe Text
emojiFromAlias Text
name = Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name Map Text Text
emojiMap

-- | Lookup the aliases of an emoji.
aliasesFromEmoji :: Text -> Maybe [Text]
aliasesFromEmoji :: Text -> Maybe [Text]
aliasesFromEmoji Text
s = Text -> Map Text [Text] -> Maybe [Text]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
s Map Text [Text]
emojiAliasMap

-- | Replace emojis in a text with alternative text.
-- The replacement function maps an emoji and a list of emoji aliases
-- to a replacement text.
replaceEmojis :: (Text -> [Text] -> Text) -> Text -> Text
replaceEmojis :: (Text -> [Text] -> Text) -> Text -> Text
replaceEmojis Text -> [Text] -> Text
getReplacement = [Int] -> Text
fromCodePoints ([Int] -> Text) -> (Text -> [Int]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [Int]
go ([Int] -> [Int]) -> (Text -> [Int]) -> Text -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Int]
toCodePoints
 where
   go :: [Int] -> [Int]
go [] = []
   go (Int
c:[Int]
cs) =
       case Trie [Text] -> [Int] -> Maybe ([Text], Int, Trie [Text])
forall (t :: * -> *) a.
Foldable t =>
Trie a -> t Int -> Maybe (a, Int, Trie a)
Trie.matchLongestPrefix Trie [Text]
emojiTrie (Int
cInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
cs) of
         Just ([Text]
aliases, Int
numcps, Trie [Text]
_subtrie) ->
           let ([Int]
consumed, [Int]
remaining) = Int -> [Int] -> ([Int], [Int])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
numcps (Int
cInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
cs)
            in Text -> [Int]
toCodePoints (Text -> [Text] -> Text
getReplacement ([Int] -> Text
fromCodePoints [Int]
consumed) [Text]
aliases)
                 [Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> [Int] -> [Int]
go [Int]
remaining
         Maybe ([Text], Int, Trie [Text])
Nothing -> -- go forward one UTF8 code point
           Int
c Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int] -> [Int]
go [Int]
cs

toCodePoints :: Text -> [Int]
toCodePoints :: Text -> [Int]
toCodePoints = (Char -> Int) -> [Char] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
ord ([Char] -> [Int]) -> (Text -> [Char]) -> Text -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack

fromCodePoints :: [Int] -> Text
fromCodePoints :: [Int] -> Text
fromCodePoints = [Char] -> Text
T.pack ([Char] -> Text) -> ([Int] -> [Char]) -> [Int] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Char) -> [Int] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
chr

emojiTrie :: Trie.Trie [Text]
emojiTrie :: Trie [Text]
emojiTrie =
  [([Int], [Text])] -> Trie [Text]
forall a. [([Int], a)] -> Trie a
Trie.fromList ([([Int], [Text])] -> Trie [Text])
-> (Map Text [Text] -> [([Int], [Text])])
-> Map Text [Text]
-> Trie [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, [Text]) -> ([Int], [Text]))
-> [(Text, [Text])] -> [([Int], [Text])]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> [Int]) -> (Text, [Text]) -> ([Int], [Text])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> [Int]
toCodePoints) ([(Text, [Text])] -> [([Int], [Text])])
-> (Map Text [Text] -> [(Text, [Text])])
-> Map Text [Text]
-> [([Int], [Text])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text [Text] -> [(Text, [Text])]
forall k a. Map k a -> [(k, a)]
M.toList (Map Text [Text] -> Trie [Text]) -> Map Text [Text] -> Trie [Text]
forall a b. (a -> b) -> a -> b
$ Map Text [Text]
emojiAliasMap

-- | Association list of (alias, emoji) pairs.  Note that the
-- same emoji may have multiple aliases.
emojis :: [(Text, Text)]

-- | A list of all valid emoji (not containing zero-width joiners), taken from
-- the Unicode Emoji Specification.
baseEmojis :: [Text]

-- | A list of all valid emoji built from zero-width joiners, taken from the
-- Unicode Emoji Specification.
zwjEmojis :: [Text]
#include "emojis.inc"