{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Commonmark.Extensions.Footnote
  ( footnoteSpec
  , HasFootnote(..)
  )
where
import Commonmark.Tokens
import Commonmark.Types
import Commonmark.Html
import Commonmark.Syntax
import Commonmark.Blocks
import Commonmark.Inlines
import Commonmark.SourceMap
import Commonmark.TokParsers
import Commonmark.ReferenceMap
import Control.Monad.Trans.Class (lift)
import Control.Monad (mzero, foldM)
import Data.Graph (stronglyConnComp, flattenSCC)
import Data.List
import Data.Maybe (fromMaybe, mapMaybe, catMaybes)
import Data.Dynamic
import Data.Tree
import Text.Parsec
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Map as M

data FootnoteDef bl m =
  FootnoteDef Int Text [Text] (ReferenceMap -> m (Either ParseError bl))
  -- ^ number, label, labels of footnote references in the body
  -- (conservative approximation, used only for ordering the
  -- memoization pass in addFootnoteList), parser for contents
  deriving Typeable

instance Eq (FootnoteDef bl m) where
  FootnoteDef Int
num1 Text
lab1 [Text]
_ ReferenceMap -> m (Either ParseError bl)
_ == :: FootnoteDef bl m -> FootnoteDef bl m -> Bool
== FootnoteDef Int
num2 Text
lab2 [Text]
_ ReferenceMap -> m (Either ParseError bl)
_
    = Int
num1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
num2 Bool -> Bool -> Bool
&& Text
lab1 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
lab2

instance Ord (FootnoteDef bl m) where
  (FootnoteDef Int
num1 Text
lab1 [Text]
_ ReferenceMap -> m (Either ParseError bl)
_) compare :: FootnoteDef bl m -> FootnoteDef bl m -> Ordering
`compare` (FootnoteDef Int
num2 Text
lab2 [Text]
_ ReferenceMap -> m (Either ParseError bl)
_) =
    (Int
num1, Text
lab1) (Int, Text) -> (Int, Text) -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (Int
num2, Text
lab2)

-- | Memoized rendered contents of a footnote, stored in the reference
-- map (alongside the FootnoteDef) once the note has been rendered, so
-- that each note body is parsed only once no matter how many times it
-- is referenced.
data FootnoteRendered bl = FootnoteRendered Int Text bl
  deriving Typeable

-- | Marker inserted into the reference map passed to a note body's
-- parser while that note is being rendered.  A reference to an
-- in-progress note is a cycle; pFootnoteRef treats it as unresolved,
-- so it falls back to literal text instead of looping forever.
data FootnoteInProgress = FootnoteInProgress
  deriving Typeable

footnoteSpec :: (Monad m, Typeable m, IsBlock il bl, IsInline il,
                 Typeable il, Typeable bl, HasFootnote il bl)
             => SyntaxSpec m il bl
footnoteSpec :: forall (m :: * -> *) il bl.
(Monad m, Typeable m, IsBlock il bl, IsInline il, Typeable il,
 Typeable bl, HasFootnote il bl) =>
SyntaxSpec m il bl
footnoteSpec = SyntaxSpec (ZonkAny 0) il (ZonkAny 1)
forall a. Monoid a => a
mempty
  { syntaxBlockSpecs = [footnoteBlockSpec]
  , syntaxInlineParsers = [withAttributes pFootnoteRef]
  , syntaxFinalParsers = [addFootnoteList]
  }

footnoteBlockSpec :: (Monad m, Typeable m, Typeable il, Typeable bl,
                      IsBlock il bl, IsInline il, HasFootnote il bl)
                  => BlockSpec m il bl
footnoteBlockSpec :: forall (m :: * -> *) il bl.
(Monad m, Typeable m, Typeable il, Typeable bl, IsBlock il bl,
 IsInline il, HasFootnote il bl) =>
BlockSpec m il bl
footnoteBlockSpec = BlockSpec
     { blockType :: Text
blockType           = Text
"Footnote"
     , blockStart :: BlockParser m il bl BlockStartResult
blockStart          = BlockParser m il bl BlockStartResult
-> BlockParser m il bl BlockStartResult
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (BlockParser m il bl BlockStartResult
 -> BlockParser m il bl BlockStartResult)
-> BlockParser m il bl BlockStartResult
-> BlockParser m il bl BlockStartResult
forall a b. (a -> b) -> a -> b
$ do
             ParsecT [Tok] (BPState m il bl) m ()
forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m ()
nonindentSpaces
             pos <- ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
             lab' <- pFootnoteLabel
             _ <- symbol ':'
             counters' <- counters <$> getState
             let num = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (Int
1 :: Int) (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$
                       Text -> Map Text Dynamic -> Maybe Dynamic
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"footnote" Map Text Dynamic
counters' Maybe Dynamic -> (Dynamic -> Maybe Int) -> Maybe Int
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dynamic -> Maybe Int
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic
             updateState $ \BPState m il bl
s -> BPState m il bl
s{ counters =
                                     M.insert "footnote" (toDyn (num + 1))
                                      (counters s) }
             addNodeToStack $
                Node (defBlockData footnoteBlockSpec){
                            blockData = toDyn (num, lab')
                          , blockStartPos = [pos] } []
             return BlockStartMatch
     , blockCanContain :: BlockSpec m il bl -> Bool
blockCanContain     = Bool -> BlockSpec m il bl -> Bool
forall a b. a -> b -> a
const Bool
True
     , blockContainsLines :: Bool
blockContainsLines  = Bool
False
     , blockParagraph :: Bool
blockParagraph      = Bool
False
     , blockContinue :: BlockNode m il bl
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
blockContinue       = \BlockNode m il bl
n -> BlockParser m il bl (SourcePos, BlockNode m il bl)
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (BlockParser m il bl (SourcePos, BlockNode m il bl)
 -> BlockParser m il bl (SourcePos, BlockNode m il bl))
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
forall a b. (a -> b) -> a -> b
$ do
             () ()
-> ParsecT [Tok] (BPState m il bl) m Int
-> ParsecT [Tok] (BPState m il bl) m ()
forall a b.
a
-> ParsecT [Tok] (BPState m il bl) m b
-> ParsecT [Tok] (BPState m il bl) m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (Int -> ParsecT [Tok] (BPState m il bl) m Int
forall (m :: * -> *) u. Monad m => Int -> ParsecT [Tok] u m Int
gobbleSpaces Int
4)
               ParsecT [Tok] (BPState m il bl) m ()
-> ParsecT [Tok] (BPState m il bl) m ()
-> ParsecT [Tok] (BPState m il bl) m ()
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> ((Tok -> Bool) -> ParsecT [Tok] (BPState m il bl) m ()
forall (m :: * -> *) u.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] u m ()
skipWhile (TokType -> Tok -> Bool
hasType TokType
Spaces) ParsecT [Tok] (BPState m il bl) m ()
-> ParsecT [Tok] (BPState m il bl) m ()
-> ParsecT [Tok] (BPState m il bl) m ()
forall a b.
ParsecT [Tok] (BPState m il bl) m a
-> ParsecT [Tok] (BPState m il bl) m b
-> ParsecT [Tok] (BPState m il bl) m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () ()
-> ParsecT [Tok] (BPState m il bl) m Tok
-> ParsecT [Tok] (BPState m il bl) m ()
forall a b.
a
-> ParsecT [Tok] (BPState m il bl) m b
-> ParsecT [Tok] (BPState m il bl) m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT [Tok] (BPState m il bl) m Tok
-> ParsecT [Tok] (BPState m il bl) m Tok
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead ParsecT [Tok] (BPState m il bl) m Tok
forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m Tok
lineEnd)
             pos <- ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
             return $! (pos, n)
     , blockConstructor :: BlockNode m il bl -> BlockParser m il bl bl
blockConstructor    = ([bl] -> bl)
-> ParsecT [Tok] (BPState m il bl) m [bl] -> BlockParser m il bl bl
forall a b.
(a -> b)
-> ParsecT [Tok] (BPState m il bl) m a
-> ParsecT [Tok] (BPState m il bl) m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [bl] -> bl
forall a. Monoid a => [a] -> a
mconcat (ParsecT [Tok] (BPState m il bl) m [bl] -> BlockParser m il bl bl)
-> (BlockNode m il bl -> ParsecT [Tok] (BPState m il bl) m [bl])
-> BlockNode m il bl
-> BlockParser m il bl bl
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode m il bl -> ParsecT [Tok] (BPState m il bl) m [bl]
forall (m :: * -> *) il bl.
(Monad m, IsBlock il bl) =>
BlockNode m il bl -> BlockParser m il bl [bl]
renderChildren (BlockNode m il bl -> ParsecT [Tok] (BPState m il bl) m [bl])
-> (BlockNode m il bl -> BlockNode m il bl)
-> BlockNode m il bl
-> ParsecT [Tok] (BPState m il bl) m [bl]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockNode m il bl -> BlockNode m il bl
forall a. Tree a -> Tree a
reverseSubforests
     , blockFinalize :: BlockNode m il bl
-> BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl)
blockFinalize       = \(Node BlockData m il bl
root [BlockNode m il bl]
children) BlockNode m il bl
parent -> do
         let (Int
num, Text
lab') = Dynamic -> (Int, Text) -> (Int, Text)
forall a. Typeable a => Dynamic -> a -> a
fromDyn (BlockData m il bl -> Dynamic
forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic
blockData BlockData m il bl
root) (Int
1, Text
forall a. Monoid a => a
mempty)
         st <- ParsecT [Tok] (BPState m il bl) m (BPState m il bl)
forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
         let mkNoteContents ReferenceMap
refmap =
               BlockParser m il bl bl
-> BPState m il bl -> String -> [Tok] -> m (Either ParseError bl)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> u -> String -> s -> m (Either ParseError a)
runParserT
                 (BlockSpec m il bl -> BlockNode m il bl -> BlockParser m il bl bl
forall (m :: * -> *) il bl.
BlockSpec m il bl -> BlockNode m il bl -> BlockParser m il bl bl
blockConstructor (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
root) (BlockData m il bl -> [BlockNode m il bl] -> BlockNode m il bl
forall a. a -> [Tree a] -> Tree a
Node BlockData m il bl
root [BlockNode m il bl]
children))
                 BPState m il bl
st{ referenceMap = refmap }
                 String
"source" []
         let bodytoks = (BlockData m il bl -> [Tok]) -> [BlockData m il bl] -> [Tok]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([[Tok]] -> [Tok]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[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)
                          (BlockNode m il bl -> [BlockData m il bl]
forall a. Tree a -> [a]
flatten (BlockData m il bl -> [BlockNode m il bl] -> BlockNode m il bl
forall a. a -> [Tree a] -> Tree a
Node BlockData m il bl
root [BlockNode m il bl]
children))
         updateState $ \BPState m il bl
s -> BPState m il bl
s{
             referenceMap = insertReference lab'
                              (FootnoteDef num lab' (extractNoteRefs bodytoks)
                                mkNoteContents)
                              (referenceMap s)
             }
         return $! parent
     }

-- Conservatively extract the labels of footnote references occurring
-- in a note body.  These are used only to order the rendering of
-- notes in addFootnoteList so that referenced notes are rendered (and
-- memoized) before the notes that reference them; inaccuracies affect
-- only performance, not correctness.
extractNoteRefs :: [Tok] -> [Text]
extractNoteRefs :: [Tok] -> [Text]
extractNoteRefs [Tok]
toks =
  case Parsec [Tok] () [Text]
-> String -> [Tok] -> Either ParseError [Text]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse ([Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Text] -> [Text])
-> ParsecT [Tok] () Identity [Maybe Text] -> Parsec [Tok] () [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tok] () Identity (Maybe Text)
-> ParsecT [Tok] () Identity [Maybe Text]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ((Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> ParsecT [Tok] () Identity Text
-> ParsecT [Tok] () Identity (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tok] () Identity Text -> ParsecT [Tok] () Identity Text
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try ParsecT [Tok] () Identity Text
forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m Text
pFootnoteLabel)
                                   ParsecT [Tok] () Identity (Maybe Text)
-> ParsecT [Tok] () Identity (Maybe Text)
-> ParsecT [Tok] () Identity (Maybe Text)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (Maybe Text
forall a. Maybe a
Nothing Maybe Text
-> ParsecT [Tok] () Identity Tok
-> ParsecT [Tok] () Identity (Maybe Text)
forall a b.
a -> ParsecT [Tok] () Identity b -> ParsecT [Tok] () Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT [Tok] () Identity Tok
forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m Tok
anyTok))) String
"" [Tok]
toks of
       Left ParseError
_     -> []
       Right [Text]
labs -> [Text]
labs

pFootnoteLabel :: Monad m => ParsecT [Tok] u m Text
pFootnoteLabel :: forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m Text
pFootnoteLabel = ParsecT [Tok] u m Text -> ParsecT [Tok] u m Text
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT [Tok] u m Text -> ParsecT [Tok] u m Text)
-> ParsecT [Tok] u m Text -> ParsecT [Tok] u m Text
forall a b. (a -> b) -> a -> b
$ do
  lab <- [Tok] -> Text
untokenize
      ([Tok] -> Text)
-> ParsecT [Tok] u m [Tok] -> ParsecT [Tok] u m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tok] u m [Tok] -> ParsecT [Tok] u m [Tok]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT [Tok] u m Tok
-> ParsecT [Tok] u m Tok
-> ParsecT [Tok] u m [Tok]
-> ParsecT [Tok] u m [Tok]
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (Char -> ParsecT [Tok] u m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
'[') (Char -> ParsecT [Tok] u m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
']')
            (([Tok], [Tok]) -> [Tok]
forall a b. (a, b) -> b
snd (([Tok], [Tok]) -> [Tok])
-> ParsecT [Tok] u m ([Tok], [Tok]) -> ParsecT [Tok] u m [Tok]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT [Tok] u m [Tok] -> ParsecT [Tok] u m ([Tok], [Tok])
forall (m :: * -> *) s a.
Monad m =>
ParsecT [Tok] s m a -> ParsecT [Tok] s m (a, [Tok])
withRaw (ParsecT [Tok] u m Tok -> ParsecT [Tok] u m [Tok]
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many
              (ParsecT [Tok] u m Tok
forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m Tok
pEscaped ParsecT [Tok] u m Tok
-> ParsecT [Tok] u m Tok -> ParsecT [Tok] u m Tok
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> [TokType] -> ParsecT [Tok] u m Tok
forall (m :: * -> *) s.
Monad m =>
[TokType] -> ParsecT [Tok] s m Tok
noneOfToks [Char -> TokType
Symbol Char
']', Char -> TokType
Symbol Char
'[', TokType
LineEnd]))))
  case T.uncons lab of
        Just (Char
'^', Text
t') | (Char -> Bool) -> Text -> Bool
T.any (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ' Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\t') Text
t' Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all (\Char
x -> Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n' Bool -> Bool -> Bool
&& Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r') Text
t'
            -> Text -> ParsecT [Tok] u m Text
forall a. a -> ParsecT [Tok] u m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> ParsecT [Tok] u m Text) -> Text -> ParsecT [Tok] u m Text
forall a b. (a -> b) -> a -> b
$! Text
t'
        Maybe (Char, Text)
