{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# 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)
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 :: 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 Any il Any
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
             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 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
             (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 =
                                     M.insert "footnote" (toDyn (num + 1))
                                      (counters 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 -> [BlockNode m il bl] -> BlockNode m il bl
forall a. a -> [Tree 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 = toDyn (num, lab')
                          , blockStartPos = [pos] } []
             BlockStartResult -> BlockParser m il bl BlockStartResult
forall a. a -> ParsecT [Tok] (BPState m il bl) m a
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 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)
             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 a. a -> ParsecT [Tok] (BPState m il bl) m a
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)
-> [BlockNode 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 -> [BlockNode m il bl]
forall a. Tree a -> [Tree 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 [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)
         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 -> [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 }
                 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 = insertReference lab'
                              (FootnoteDef num lab' mkNoteContents)
                              (referenceMap s)
             }
         BlockNode m il bl -> BlockParser m il bl (BlockNode m il bl)
forall a. a -> ParsecT [Tok] (BPState m il bl) m a
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 :: 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
  Text
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 Text -> Maybe (Char, Text)
T.uncons Text
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 :: (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
  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 (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 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))))
-> 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 (SourceName -> Text
T.pack (Int -> SourceName
forall a. Show a => a -> SourceName
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 :: (Monad m, Typeable m, Typeable bl, HasFootnote il bl,
                    IsBlock il bl) => BlockParser m il bl bl
addFootnoteList :: forall (m :: * -> *) bl il.
(Monad m, Typeable m, Typeable bl, HasFootnote il bl,
 IsBlock il bl) =>
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 (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 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 a. a -> m a
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 a. a -> m a
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 a. a -> ParsecT s u m a
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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FootnoteDef bl m]
notes
     then 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
     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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 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"