{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Commonmark.Extensions.Emoji
  ( HasEmoji(..)
  , emojiSpec )
where
import Commonmark.Types
import Commonmark.Tokens
import Commonmark.Syntax
import Commonmark.Inlines
import Commonmark.SourceMap
import Commonmark.TokParsers
import Commonmark.Html
import Text.Emoji (emojiFromAlias)
import Text.Parsec
import Data.Text (Text)

emojiSpec :: (Monad m, IsBlock il bl, IsInline il, HasEmoji il)
          => SyntaxSpec m il bl
emojiSpec :: forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il, HasEmoji il) =>
SyntaxSpec m il bl
emojiSpec = forall a. Monoid a => a
mempty
  { syntaxInlineParsers :: [InlineParser m il]
syntaxInlineParsers = [forall a (m :: * -> *).
(IsInline a, Monad m) =>
InlineParser m a -> InlineParser m a
withAttributes forall (m :: * -> *) a. (Monad m, HasEmoji a) => InlineParser m a
parseEmoji]
  }

class HasEmoji a where
  emoji :: Text   -- the ascii keyword
        -> Text   -- the emoji characters
        -> a

instance HasEmoji (Html a) where
  emoji :: Text -> Text -> Html a
emoji Text
kw Text
t = forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class", Text
"emoji") forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               forall a. Attribute -> Html a -> Html a
addAttribute (Text
"data-emoji", Text
kw) forall a b. (a -> b) -> a -> b
$
    forall a. Text -> Maybe (Html a) -> Html a
htmlInline Text
"span" forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Text -> Html a
htmlText Text
t

instance (HasEmoji i, Monoid i) => HasEmoji (WithSourceMap i) where
  emoji :: Text -> Text -> WithSourceMap i
emoji Text
kw Text
t = forall a. HasEmoji a => Text -> Text -> a
emoji Text
kw Text
t forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> WithSourceMap ()
addName Text
"emoji"

parseEmoji :: (Monad m, HasEmoji a) => InlineParser m a
parseEmoji :: forall (m :: * -> *) a. (Monad m, HasEmoji a) => InlineParser m a
parseEmoji = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
':'
  [Tok]
ts <- forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord (forall a b. a -> b -> a
const Bool
True)
             forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'_'
             forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'+'
             forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'-'
  forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
':'
  let kw :: Text
kw = [Tok] -> Text
untokenize [Tok]
ts
  case Text -> Maybe Text
emojiFromAlias Text
kw of
    Maybe Text
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"emoji not found"
    Just Text
t  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. HasEmoji a => Text -> Text -> a
emoji Text
kw Text
t