_ -> ParsecT [Tok] u m Text
forall a. ParsecT [Tok] u m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

pFootnoteRef :: forall m a b.  (Monad m, Typeable m, Typeable a,
                 Typeable b, IsInline a, IsBlock a b, HasFootnote a b)
             => InlineParser m a
pFootnoteRef :: forall (m :: * -> *) a b.
(Monad m, Typeable m, Typeable a, Typeable b, IsInline a,
 IsBlock a b, HasFootnote a b) =>
InlineParser m a
pFootnoteRef = ParsecT [Tok] (IPState m) (StateT Enders m) a
-> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (ParsecT [Tok] (IPState m) (StateT Enders m) a
 -> ParsecT [Tok] (IPState m) (StateT Enders m) a)
-> ParsecT [Tok] (IPState m) (StateT Enders m) a
-> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall a b. (a -> b) -> a -> b
$ do
  lab <- ParsecT [Tok] (IPState m) (StateT Enders m) Text
forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m Text
pFootnoteLabel
  rm <- getReferenceMap
  case lookupReference lab rm :: Maybe FootnoteInProgress of
    Just FootnoteInProgress
_ -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall a. ParsecT [Tok] (IPState m) (StateT Enders m) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero -- cyclic reference: leave it as literal text
    Maybe FootnoteInProgress
