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 = forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
W.query forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList 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]
_, forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList -> Map Text Text
attrs) [Inline]
_ -> do
Text
tag <- forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
tagDataAttr Map Text Text
attrs
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Tag
TT.Tag Text
tag
Inline
_ -> 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"
,
Text
"emanote:inline-tag:" forall a. Semigroup a => a -> a -> a
<> Text
tag
]
in forall b a. a -> Cm b a
CP.Cm forall a b. (a -> b) -> a -> b
$ (Text, [Text], [(Text, Text)]) -> Inlines -> Inlines
B.spanWith (Text
"", [Text]
classes, [(Text, Text)]
attrs) forall a b. (a -> b) -> a -> b
$ Text -> Inlines
B.str forall a b. (a -> b) -> a -> b
$ 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 =
forall a. Monoid a => a
mempty
{ syntaxInlineParsers :: [InlineParser m il]
CM.syntaxInlineParsers = [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 = forall s u (m :: Type -> Type) a.
ParsecT s u m a -> ParsecT s u m a
P.try forall a b. (a -> b) -> a -> b
$ do
Tok
_ <- forall (m :: Type -> Type) s.
Monad m =>
Char -> ParsecT [Tok] s m Tok
symbol Char
'#'
Text
tag <- [Tok] -> Text
CM.untokenize forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: Type -> Type) s. Monad m => ParsecT [Tok] s m [Tok]
tagP
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall il. HasHashTag il => Tag -> il
hashTag 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 <- forall (f :: Type -> Type) a. Alternative f => f a -> f [a]
some (forall (m :: Type -> Type) s.
Monad m =>
[TokType] -> ParsecT [Tok] s m Tok
noneOfToks [TokType]
disallowed)
forall (f :: Type -> Type). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text
"/" Text -> Text -> Bool
`T.isSuffixOf` [Tok] -> Text
CM.untokenize [Tok]
s
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [Tok]
s
where
disallowed :: [TokType]
disallowed = [TokType
Spaces, TokType
UnicodeSpace, TokType
LineEnd] forall a. Semigroup a => a -> a -> a
<> forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> TokType
Symbol [Char]
punctuation
punctuation :: [Char]
punctuation = [Char]
"[];:,.?!"