{-# 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 = SyntaxSpec m il bl
forall a. Monoid a => a
mempty
  { syntaxInlineParsers = [withAttributes 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 = Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class", Text
"emoji") (Html a -> Html a) -> (Html a -> Html a) -> Html a -> Html a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
               Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"data-emoji", Text
kw) (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
    Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline Text
"span" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$ Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Html a -> Maybe (Html a)) -> Html a -> Maybe (Html a)
forall a b. (a -> b) -> a -> b
$ Text -> Html a
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 = Text -> Text -> i
forall a. HasEmoji a => Text -> Text -> a
emoji Text
kw Text
t i -> WithSourceMap () -> WithSourceMap i
forall a b. a -> WithSourceMap b -> WithSourceMap a
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 = ParsecT [Tok] (IPState m) (StateT Enders m) a
-> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT [Tok] (IPState m) (StateT Enders m) a
 -> ParsecT [Tok] (IPState m) (StateT Enders m) a)
-> ParsecT [Tok] (IPState m) (StateT Enders m) a
-> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall a b. (a -> b) -> a -> b
$ do
  Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
':'
  [Tok]
ts <- ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT [Tok] (IPState m) (StateT Enders m) Tok
 -> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok])
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s.
Monad m =>
(Text -> Bool) -> ParsecT [Tok] s m Tok
satisfyWord (Bool -> Text -> Bool
forall a b. a -> b -> a
const Bool
True)
             ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'_'
             ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'+'
             ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
-> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'-'
  Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
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 -> String -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall a. String -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"emoji not found"
    Just Text
t  -> a -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall a. a -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ParsecT [Tok] (IPState m) (StateT Enders m) a)
-> a -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall a b. (a -> b) -> a -> b
$! Text -> Text -> a
forall a. HasEmoji a => Text -> Text -> a
emoji Text
kw Text
t