{-# 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]
  }

-- 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 <- 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
      -- update ref map
      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 ()