{-# LANGUAGE CPP #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
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)
import Data.List
import Data.Maybe (fromMaybe, mapMaybe)
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup (Semigroup)
import Data.Monoid
#endif
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 (ReferenceMap -> m (Either ParseError bl))
  deriving Typeable

instance Eq (FootnoteDef bl m) where
  FootnoteDef Int
num1 Text
lab1 ReferenceMap -> m (Either ParseError bl)
_ == :: FootnoteDef bl m -> FootnoteDef bl m -> Bool
== FootnoteDef Int
num2 Text
lab2 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 ReferenceMap -> m (Either ParseError bl)
_) compare :: FootnoteDef bl m -> FootnoteDef bl m -> Ordering
`compare` (FootnoteDef Int
num2 Text
lab2 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)

footnoteSpec :: (Monad m, Typeable m, IsBlock il bl, IsInline il,
                 Typeable il, Typeable bl, HasFootnote il bl)
             => SyntaxSpec m il bl
footnoteSpec :: SyntaxSpec m il bl
footnoteSpec = SyntaxSpec Any il Any
forall a. Monoid a => a
mempty
  { syntaxBlockSpecs :: [BlockSpec m il bl]
syntaxBlockSpecs = [BlockSpec m il bl
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]
  , syntaxInlineParsers :: [InlineParser m il]
syntaxInlineParsers = [InlineParser m il -> InlineParser m il
forall a (m :: * -> *).
(IsInline a, Monad m) =>
InlineParser m a -> InlineParser m a
withAttributes InlineParser m il
forall (m :: * -> *) a b.
(Monad m, Typeable m, Typeable a, Typeable b, IsInline a,
 IsBlock a b, HasFootnote a b) =>
InlineParser m a
pFootnoteRef]
  , syntaxFinalParsers :: [BlockParser m il bl bl]
syntaxFinalParsers = [BlockParser m il bl bl
forall (m :: * -> *) bl il.
(Monad m, Typeable m, Typeable bl, HasFootnote il bl,
 IsBlock il bl) =>
BlockParser m il bl bl
addFootnoteList]
  }

footnoteBlockSpec :: (Monad m, Typeable m, Typeable il, Typeable bl,
                      IsBlock il bl, IsInline il, HasFootnote il bl)
                  => BlockSpec m il bl
footnoteBlockSpec :: BlockSpec m il bl
footnoteBlockSpec = BlockSpec :: forall (m :: * -> *) il bl.
Text
-> BlockParser m il bl BlockStartResult
-> (BlockSpec m il bl -> Bool)
-> Bool
-> Bool
-> (BlockNode m il bl
    -> BlockParser m il bl (SourcePos, BlockNode m il bl))
-> (BlockNode m il bl -> BlockParser m il bl bl)
-> (BlockNode m il bl
    -> BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl))
-> BlockSpec m il bl
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
             SourcePos
pos <- ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
             Text
lab' <- ParsecT [Tok] (BPState m il bl) m Text
forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m Text
pFootnoteLabel
             Tok
_ <- Char -> ParsecT [Tok] (BPState m il bl) m Tok
forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
':'
             Map Text Dynamic
counters' <- BPState m il bl -> Map Text Dynamic
forall (m :: * -> *) il bl. BPState m il bl -> Map Text Dynamic
counters (BPState m il bl -> Map Text Dynamic)
-> ParsecT [Tok] (BPState m il bl) m (BPState m il bl)
-> ParsecT [Tok] (BPState m il bl) m (Map Text Dynamic)
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 num :: Int
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Dynamic -> Maybe Int
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic
             (BPState m il bl -> BPState m il bl)
-> ParsecT [Tok] (BPState m il bl) m ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState ((BPState m il bl -> BPState m il bl)
 -> ParsecT [Tok] (BPState m il bl) m ())