Nothing ->
      case Text -> ReferenceMap -> Maybe (FootnoteRendered b)
forall a. Typeable a => Text -> ReferenceMap -> Maybe a
lookupReference Text
lab ReferenceMap
rm :: Maybe (FootnoteRendered b) of
        -- memoized contents (notes are pre-rendered in addFootnoteList,
        -- which runs before inline parsing of the main document):
        Just (FootnoteRendered Int
num Text
_ b
contents) -> a -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall a. a -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ParsecT [Tok] (IPState m) (StateT Enders m) a)
-> a -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall a b. (a -> b) -> a -> b
$!
          Text -> Text -> b -> a
forall il bl. HasFootnote il bl => Text -> Text -> bl -> il
footnoteRef (String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
num)) Text
lab b
contents
        Maybe (FootnoteRendered b)
Nothing ->
          case Text -> ReferenceMap -> Maybe (FootnoteDef b m)
forall a. Typeable a => Text -> ReferenceMap -> Maybe a
lookupReference Text
lab ReferenceMap
rm :: Maybe (FootnoteDef b m) of
            -- not yet rendered (only happens while another note that
            -- references this one is itself being rendered):
            Just (FootnoteDef Int
num Text
_ [Text]
_ ReferenceMap -> m (Either ParseError b)
mkContents) -> do
              res <- StateT Enders m (Either ParseError b)
