{-# 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 bl m =
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 forall a. Eq a => a -> a -> Bool
== Int
num2 Bool -> Bool -> Bool
&& Text
lab1 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) 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
= forall a. Monoid a => a
mempty
{ syntaxBlockSpecs :: [BlockSpec m il bl]
syntaxBlockSpecs = [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 = [forall a (m :: * -> *).
(IsInline a, Monad m) =>
InlineParser m a -> InlineParser m a
withAttributes 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 = [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
= BlockSpec
{ blockType :: Text
blockType = Text
"Footnote"
, blockStart :: BlockParser m il bl BlockStartResult
blockStart = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m ()
nonindentSpaces
SourcePos
pos <- forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
Text
lab' <- forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m Text
pFootnoteLabel
Tok
_ <- forall (m :: * -> *) s. Monad m => Char -> ParsecT [Tok] s m Tok
symbol Char
':'
Map Text Dynamic
counters' <- forall (m :: * -> *) il bl. BPState m il bl -> Map Text Dynamic
counters forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
let num :: Int
num = forall a. a -> Maybe a -> a
fromMaybe (Int
1 :: Int) forall a b. (a -> b) -> a -> b
$
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
"footnote" Map Text Dynamic
counters' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Typeable a => Dynamic -> Maybe a
fromDynamic
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState forall a b. (a -> b) -> a -> b
$ \BPState m il bl
s -> BPState m il bl
s{ counters :: Map Text Dynamic
counters =
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
"footnote" (forall a. Typeable a => a -> Dynamic
toDyn (Int
num forall a. Num a => a -> a -> a
+ Int
1))
(forall (m :: * -> *) il bl. BPState m il bl -> Map Text Dynamic
counters BPState m il bl
s) }
forall (m :: * -> *) bl il.
Monad m =>
BlockNode m bl il -> BlockParser m bl il ()
addNodeToStack forall a b. (a -> b) -> a -> b
$
forall a. a -> [Tree a] -> Tree a
Node (forall (m :: * -> *) il bl. BlockSpec m il bl -> BlockData m il bl
defBlockData 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 = forall a. Typeable a => a -> Dynamic
toDyn (Int
num, Text
lab')
, blockStartPos :: [SourcePos]
blockStartPos = [SourcePos
pos] } []
forall (m :: * -> *) a. Monad m => a -> m a
return BlockStartResult
BlockStartMatch
, blockCanContain :: BlockSpec m il bl -> Bool
blockCanContain = 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 -> forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
() forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (forall (m :: * -> *) u. Monad m => Int -> ParsecT [Tok] u m Int
gobbleSpaces Int
4)
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> (forall (m :: * -> *) u.
Monad m =>
(Tok -> Bool) -> ParsecT [Tok] u m ()
skipWhile (TokType -> Tok -> Bool
hasType TokType
Spaces) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m a
lookAhead forall (m :: * -> *) s. Monad m => ParsecT [Tok] s m Tok
lineEnd)
SourcePos
pos <- forall (m :: * -> *) s u. Monad m => ParsecT s u m SourcePos
getPosition
forall (m :: * -> *) a. Monad m => a -> m a
return 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 ->
forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\BlockNode m il bl
n ->
forall (m :: * -> *) il bl.
BlockSpec m il bl -> BlockNode m il bl -> BlockParser m il bl bl
blockConstructor (forall (m :: * -> *) il bl. BlockData m il bl -> BlockSpec m il bl
blockSpec (forall a. Tree a -> a
rootLabel BlockNode m il bl
n)) BlockNode m il bl
n)
(forall a. Tree a -> [Tree a]
subForest (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') = forall a. Typeable a => Dynamic -> a -> a
fromDyn (forall (m :: * -> *) il bl. BlockData m il bl -> Dynamic
blockData BlockData m il bl
root) (Int
1, forall a. Monoid a => a
mempty)
BPState m il bl
st <- forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
let mkNoteContents :: ReferenceMap -> m (Either ParseError bl)
mkNoteContents ReferenceMap
refmap =
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> u -> SourceName -> s -> m (Either ParseError a)
runParserT
(forall (m :: * -> *) il bl.
BlockSpec m il bl -> BlockNode m il bl -> BlockParser m il bl bl
blockConstructor (forall (m :: * -> *) il bl. BlockData m il bl -> BlockSpec m il bl
blockSpec BlockData m il bl
root) (forall a. a -> [Tree a] -> Tree a
Node BlockData m il bl
root [BlockNode m il bl]
children))
BPState m il bl
st{ referenceMap :: ReferenceMap
referenceMap = ReferenceMap
refmap }
SourceName
"source" []
forall (m :: * -> *) u s. Monad m => (u -> u) -> ParsecT s u m ()
updateState forall a b. (a -> b) -> a -> b
$ \BPState m il bl
s -> BPState m il bl
s{
referenceMap :: ReferenceMap
referenceMap = forall a. Typeable a => Text -> a -> ReferenceMap -> ReferenceMap
insertReference Text
lab'
(forall bl (m :: * -> *).
Int
-> Text
-> (ReferenceMap -> m (Either ParseError bl))
-> FootnoteDef bl m
FootnoteDef Int
num Text
lab' ReferenceMap -> m (Either ParseError bl)
mkNoteContents)
(forall (m :: * -> *) il bl. BPState m il bl -> ReferenceMap
referenceMap BPState m il bl
s)
}
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! BlockNode m il bl
parent
}
pFootnoteLabel :: Monad m => ParsecT [Tok] u m Text
= forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
Text
lab <- 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') -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Text
t'
Maybe (Char, 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
= forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try forall a b. (a -> b) -> a -> b
$ do
Text
lab <- forall (m :: * -> *) u. Monad m => ParsecT [Tok] u m Text
pFootnoteLabel
ReferenceMap
rm <- forall (m :: * -> *). Monad m => InlineParser m ReferenceMap
getReferenceMap
case 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ ReferenceMap -> m (Either ParseError b)
mkContents ReferenceMap
rm
case Either ParseError b
res of
Left ParseError
err -> 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)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Consumed a
Empty (forall (m :: * -> *) a. Monad m => a -> m a
return (forall s u a. ParseError -> Reply s u a
Error ParseError
err))))
Right b
contents -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$!
forall il bl. HasFootnote il bl => Text -> Text -> bl -> il
footnoteRef (SourceName -> Text
T.pack (forall a. Show a => a -> SourceName
show Int
num)) Text
lab b
contents
Maybe (FootnoteDef b m)
Nothing -> 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
= do
ReferenceMap
rm <- forall (m :: * -> *) il bl. BPState m il bl -> ReferenceMap
referenceMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) s u. Monad m => ParsecT s u m u
getState
let keys :: [Text]
keys = forall k a. Map k a -> [k]
M.keys forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReferenceMap -> Map Text [Dynamic]
unReferenceMap forall a b. (a -> b) -> a -> b
$ ReferenceMap
rm
let getNote :: Text -> Maybe a
getNote Text
key = forall a. Typeable a => Text -> ReferenceMap -> Maybe a
lookupReference Text
key ReferenceMap
rm
let notes :: [FootnoteDef bl m]
notes = forall a. Ord a => [a] -> [a]
sort forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ ReferenceMap -> m (Either ParseError b)
mkContents ReferenceMap
rm
case Either ParseError b
res of
Left ParseError
err -> 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Consumed a
Empty (forall (m :: * -> *) a. Monad m => a -> m a
return (forall s u a. ParseError -> Reply s u a
Error ParseError
err))))
Right b
contents -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall il bl. HasFootnote il bl => Int -> Text -> bl -> bl
footnote Int
num Text
lab b
contents
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FootnoteDef bl m]
notes
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
else forall il bl. HasFootnote il bl => [bl] -> bl
footnoteList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM 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 => il bl | il -> bl where
:: Int -> Text -> bl -> bl
:: [bl] -> bl
:: 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 =
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class", Text
"footnote") forall a b. (a -> b) -> a -> b
$
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"id", Text
"fn-" forall a. Semigroup a => a -> a -> a
<> Text
lab') forall a b. (a -> b) -> a -> b
$
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"div" forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Text -> Html a
htmlRaw Text
"\n" forall a. Semigroup a => a -> a -> a
<>
(forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class", Text
"footnote-number") forall a b. (a -> b) -> a -> b
$
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"div" forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Text -> Html a
htmlRaw Text
"\n" forall a. Semigroup a => a -> a -> a
<>
(forall a. Attribute -> Html a -> Html a
addAttribute (Text
"href", Text
"#fnref-" forall a. Semigroup a => a -> a -> a
<> Text
lab') forall a b. (a -> b) -> a -> b
$
forall a. Text -> Maybe (Html a) -> Html a
htmlInline Text
"a" (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Text -> Html a
htmlText forall a b. (a -> b) -> a -> b
$ SourceName -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> SourceName
show Int
num)) forall a. Semigroup a => a -> a -> a
<>
forall a. Text -> Html a
htmlRaw Text
"\n") forall a. Semigroup a => a -> a -> a
<>
(forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class", Text
"footnote-contents") forall a b. (a -> b) -> a -> b
$
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"div" forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Text -> Html a
htmlRaw Text
"\n" forall a. Semigroup a => a -> a -> a
<> Html a
x)
footnoteList :: [Html a] -> Html a
footnoteList [Html a]
items =
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class", Text
"footnotes") forall a b. (a -> b) -> a -> b
$
forall a. Text -> Maybe (Html a) -> Html a
htmlBlock Text
"section" forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Text -> Html a
htmlRaw Text
"\n" forall a. Semigroup a => a -> a -> 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
_ =
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"class", Text
"footnote-ref") forall a b. (a -> b) -> a -> b
$
forall a. Text -> Maybe (Html a) -> Html a
htmlInline Text
"sup" forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"href", Text
"#fn-" forall a. Semigroup a => a -> a -> a
<> Text
lab) forall a b. (a -> b) -> a -> b
$
forall a. Attribute -> Html a -> Html a
addAttribute (Text
"id", Text
"fnref-" forall a. Semigroup a => a -> a -> a
<> Text
lab) forall a b. (a -> b) -> a -> b
$
forall a. Text -> Maybe (Html a) -> Html a
htmlInline Text
"a" forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (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 = (forall il bl. HasFootnote il bl => Int -> Text -> bl -> bl
footnote Int
num Text
lab' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithSourceMap bl
x) 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 = forall il bl. HasFootnote il bl => [bl] -> bl
footnoteList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = (forall il bl. HasFootnote il bl => Text -> Text -> bl -> il
footnoteRef Text
x Text
y forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WithSourceMap bl
z) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Text -> WithSourceMap ()
addName Text
"footnoteRef"