module Emanote.Pandoc.Markdown.Syntax.HashTag
  ( hashTagSpec,
    inlineTagsInPandoc,
    getTagFromInline,
    TT.Tag (..),
    TT.TagPattern (..),
    TT.TagNode (..),
    TT.mkTagPattern,
    TT.tagMatch,
    TT.constructTag,
    TT.deconstructTag,
    TT.tagTree,
  )
where

import Commonmark (TokType (..))
import Commonmark qualified as CM
import Commonmark.Inlines qualified as CM
import Commonmark.Pandoc qualified as CP
import Commonmark.TokParsers (noneOfToks, symbol)
import Data.Map.Strict qualified as Map
import Data.TagTree qualified as TT
import Data.Text qualified as T
import Relude
import Text.Pandoc.Builder qualified as B
import Text.Pandoc.Walk qualified as W
import Text.Parsec qualified as P

inlineTagsInPandoc :: B.Pandoc -> [TT.Tag]
inlineTagsInPandoc :: Pandoc -> [Tag]
inlineTagsInPandoc = (Inline -> [Tag]) -> Pandoc -> [Tag]
forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
W.query ((Inline -> [Tag]) -> Pandoc -> [Tag])
-> (Inline -> [Tag]) -> Pandoc -> [Tag]
forall a b. (a -> b) -> a -> b
$ Maybe Tag -> [Tag]
forall a. Maybe a -> [a]
maybeToList (Maybe Tag -> [Tag]) -> (Inline -> Maybe Tag) -> Inline -> [Tag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inline -> Maybe Tag
getTagFromInline

getTagFromInline :: B.Inline -> Maybe TT.Tag
getTagFromInline :: Inline -> Maybe Tag
getTagFromInline = \case
  B.Span (Text
_, [Text]
_, [(Text, Text)] -> Map Text Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList -> Map Text Text
attrs) [Inline]
_ -> do
    Text
tag <- Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
tagDataAttr Map Text Text
attrs
    Tag -> Maybe Tag
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Tag -> Maybe Tag) -> Tag -> Maybe Tag
forall a b. (a -> b) -> a -> b
$ Text -> Tag
TT.Tag Text
tag
  Inline
_ -> Maybe Tag
forall a. Maybe a
Nothing

class HasHashTag il where
  hashTag :: TT.Tag -> il

instance HasHashTag (CP.Cm b B.Inlines) where
  hashTag :: Tag -> Cm b Inlines
hashTag (TT.Tag Text
tag) =
    let attrs :: [(Text, Text)]
attrs =
          [ (Text
"title", Text
"Tag"),
            (Text
tagDataAttr, Text
tag)
          ]
        classes :: [Text]
classes =
          [ Text
"emanote:inline-tag",
            -- This must be placed *after* the class above, to allow the user to
            -- override generic styles (of the class above)
            Text
"emanote:inline-tag:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tag
          ]
     in Inlines -> Cm b Inlines
forall b a. a -> Cm b a
CP.Cm (Inlines -> Cm b Inlines) -> Inlines -> Cm b Inlines
forall a b. (a -> b) -> a -> b
$ (Text, [Text], [(Text, Text)]) -> Inlines -> Inlines
B.spanWith (Text
"", [Text]
classes, [(Text, Text)]
attrs) (Inlines -> Inlines) -> Inlines -> Inlines
forall a b. (a -> b) -> a -> b
$ Text -> Inlines
B.str (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tag

tagDataAttr :: Text
tagDataAttr :: Text
tagDataAttr = Text
"data-tag"

hashTagSpec ::
  (Monad m, CM.IsBlock il bl, CM.IsInline il, HasHashTag il) =>
  CM.SyntaxSpec m il bl
hashTagSpec :: forall (m :: Type -> Type) il bl.
(Monad m, IsBlock il bl, IsInline il, HasHashTag il) =>
SyntaxSpec m il bl
hashTagSpec =
  SyntaxSpec m il bl
forall a. Monoid a => a
mempty
    { syntaxInlineParsers :: [InlineParser m il]
CM.syntaxInlineParsers = [InlineParser m il
forall (m :: Type -> Type) il.
(Monad m, IsInline il, HasHashTag il) =>
InlineParser m il
pTag]
    }
  where
    pTag ::
      (Monad m, CM.IsInline il, HasHashTag il) =>
      CM.InlineParser m il
    pTag :: forall (m :: Type -> Type) il.
(Monad m, IsInline il, HasHashTag il) =>
InlineParser m il
pTag = ParsecT [Tok] (IPState m) (StateT Enders m) il
-> ParsecT [Tok] (IPState m) (StateT Enders m) il
forall s u (m :: Type -> Type) a.
ParsecT s u m a -> ParsecT s u m a
P.try (ParsecT [Tok] (IPState m) (StateT Enders m) il
 -> ParsecT [Tok] (IPState m) (StateT Enders m) il)
-> ParsecT [Tok] (IPState m) (StateT Enders m) il
-> ParsecT [Tok] (IPState m) (StateT Enders m) il
forall a b. (a -> b) -> a -> b
$ do
      Tok
_ <- Char -> ParsecT [Tok] (IPState m) (StateT Enders m) Tok
forall (m :: Type -> Type) s.
Monad m =>
Char -> ParsecT [Tok] s m Tok
symbol Char
'#'
      Text
tag <- [Tok] -> Text
CM.untokenize ([Tok] -> Text)
-> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
-> ParsecT [Tok] (IPState m) (StateT Enders m) Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tok] (IPState m) (StateT Enders m) [Tok]
forall (m :: Type -> Type) s. Monad m => ParsecT [Tok] s m [Tok]
tagP
      il -> ParsecT [Tok] (IPState m) (StateT Enders m) il
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (il -> ParsecT [Tok] (IPState m) (StateT Enders m) il)
-> il -> ParsecT [Tok] (IPState m) (StateT Enders m) il
forall a b. (a -> b) -> a -> b
$ Tag -> il
forall il. HasHashTag il => Tag -> il
hashTag (Tag -> il) -> Tag -> il
forall a b. (a -> b) -> a -> b
$ Text -> Tag
TT.Tag Text
tag
    tagP :: Monad m => P.ParsecT [CM.Tok] s m [CM.Tok]
    tagP :: forall (m :: Type -> Type) s. Monad m => ParsecT [Tok] s m [Tok]
tagP = do
      [Tok]
s <- ParsecT [Tok] s m Tok -> ParsecT [Tok] s m [Tok]
forall (f :: Type -> Type) a. Alternative f => f a -> f [a]
some ([TokType] -> ParsecT [Tok] s m Tok
forall (m :: Type -> Type) s.
Monad m =>
[TokType] -> ParsecT [Tok] s m Tok
noneOfToks [TokType]
disallowed)
      -- A tag cannot end with a slash (which is a separator in hierarchical tags)
      Bool -> ParsecT [Tok] s m ()
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard (Bool -> ParsecT [Tok] s m ()) -> Bool -> ParsecT [Tok] s m ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text
"/" Text -> Text -> Bool
`T.isSuffixOf` [Tok] -> Text
CM.untokenize [Tok]
s
      [Tok] -> ParsecT [Tok] s m [Tok]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Tok]
s
      where
        disallowed :: [TokType]
disallowed = [TokType
Spaces, TokType
UnicodeSpace, TokType
LineEnd] [TokType] -> [TokType] -> [TokType]
forall a. Semigroup a => a -> a -> a
<> (Char -> TokType) -> [Char] -> [TokType]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> TokType
Symbol [Char]
punctuation
        punctuation :: [Char]
punctuation = [Char]
"[];:,.?!"