{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
module Commonmark.Extensions.ImplicitHeadingReferences
( implicitHeadingReferencesSpec
)
where
import Commonmark.Types
import Commonmark.Tokens
import Commonmark.Syntax
import Commonmark.Blocks
import Commonmark.ReferenceMap
import qualified Data.Text as T
import Control.Monad (unless)
import Data.Maybe (fromMaybe)
import Text.Parsec
implicitHeadingReferencesSpec
:: (Monad m, IsBlock il bl, IsInline il)
=> SyntaxSpec m il bl
implicitHeadingReferencesSpec :: forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
SyntaxSpec m il bl
implicitHeadingReferencesSpec = forall a. Monoid a => a
mempty
{ syntaxFinalParsers :: [BlockParser m il bl bl]
syntaxFinalParsers = [forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
BlockParser m il bl bl
addHeadingReferences]
}
addHeadingReferences :: (Monad m, IsBlock il bl, IsInline il)
=> BlockParser m il bl bl
addHeadingReferences :: forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
BlockParser m il bl bl
addHeadingReferences = do
[BlockNode m il bl]
nodes <- forall (m :: * -> *) il bl. BPState m il bl -> [BlockNode m il bl]
nodeStack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
BlockData m il bl -> BlockParser m il bl ()
addHeadingRef) [BlockNode m il bl]
nodes
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
addHeadingRef :: (Monad m, IsBlock il bl, IsInline il)
=> BlockData m il bl -> BlockParser m il bl ()
addHeadingRef :: forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
BlockData m il bl -> BlockParser m il bl ()
addHeadingRef BlockData m il bl
bd
| forall (m :: * -> *) il bl. BlockSpec m il bl -> Text
blockType (forall (m :: * -> *) il bl. BlockData m il bl -> BlockSpec m il bl
blockSpec BlockData m il bl
bd) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"ATXHeading", Text
"SetextHeading"] = do
let lab :: Text
lab = [Tok] -> Text
untokenize forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tok] -> [Tok]
removeIndent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) il bl. BlockData m il bl -> [[Tok]]
blockLines forall a b. (a -> b) -> a -> b
$ BlockData m il bl
bd
let ident :: Text
ident = forall a. a -> Maybe a -> a
fromMaybe Text
"" forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"id" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) il bl. BlockData m il bl -> Attributes
blockAttributes BlockData m il bl
bd
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
lab) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState forall a b. (a -> b) -> a -> b
$ \BPState m il bl
s -> BPState m il bl
s{
referenceMap :: ReferenceMap
referenceMap = forall a. Typeable a => Text -> a -> ReferenceMap -> ReferenceMap
insertReference Text
lab
LinkInfo{ linkDestination :: Text
linkDestination = Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
ident
, linkTitle :: Text
linkTitle = forall a. Monoid a => a
mempty
, linkAttributes :: Attributes
linkAttributes = forall a. Monoid a => a
mempty
, linkPos :: Maybe SourcePos
linkPos = forall a. Maybe a
Nothing }
(forall (m :: * -> *) il bl. BPState m il bl -> ReferenceMap
referenceMap BPState m il bl
s) }
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()