-> (BPState m il bl -> BPState m il bl)
-> ParsecT [Tok] (BPState m il bl) m ()
forall a b. (a -> b) -> a -> b
$ \BPState m il bl
s -> BPState m il bl
s{ counters :: Map Text Dynamic
counters =
                                     Text -> Dynamic -> Map Text Dynamic -> Map Text Dynamic
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
"footnote" (Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (Int
num Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
                                      (BPState m il bl -> Map Text Dynamic
forall (m :: * -> *) il bl. BPState m il bl -> Map Text Dynamic
counters BPState m il bl
s) }
             BlockNode m il bl -> ParsecT [Tok] (BPState m il bl) m ()
forall (m :: * -> *) bl il.
Monad m =>
BlockNode m bl il -> BlockParser m bl il ()
addNodeToStack (BlockNode m il bl -> ParsecT [Tok] (BPState m il bl) m ())
-> BlockNode m il bl -> ParsecT [Tok] (BPState m il bl) m ()
forall a b. (a -> b) -> a -> b
$
                BlockData m il bl
-> Forest (BlockData m il bl) -> BlockNode m il bl
forall a. a -> Forest a -> Tree a
Node (BlockSpec m il bl -> BlockData m il bl
forall (m :: * -> *) il bl. BlockSpec m il bl -> BlockData m il bl
defBlockData BlockSpec m il bl
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){
                            blockData :: Dynamic
blockData = (Int, Text) -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (Int
num, Text
lab')
                          , blockStartPos :: [SourcePos]
blockStartPos = [SourcePos
pos] } []
             BlockStartResult -> BlockParser m il bl BlockStartResult
forall (m :: * -> *) a. Monad m => a -> m a
return BlockStartResult
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 (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 (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 (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)
             SourcePos
pos <- ParsecT [Tok] (BPState m il bl) m SourcePos
forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
             (SourcePos, BlockNode m il bl)
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
forall (m :: * -> *) a. Monad m => a -> m a
return ((SourcePos, BlockNode m il bl)
 -> BlockParser m il bl (SourcePos, BlockNode m il bl))
-> (SourcePos, BlockNode m il bl)
-> BlockParser m il bl (SourcePos, BlockNode m il bl)
forall a b. (a -> b) -> a -> b
$! (SourcePos
pos, BlockNode m il bl
n)
     , blockConstructor :: BlockNode m il bl -> BlockParser m il bl bl
blockConstructor    = \BlockNode m il bl
node ->
          [bl] -> bl
forall a. Monoid a => [a] -> a
mconcat ([bl] -> bl)
-> ParsecT [Tok] (BPState m il bl) m [bl] -> BlockParser m il bl bl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BlockNode m il bl -> BlockParser m il bl bl)
-> Forest (BlockData m il bl)
-> ParsecT [Tok] (BPState m il bl) m [bl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\BlockNode m il bl
n ->
              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 (BlockNode m il bl -> BlockData m il bl
forall a. Tree a -> a
rootLabel BlockNode m il bl
n)) BlockNode m il bl
n)
           (BlockNode m il bl -> Forest (BlockData m il bl)
forall a. Tree a -> Forest a
subForest (BlockNode m il bl -> BlockNode m il bl
forall a. Tree a -> Tree a
reverseSubforests BlockNode m il bl
node))
     , blockFinalize :: BlockNode m il bl
-> BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl)
blockFinalize       = \(Node BlockData m il bl
root Forest (BlockData 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)
         BPState m il bl
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 -> m (Either ParseError bl)
mkNoteContents ReferenceMap
refmap =
               BlockParser m il bl bl
-> BPState m il bl
-> SourceName
-> [Tok]
-> m (Either ParseError bl)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> u -> SourceName -> 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
-> Forest (BlockData m il bl) -> BlockNode m il bl
forall a. a -> Forest a -> Tree a
Node BlockData m il bl
root Forest (BlockData m il bl)
children))
                 BPState m il bl
st{ referenceMap :: ReferenceMap
referenceMap = ReferenceMap
refmap }
                 SourceName
"source" []
         (BPState m il bl -> BPState m il bl)
-> ParsecT [Tok] (BPState m il bl) m ()
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState ((BPState m il bl -> BPState m il bl)
 -> ParsecT [Tok] (BPState m il bl) m ())
-> (BPState m il bl -> BPState m il bl)
-> ParsecT [Tok] (BPState m il bl) m ()
forall a b. (a -> b) -> a -> b
$ \BPState m il bl
s -> BPState m il bl
s{
             referenceMap :: ReferenceMap
referenceMap = Text -> FootnoteDef bl m -> ReferenceMap -> ReferenceMap
forall a. Typeable a => Text -> a -> ReferenceMap -> ReferenceMap
insertReference Text
lab'
                              (Int
-> Text
-> (ReferenceMap -> m (Either ParseError bl))
-> FootnoteDef bl m
forall bl (m :: * -> *).
Int
-> Text
-> (ReferenceMap -> m (Either ParseError bl))
-> FootnoteDef bl m
FootnoteDef Int
num Text
lab' ReferenceMap -> m (Either ParseError bl)
mkNoteContents)
                              (BPState m il bl -> ReferenceMap
forall (m :: * -> *) il bl. BPState m il bl -> ReferenceMap
referenceMap BPState m il bl
s)
             }
         BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl)
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl))
-> BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl)
forall a b. (a -> b) -> a -> b
$! BlockNode m il bl
parent
     }

pFootnoteLabel :: Monad m => ParsecT [Tok] u m Text
pFootnoteLabel :: 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
  Text
lab <- ParsecT [Tok] u m Text
forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m Text
pLinkLabel
  case Text -> Maybe (Char, Text)