-> ParsecT
     [Tok] (IPState m) (StateT Enders m) (Either ParseError b)
forall (m :: * -> *) a.
Monad m =>
m a -> ParsecT [Tok] (IPState m) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT Enders m (Either ParseError b)
 -> ParsecT
      [Tok] (IPState m) (StateT Enders m) (Either ParseError b))
-> (m (Either ParseError b)
    -> StateT Enders m (Either ParseError b))
-> m (Either ParseError b)
-> ParsecT
     [Tok] (IPState m) (StateT Enders m) (Either ParseError b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either ParseError b) -> StateT Enders m (Either ParseError b)
forall (m :: * -> *) a. Monad m => m a -> StateT Enders m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either ParseError b)
 -> ParsecT
      [Tok] (IPState m) (StateT Enders m) (Either ParseError b))
-> m (Either ParseError b)
-> ParsecT
     [Tok] (IPState m) (StateT Enders m) (Either ParseError b)
forall a b. (a -> b) -> a -> b
$ ReferenceMap -> m (Either ParseError b)
mkContents
                       (Text -> FootnoteInProgress -> ReferenceMap -> ReferenceMap
forall a. Typeable a => Text -> a -> ReferenceMap -> ReferenceMap
insertReference Text
lab FootnoteInProgress
FootnoteInProgress ReferenceMap
rm)
              case res of
                   Left ParseError
