{-# LANGUAGE CPP #-}
{-# 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
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif

implicitHeadingReferencesSpec
         :: (Monad m, IsBlock il bl, IsInline il)
         => SyntaxSpec m il bl
implicitHeadingReferencesSpec :: SyntaxSpec m il bl
implicitHeadingReferencesSpec = SyntaxSpec m il bl
forall a. Monoid a => a
mempty
  { syntaxFinalParsers :: [BlockParser m il bl bl]
syntaxFinalParsers = [BlockParser m il bl bl
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl, IsInline il) =>
BlockParser m il bl bl
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 :: 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)
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 (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 :: 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 (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 -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"id" ([(Text, Text)] -> Maybe Text) -> [(Text, Text)] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ BlockData m il bl -> [(Text, Text)]
forall (m :: * -> *) il bl. BlockData m il bl -> [(Text, Text)]
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 :: ReferenceMap
referenceMap = Text -> LinkInfo -> ReferenceMap -> ReferenceMap
forall a. Typeable a => Text -> a -> ReferenceMap -> ReferenceMap
insertReference Text
lab
            LinkInfo :: Text -> Text -> [(Text, Text)] -> Maybe SourcePos -> LinkInfo
LinkInfo{ linkDestination :: Text
linkDestination = Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ident
                    , linkTitle :: Text
linkTitle = Text
forall a. Monoid a => a
mempty
                    , linkAttributes :: [(Text, Text)]
linkAttributes = [(Text, Text)]
forall a. Monoid a => a
mempty
                    , linkPos :: Maybe SourcePos
linkPos = Maybe SourcePos
forall a. Maybe a
Nothing }
            (BPState m il bl -> ReferenceMap
forall (m :: * -> *) il bl. BPState m il bl -> ReferenceMap
referenceMap BPState m il bl
s) }
  | Bool
otherwise = () -> BlockParser m il bl ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()