1{-# LANGUAGE CPP #-} 2{-# LANGUAGE FunctionalDependencies #-} 3{-# LANGUAGE UndecidableInstances #-} 4{-# LANGUAGE MultiParamTypeClasses #-} 5{-# LANGUAGE FlexibleInstances #-} 6{-# LANGUAGE OverloadedStrings #-} 7module Commonmark.Extensions.Footnote 8 ( footnoteSpec 9 , HasFootnote(..) 10 ) 11where 12import Commonmark.Tokens 13import Commonmark.Types 14import Commonmark.Html 15import Commonmark.Syntax 16import Commonmark.Blocks 17import Commonmark.Inlines 18import Commonmark.SourceMap 19import Commonmark.TokParsers 20import Commonmark.ReferenceMap 21import Control.Monad.Trans.Class (lift) 22import Control.Monad (mzero) 23import Data.List 24import Data.Maybe (fromMaybe, mapMaybe) 25#if !MIN_VERSION_base(4,11,0) 26import Data.Semigroup (Semigroup) 27import Data.Monoid 28#endif 29import Data.Dynamic 30import Data.Tree 31import Text.Parsec 32import Data.Text (Text) 33import qualified Data.Text as T 34import qualified Data.Map as M 35 36data FootnoteDef bl m = 37 FootnoteDef Int Text (ReferenceMap -> m (Either ParseError bl)) 38 deriving Typeable 39 40instance Eq (FootnoteDef bl m) where 41 FootnoteDef num1 lab1 _ == FootnoteDef num2 lab2 _ 42 = num1 == num2 && lab1 == lab2 43 44instance Ord (FootnoteDef bl m) where 45 (FootnoteDef num1 lab1 _) `compare` (FootnoteDef num2 lab2 _) = 46 (num1, lab1) `compare` (num2, lab2) 47 48footnoteSpec :: (Monad m, Typeable m, IsBlock il bl, IsInline il, 49 Typeable il, Typeable bl, HasFootnote il bl) 50 => SyntaxSpec m il bl 51footnoteSpec = mempty 52 { syntaxBlockSpecs = [footnoteBlockSpec] 53 , syntaxInlineParsers = [withAttributes pFootnoteRef] 54 , syntaxFinalParsers = [addFootnoteList] 55 } 56 57footnoteBlockSpec :: (Monad m, Typeable m, Typeable il, Typeable bl, 58 IsBlock il bl, IsInline il, HasFootnote il bl) 59 => BlockSpec m il bl 60footnoteBlockSpec = BlockSpec 61 { blockType = "Footnote" 62 , blockStart = try $ do 63 nonindentSpaces 64 pos <- getPosition 65 lab' <- pFootnoteLabel 66 _ <- symbol ':' 67 counters' <- counters <$> getState 68 let num = fromMaybe (1 :: Int) $ 69 M.lookup "footnote" counters' >>= fromDynamic 70 updateState $ \s -> s{ counters = 71 M.insert "footnote" (toDyn (num + 1)) 72 (counters s) } 73 addNodeToStack $ 74 Node (defBlockData footnoteBlockSpec){ 75 blockData = toDyn (num, lab') 76 , blockStartPos = [pos] } [] 77 return BlockStartMatch 78 , blockCanContain = const True 79 , blockContainsLines = False 80 , blockParagraph = False 81 , blockContinue = \n -> try $ do 82 () <$ (gobbleSpaces 4) 83 <|> (skipWhile (hasType Spaces) >> () <$ lookAhead lineEnd) 84 pos <- getPosition 85 return $! (pos, n) 86 , blockConstructor = \node -> 87 mconcat <$> mapM (\n -> 88 blockConstructor (blockSpec (rootLabel n)) n) 89 (subForest (reverseSubforests node)) 90 , blockFinalize = \(Node root children) parent -> do 91 let (num, lab') = fromDyn (blockData root) (1, mempty) 92 st <- getState 93 let mkNoteContents refmap = 94 runParserT 95 (blockConstructor (blockSpec root) (Node root children)) 96 st{ referenceMap = refmap } 97 "source" [] 98 updateState $ \s -> s{ 99 referenceMap = insertReference lab' 100 (FootnoteDef num lab' mkNoteContents) 101 (referenceMap s) 102 } 103 return $! parent 104 } 105 106pFootnoteLabel :: Monad m => ParsecT [Tok] u m Text 107pFootnoteLabel = try $ do 108 lab <- pLinkLabel 109 case T.uncons lab of 110 Just ('^', t') -> return $! t' 111 _ -> mzero 112 113pFootnoteRef :: (Monad m, Typeable m, Typeable a, 114 Typeable b, IsInline a, IsBlock a b, HasFootnote a b) 115 => InlineParser m a 116pFootnoteRef = try $ do 117 lab <- pFootnoteLabel 118 rm <- getReferenceMap 119 case lookupReference lab rm of 120 Just (FootnoteDef num _ mkContents) -> do 121 res <- lift . lift $ mkContents rm 122 case res of 123 Left err -> mkPT (\_ -> return (Empty (return (Error err)))) 124 Right contents -> return $! 125 footnoteRef (T.pack (show num)) lab contents 126 Nothing -> mzero 127 128addFootnoteList :: (Monad m, Typeable m, Typeable bl, HasFootnote il bl, 129 IsBlock il bl) => BlockParser m il bl bl 130addFootnoteList = do 131 rm <- referenceMap <$> getState 132 let keys = M.keys . unReferenceMap $ rm 133 let getNote key = lookupReference key rm 134 let notes = sort $ mapMaybe getNote keys 135 let renderNote (FootnoteDef num lab mkContents) = do 136 res <- lift $ mkContents rm 137 case res of 138 Left err -> mkPT (\_ -> return (Empty (return (Error err)))) 139 Right contents -> return $! footnote num lab contents 140 if null notes 141 then return mempty 142 else footnoteList <$> mapM renderNote notes 143 144class IsBlock il bl => HasFootnote il bl | il -> bl where 145 footnote :: Int -> Text -> bl -> bl 146 footnoteList :: [bl] -> bl 147 footnoteRef :: Text -> Text -> bl -> il 148 149instance Rangeable (Html a) => HasFootnote (Html a) (Html a) where 150 footnote num lab' x = 151 addAttribute ("class", "footnote") $ 152 addAttribute ("id", "fn-" <> lab') $ 153 htmlBlock "div" $ Just $ htmlRaw "\n" <> 154 (addAttribute ("class", "footnote-number") $ 155 htmlBlock "div" $ Just $ htmlRaw "\n" <> 156 (addAttribute ("href", "#fnref-" <> lab') $ 157 htmlInline "a" (Just $ htmlText $ T.pack $ show num)) <> 158 htmlRaw "\n") <> 159 (addAttribute ("class", "footnote-contents") $ 160 htmlBlock "div" $ Just $ htmlRaw "\n" <> x) 161 footnoteList items = 162 addAttribute ("class", "footnotes") $ 163 htmlBlock "section" $ Just $ htmlRaw "\n" <> mconcat items 164 footnoteRef x lab _ = 165 addAttribute ("class", "footnote-ref") $ 166 htmlInline "sup" $ Just $ 167 addAttribute ("href", "#fn-" <> lab) $ 168 addAttribute ("id", "fnref-" <> lab) $ 169 htmlInline "a" $ Just (htmlText x) 170 171instance (HasFootnote il bl, Semigroup bl, Semigroup il) 172 => HasFootnote (WithSourceMap il) (WithSourceMap bl) where 173 footnote num lab' x = (footnote num lab' <$> x) <* addName "footnote" 174 footnoteList items = footnoteList <$> sequence items 175 footnoteRef x y z = (footnoteRef x y <$> z) <* addName "footnoteRef" 176