err -> (State [Tok] (IPState m)
 -> StateT
      Enders m (Consumed (StateT Enders m (Reply [Tok] (IPState m) a))))
-> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall (m :: * -> *) s u a.
Monad m =>
(State s u -> m (Consumed (m (Reply s u a)))) -> ParsecT s u m a
mkPT (\State [Tok] (IPState m)
_ -> Consumed (StateT Enders m (Reply [Tok] (IPState m) a))
-> StateT
     Enders m (Consumed (StateT Enders m (Reply [Tok] (IPState m) a)))
forall a. a -> StateT Enders m a
forall (m :: * -> *) a. Monad m => a -> m a
return (StateT Enders m (Reply [Tok] (IPState m) a)
-> Consumed (StateT Enders m (Reply [Tok] (IPState m) a))
forall a. a -> Consumed a
Empty (Reply [Tok] (IPState m) a
-> StateT Enders m (Reply [Tok] (IPState m) a)
forall a. a -> StateT Enders m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseError -> Reply [Tok] (IPState m) a
forall s u a. ParseError -> Reply s u a
Error ParseError
err))))
                   Right b
contents -> a -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall a. a -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> ParsecT [Tok] (IPState m) (StateT Enders m) a)
-> a -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall a b. (a -> b) -> a -> b
$!
                     Text -> Text -> b -> a
