{-# 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 = SyntaxSpec m il bl
forall a. Monoid a => a
mempty
  { syntaxFinalParsers = [addHeadingReferences]
  }

-- Go through the node stack and add implicit references
-- for each header.
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 <- BPState m il bl -> [BlockNode m il bl]
forall (m :: * -> *) il bl. BPState m il bl -> [BlockNode m il bl]
nodeStack (BPState m il bl -> [BlockNode m il bl])
-> ParsecT [Tok] (BPState m il bl) m (BPState m il bl)
-> ParsecT [Tok] (BPState m il bl) m [BlockNode m il bl]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tok] (BPState m il bl) m (BPState m il bl)
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
  (BlockNode m il bl -> ParsecT [Tok] (BPState m il bl) m (Tree ()))
-> [BlockNode m il bl] -> ParsecT [Tok] (BPState m il bl) m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((BlockData m il bl -> ParsecT [Tok] (BPState m il bl) m ())
-> BlockNode m il bl -> ParsecT [Tok] (BPState m il bl) m (Tree ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Tree a -> f (Tree b)
traverse BlockData m il bl -> ParsecT [Tok] (BPState m il bl) m ()
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
  bl -> BlockParser m il bl bl
forall a. a -> ParsecT [Tok] (BPState m il bl) m a
forall (m :: * -> *) a. Monad m => a -> m a
return bl
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
  | BlockSpec m il bl -> Text
forall (m :: * -> *) il bl. BlockSpec m il bl -> Text
blockType (BlockData m il bl -> BlockSpec m il bl
forall (m :: * -> *) il bl. BlockData m il bl -> BlockSpec m il bl
blockSpec BlockData m il bl
bd) Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"ATXHeading", Text
"SetextHeading"] = do
      -- update ref map
      let lab :: Text
lab = [Tok] -> Text
untokenize ([Tok] -> Text)
-> (BlockData m il bl -> [Tok]) -> BlockData m il bl -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tok] -> [Tok]
removeIndent ([Tok] -> [Tok])
-> (BlockData m il bl -> [Tok]) -> BlockData m il bl -> [Tok]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Tok]] -> [Tok]
forall a. Monoid a => [a] -> a
mconcat ([[Tok]] -> [Tok])
-> (BlockData m il bl -> [[Tok]]) -> BlockData m il bl -> [Tok]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Tok]] -> [[Tok]]
forall a. [a] -> [a]
reverse ([[Tok]] -> [[Tok]])
-> (BlockData m il bl -> [[Tok]]) -> BlockData m il bl -> [[Tok]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockData m il bl -> [[Tok]]
forall (m :: * -> *) il bl. BlockData m il bl -> [[Tok]]
blockLines (BlockData m il bl -> Text) -> BlockData m il bl -> Text
forall a b. (a -> b) -> a -> b
$ BlockData m il bl
bd
      let ident :: Text
ident = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Attributes -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"id" (Attributes -> Maybe Text) -> Attributes -> Maybe Text
forall a b. (a -> b) -> a -> b
$ BlockData m il bl -> Attributes
forall (m :: * -> *) il bl. BlockData m il bl -> Attributes
blockAttributes BlockData m il bl
bd
      Bool -> BlockParser m il bl () -> BlockParser m il bl ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text -> Bool
T.null Text
lab) (BlockParser m il bl () -> BlockParser m il bl ())
-> BlockParser m il bl () -> BlockParser m il bl ()
forall a b. (a -> b) -> a -> b
$
        (BPState m il bl -> BPState m il bl) -> BlockParser m il bl ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState ((BPState m il bl -> BPState m il bl) -> BlockParser m il bl ())
-> (BPState m il bl -> BPState m il bl) -> BlockParser m il bl ()
forall a b. (a -> b) -> a -> b
$ \BPState m il bl
s -> BPState m il bl
s{
          referenceMap = insertReference lab
            LinkInfo{ linkDestination = "#" <> ident
                    , linkTitle = mempty
                    , linkAttributes = mempty
                    , linkPos = Nothing }
            (referenceMap s) }
  | Bool
otherwise = () -> BlockParser m il bl ()
forall a. a -> ParsecT [Tok] (BPState m il bl) m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()