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