forall il bl. HasFootnote il bl => Text -> Text -> bl -> il
footnoteRef (String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
num)) Text
lab b
contents
            Maybe (FootnoteDef b m)
Nothing -> ParsecT [Tok] (IPState m) (StateT Enders m) a
forall a. ParsecT [Tok] (IPState m) (StateT Enders m) a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

addFootnoteList :: forall m il bl.
                   (Monad m, Typeable m, Typeable bl, HasFootnote il bl,
                    IsBlock il bl) => BlockParser m il bl bl
addFootnoteList :: forall (m :: * -> *) il bl.
(Monad m, Typeable m, Typeable bl, HasFootnote il bl,
 IsBlock il bl) =>
BlockParser m il bl bl
addFootnoteList = do
  rm <- BPState m il bl -> ReferenceMap
forall (m :: * -> *) il bl. BPState m il bl -> ReferenceMap
referenceMap (BPState m il bl -> ReferenceMap)
-> ParsecT [Tok] (BPState m il bl) m (BPState m il bl)
-> ParsecT [Tok] (BPState m il bl) m ReferenceMap
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
  let keys = Map Text [Dynamic] -> [Text]
forall k a. Map k a -> [k]
M.keys (Map Text [Dynamic] -> [Text])
-> (ReferenceMap -> Map Text [Dynamic]) -> ReferenceMap -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReferenceMap -> Map Text [Dynamic]
unReferenceMap (ReferenceMap -> [Text]) -> ReferenceMap -> [Text]
forall a b. (a -> b) -> a -> b
$ ReferenceMap
rm
  let getNote Text
key = Text -> ReferenceMap -> Maybe (FootnoteDef bl m)
forall a. Typeable a => Text -> ReferenceMap -> Maybe a
lookupReference Text
key ReferenceMap
rm :: Maybe (FootnoteDef bl m)
  let notes = [FootnoteDef bl m] -> [FootnoteDef bl m]
forall a. Ord a => [a] -> [a]
sort ([FootnoteDef bl m] -> [FootnoteDef bl m])
-> [FootnoteDef bl m] -> [FootnoteDef bl m]
forall a b. (a -> b) -> a -> b
$ (Text -> Maybe (FootnoteDef bl m)) -> [Text] -> [FootnoteDef bl m]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe (FootnoteDef bl m)
getNote [Text]
keys
  -- Render each note's contents exactly once, in dependency order
  -- (so that notes referenced by other notes are rendered, and
  -- memoized, first), caching the results in the reference map.
  -- Since final parsers run before inline parsing of the main
  -- document, every footnote reference outside of a note body will
  -- find the memoized contents.  Cyclic references are cut off by
  -- the FootnoteInProgress marker (see pFootnoteRef).
  let sccs = [(FootnoteDef bl m, Text, [Text])] -> [SCC (FootnoteDef bl m)]
forall key node. Ord key => [(node, key, [key])] -> [SCC node]
stronglyConnComp
        [ (FootnoteDef bl m
def, Text -> Text
normalizeLabel Text
lab, (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
normalizeLabel [Text]
refs)
        | def :: FootnoteDef bl m
def@(FootnoteDef Int
_ Text
lab [Text]
refs ReferenceMap -> m (Either ParseError bl)
_) <- [FootnoteDef bl m]
notes ]
  let renderNote ReferenceMap
rm' (FootnoteDef Int
num Text
lab [Text]
_ ReferenceMap -> m (Either ParseError bl)
mkContents) = do
        res <- m (Either ParseError bl) -> ParsecT s u m (Either ParseError bl)