T.uncons Text
lab of
        Just (Char
'^', Text
t') -> Text -> ParsecT [Tok] u m Text
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 (m :: * -> *) a. MonadPlus m => m a
mzero

pFootnoteRef :: (Monad m, Typeable m, Typeable a,
                 Typeable b, IsInline a, IsBlock a b, HasFootnote a b)
             => InlineParser m a
pFootnoteRef :: InlineParser m a
pFootnoteRef = InlineParser m a -> InlineParser m a
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try (InlineParser m a -> InlineParser m a)
-> InlineParser m a -> InlineParser m a
forall a b. (a -> b) -> a -> b
$ do
  Text
lab <- ParsecT [Tok] (IPState m) (StateT Enders m) Text
forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m Text
pFootnoteLabel
  ReferenceMap
rm <- InlineParser m ReferenceMap
forall (m :: * -> *). Monad m => InlineParser m ReferenceMap
getReferenceMap
  case Text -> ReferenceMap -> Maybe (FootnoteDef b m)
forall a. Typeable a => Text -> ReferenceMap -> Maybe a
lookupReference Text
lab ReferenceMap
rm of
        Just (FootnoteDef Int
num Text
_ ReferenceMap -> m (Either ParseError b)
mkContents) -> do
          Either ParseError b
res <- StateT Enders m (Either ParseError b)
-> ParsecT
     [Tok] (IPState m) (StateT Enders m) (Either ParseError b)
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 (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 ReferenceMap
rm
          case Either ParseError b
res of
               Left ParseError
err -> (State [Tok] (IPState m)
 -> StateT
      Enders m (Consumed (StateT Enders m (Reply [Tok] (IPState m) a))))
-> InlineParser 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 (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 (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 -> InlineParser m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> InlineParser m a) -> a -> InlineParser m a
forall a b. (a -> b) -> a -> b
$!
                 Text -> Text -> b -> a
forall il bl. HasFootnote il bl => Text -> Text -> bl -> il
footnoteRef (SourceName -> Text
T.pack (Int -> SourceName
forall a. Show a => a -> SourceName
show Int
num)) Text
lab b
contents
        Maybe (FootnoteDef b m)
Nothing -> InlineParser m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

addFootnoteList :: (Monad m, Typeable m, Typeable bl, HasFootnote il bl,
                    IsBlock il bl) => BlockParser m il bl bl
addFootnoteList :: BlockParser m il bl bl
addFootnoteList = do
  ReferenceMap
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 :: [Text]
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 -> Maybe a
getNote Text
key = Text -> ReferenceMap -> Maybe a
forall a. Typeable a => Text -> ReferenceMap -> Maybe a
lookupReference Text
key ReferenceMap
rm
  let notes :: [FootnoteDef bl m]
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)
forall a. Typeable a => Text -> Maybe a
getNote [Text]
keys
  let renderNote :: FootnoteDef b m -> ParsecT s u m b
renderNote (FootnoteDef Int
num Text
lab ReferenceMap -> m (Either ParseError b)
mkContents) = do
        Either ParseError b
res <- m (Either ParseError b) -> ParsecT s u m (Either ParseError b)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either ParseError b) -> ParsecT s u m (Either ParseError b))
-> m (Either ParseError b) -> ParsecT s u m (Either ParseError b)
forall a b. (a -> b) -> a -> b
$ ReferenceMap -> m (Either ParseError b)
mkContents ReferenceMap
rm
        case Either ParseError b
res of
             Left ParseError
err -> (State s u -> m (Consumed (m (Reply s u b)))) -> ParsecT s u m b
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 b)) -> m (Consumed (m (Reply s u b)))
forall (m :: * -> *) a. Monad m => a -> m a
return (m (Reply s u b) -> Consumed (m (Reply s u b))
forall a. a -> Consumed a
Empty (Reply s u b -> m (Reply s u b)
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseError -> Reply s u b
forall s u a. ParseError -> Reply s u a
Error ParseError
err))))
             Right b
contents -> b -> ParsecT s u m b
forall (m :: * -> *) a. Monad m => a -> m a
return (b -> ParsecT s u m b) -> b -> ParsecT s u m b
forall a b. (a -> b) -> a -> b
$! Int -> Text -> b -> b
forall il bl. HasFootnote il bl => Int -> Text -> bl -> bl
footnote Int
num Text
lab b
contents
  if [FootnoteDef bl m] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FootnoteDef bl m]
notes
     then bl -> BlockParser m il bl bl
forall (m :: * -> *) a. Monad m => a -> m a
return bl
forall a. Monoid a => a
mempty
     else [bl] -> bl
forall il bl. HasFootnote il bl => [bl] -> bl
footnoteList ([bl] -> bl)
-> ParsecT [Tok] (BPState m il bl) m [bl] -> BlockParser m il bl bl
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FootnoteDef bl m -> BlockParser m il bl bl)
-> [FootnoteDef bl m] -> ParsecT [Tok] (BPState m il bl) m [bl]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FootnoteDef bl m -> BlockParser m il bl bl
forall (m :: * -> *) il b s u.
(Monad m, HasFootnote il b) =>
FootnoteDef b m -> ParsecT s u m b
renderNote [FootnoteDef bl m]
notes

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
$ SourceName -> Text
T.pack (SourceName -> Text) -> SourceName -> Text
forall a b. (a -> b) -> a -> b
$ Int -> SourceName
forall a. Show a => a -> SourceName
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 (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)
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 (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> WithSourceMap ()
addName Text
"footnoteRef"