forall (m :: * -> *) a. Monad m => m a -> ParsecT s u m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either ParseError bl) -> ParsecT s u m (Either ParseError bl))
-> m (Either ParseError bl) -> ParsecT s u m (Either ParseError bl)
forall a b. (a -> b) -> a -> b
$ ReferenceMap -> m (Either ParseError bl)
mkContents (Text -> FootnoteInProgress -> ReferenceMap -> ReferenceMap
forall a. Typeable a => Text -> a -> ReferenceMap -> ReferenceMap
insertReference Text
lab FootnoteInProgress
FootnoteInProgress ReferenceMap
rm')
        case res of
             Left ParseError
err -> (State s u -> m (Consumed (m (Reply s u ReferenceMap))))
-> ParsecT s u m ReferenceMap
forall (m :: * -> *) s u a.
Monad m =>
(State s u -> m (Consumed (m (Reply s u a)))) -> ParsecT s u m a
mkPT (\State s u
_ -> Consumed (m (Reply s u ReferenceMap))
-> m (Consumed (m (Reply s u ReferenceMap)))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (m (Reply s u ReferenceMap) -> Consumed (m (Reply s u ReferenceMap))
forall a. a -> Consumed a
Empty (Reply s u ReferenceMap -> m (Reply s u ReferenceMap)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseError -> Reply s u ReferenceMap
forall s u a. ParseError -> Reply s u a
Error ParseError
err))))
             Right bl
contents -> ReferenceMap -> ParsecT s u m ReferenceMap
forall a. a -> ParsecT s u m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ReferenceMap -> ParsecT s u m ReferenceMap)
-> ReferenceMap -> ParsecT s u m ReferenceMap
forall a b. (a -> b) -> a -> b
$!
               Text -> FootnoteRendered bl -> ReferenceMap -> ReferenceMap
forall a. Typeable a => Text -> a -> ReferenceMap -> ReferenceMap
insertReference Text
lab (Int -> Text -> bl -> FootnoteRendered bl
forall bl. Int -> Text -> bl -> FootnoteRendered bl
FootnoteRendered Int
num Text
lab bl
contents) ReferenceMap
rm'
  rm' <- foldM renderNote rm (concatMap flattenSCC sccs)
  updateState $ \BPState m il bl
s -> BPState m il bl
s{ referenceMap = rm' }
  let renderedNote (FootnoteDef Int
num Text
lab [Text]
_ ReferenceMap -> m (Either ParseError bl)
_) = do
        FootnoteRendered _ _ contents <- Text -> ReferenceMap -> Maybe (FootnoteRendered b)
forall a. Typeable a => Text -> ReferenceMap -> Maybe a
lookupReference Text
lab ReferenceMap
rm'
        return $! footnote num lab contents
  if null notes
     then return mempty
     else return $! footnoteList $ mapMaybe renderedNote notes

-- Must match the label normalization performed by insertReference
-- and lookupReference (see Commonmark.ReferenceMap).
normalizeLabel :: Text -> Text
normalizeLabel :: Text -> Text
normalizeLabel = Text -> Text
T.toCaseFold (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unwords ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words

class IsBlock il bl => HasFootnote il bl | il -> bl where
  footnote :: Int -> Text -> bl -> bl
  footnoteList :: [bl] -> bl
  footnoteRef :: Text -> Text -> bl -> il

instance Rangeable (Html a) => HasFootnote (Html a) (Html a) where
  footnote :: Int -> Text -> Html a -> Html a
footnote Int
num Text
lab' Html a
x =
    Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class", Text
"footnote") (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
    Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"id", Text
"fn-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lab') (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
    Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"div" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$ Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Html a -> Maybe (Html a)) -> Html a -> Maybe (Html a)
forall a b. (a -> b) -> a -> b
$ Text -> Html a
forall a. Text -> Html a
htmlRaw Text
"\n" Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<>
      (Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class", Text
"footnote-number") (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
       Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"div" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$ Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Html a -> Maybe (Html a)) -> Html a -> Maybe (Html a)
forall a b. (a -> b) -> a -> b
$ Text -> Html a
forall a. Text -> Html a
htmlRaw Text
"\n" Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<>
        (Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"href", Text
"#fnref-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lab') (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
         Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline Text
"a" (Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Html a -> Maybe (Html a)) -> Html a -> Maybe (Html a)
forall a b. (a -> b) -> a -> b
$ Text -> Html a
forall a. Text -> Html a
htmlText (Text -> Html a) -> Text -> Html a
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
num)) Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<>
         Text -> Html a
forall a. Text -> Html a
htmlRaw Text
"\n") Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<>
      (Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class", Text
"footnote-contents") (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
        Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"div" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$ Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Html a -> Maybe (Html a)) -> Html a -> Maybe (Html a)
forall a b. (a -> b) -> a -> b
$ Text -> Html a
forall a. Text -> Html a
htmlRaw Text
"\n" Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> Html a
x)
  footnoteList :: [Html a] -> Html a
footnoteList [Html a]
items =
    Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class", Text
"footnotes") (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
      Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"section" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$ Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Html a -> Maybe (Html a)) -> Html a -> Maybe (Html a)
forall a b. (a -> b) -> a -> b
$ Text -> Html a
forall a. Text -> Html a
htmlRaw Text
"\n" Html a -> Html a -> Html a
forall a. Semigroup a => a -> a -> a
<> [Html a] -> Html a
forall a. Monoid a => [a] -> a
mconcat [Html a]
items
  footnoteRef :: Text -> Text -> Html a -> Html a
footnoteRef Text
x Text
lab Html a
_ =
   Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class", Text
"footnote-ref") (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
     Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline Text
"sup" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$ Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Html a -> Maybe (Html a)) -> Html a -> Maybe (Html a)
forall a b. (a -> b) -> a -> b
$
       Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"href", Text
"#fn-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lab) (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
       Attribute -> Html a -> Html a
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"id", Text
"fnref-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lab) (Html a -> Html a) -> Html a -> Html a
forall a b. (a -> b) -> a -> b
$
       Text -> Maybe (Html a) -> Html a
forall a. Text -> Maybe (Html a) -> Html a
htmlInline Text
"a" (Maybe (Html a) -> Html a) -> Maybe (Html a) -> Html a
forall a b. (a -> b) -> a -> b
$ Html a -> Maybe (Html a)
forall a. a -> Maybe a
Just (Text -> Html a
forall a. Text -> Html a
htmlText Text
x)

instance (HasFootnote il bl, Semigroup bl, Semigroup il)
        => HasFootnote (WithSourceMap il) (WithSourceMap bl) where
  footnote :: Int -> Text -> WithSourceMap bl -> WithSourceMap bl
footnote Int
num Text
lab' WithSourceMap bl
x = (Int -> Text -> bl -> bl
forall il bl. HasFootnote il bl => Int -> Text -> bl -> bl
footnote Int
num Text
lab' (bl -> bl) -> WithSourceMap bl -> WithSourceMap bl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithSourceMap bl
x) WithSourceMap bl -> WithSourceMap () -> WithSourceMap bl
forall a b. WithSourceMap a -> WithSourceMap b -> WithSourceMap a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> WithSourceMap ()
addName Text
"footnote"
  footnoteList :: [WithSourceMap bl] -> WithSourceMap bl
footnoteList [WithSourceMap bl]
items = [bl] -> bl
forall il bl. HasFootnote il bl => [bl] -> bl
footnoteList ([bl] -> bl) -> WithSourceMap [bl] -> WithSourceMap bl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [WithSourceMap bl] -> WithSourceMap [bl]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [WithSourceMap bl]
items
  footnoteRef :: Text -> Text -> WithSourceMap bl -> WithSourceMap il
footnoteRef Text
x Text
y WithSourceMap bl
z = (Text -> Text -> bl -> il
forall il bl. HasFootnote il bl => Text -> Text -> bl -> il
footnoteRef Text
x Text
y (bl -> il) -> WithSourceMap bl -> WithSourceMap il
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithSourceMap bl
z) WithSourceMap il -> WithSourceMap () -> WithSourceMap il
forall a b. WithSourceMap a -> WithSourceMap b -> WithSourceMap a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> WithSourceMap ()
addName Text
"footnoteRef"