diff --git a/changelog.md b/changelog.md
--- a/changelog.md
+++ b/changelog.md
@@ -1,5 +1,28 @@
# Changelog for commonmark-extensions
+## 0.2.7.2
+
+ * Footnotes: memoize note rendering and detect reference cycles.
+
+ * TaskList: re-sync forked list finalizers with the core versions.
+ Task lists now get the same tight/loose classification as
+ identically shaped plain lists.
+
+ * FancyList: require whole word to be a valid roman numeral.
+ Previously "vv. item" parsed as a roman list with start="5".
+
+ * Math: allow an unbraced `$` inside display math.
+
+ * Use `renderChildren` in definition list and footnote constructors.
+ Both called blockConstructor directly on child nodes, bypassing
+ renderChildren, so child blocks lost their attributes and source ranges.
+
+ * Autolink: implement GFM preceding-character restriction.
+ GFM recognizes extended www/url autolinks only when preceded by the
+ beginning of a line, whitespace, or one of `(`, `*`, `_`, `~`, `[`.
+
+ * Autolink: fix ']' guard to test bracket counter, not paren counter.
+
## 0.2.7.1
* Task list extension: andle empty task list items correctly (#174,
diff --git a/commonmark-extensions.cabal b/commonmark-extensions.cabal
--- a/commonmark-extensions.cabal
+++ b/commonmark-extensions.cabal
@@ -1,5 +1,5 @@
name: commonmark-extensions
-version: 0.2.7.1
+version: 0.2.7.2
synopsis: Pure Haskell commonmark parser.
description:
This library provides some useful extensions to core commonmark
diff --git a/src/Commonmark/Extensions/Attributes.hs b/src/Commonmark/Extensions/Attributes.hs
--- a/src/Commonmark/Extensions/Attributes.hs
+++ b/src/Commonmark/Extensions/Attributes.hs
@@ -27,7 +27,7 @@
import Commonmark.Html
import Data.Dynamic
import Data.Tree
-import Control.Monad (mzero, guard, void)
+import Control.Monad (guard, void)
import Text.Parsec
class HasDiv bl where
@@ -282,6 +282,5 @@
Symbol '}'])
let val' = case val of
Tok (Symbol '"') _ _:_:_ -> drop 1 $ init $ val
- Tok (Symbol '\'') _ _:_:_ -> mzero
_ -> val
return $! (untokenize name, unEntity val')
diff --git a/src/Commonmark/Extensions/Autolink.hs b/src/Commonmark/Extensions/Autolink.hs
--- a/src/Commonmark/Extensions/Autolink.hs
+++ b/src/Commonmark/Extensions/Autolink.hs
@@ -28,8 +28,25 @@
(prefix, linktext) <- withRaw $ wwwAutolink <|> urlAutolink <|> emailAutolink
return $! link (prefix <> untokenize linktext) "" (str . untokenize $ linktext)
+-- GFM: extended www and url autolinks are recognized only when
+-- preceded by the beginning of a line, whitespace, or one of the
+-- characters (, *, _, ~. We additionally allow [, since
+-- commonmark-hs recognizes autolinks inside square brackets
+-- (see test/autolinks.md).
+guardPreceded :: Monad m => InlineParser m ()
+guardPreceded = do
+ mbty <- getPrecedingTokType
+ guard $ case mbty of
+ Nothing -> True
+ Just Spaces -> True
+ Just UnicodeSpace -> True
+ Just LineEnd -> True
+ Just (Symbol c) -> c `elem` ['(', '*', '_', '~', '[']
+ Just WordChars -> False
+
wwwAutolink :: Monad m => InlineParser m Text
wwwAutolink = try $ do
+ guardPreceded
lookAhead $ satisfyWord (== "www")
validDomain
linkPath 0 0
@@ -59,7 +76,7 @@
Symbol '(' -> symbol '(' *> linkPath (openParens + 1) openBrackets
Symbol ')' -> optional $ guard (openParens > 0) *> symbol ')' *> linkPath (openParens - 1) openBrackets
Symbol '[' -> symbol '[' *> linkPath openParens (openBrackets + 1)
- Symbol ']' -> optional $ guard (openParens > 0) *> symbol ']' *> linkPath openParens (openBrackets - 1)
+ Symbol ']' -> optional $ guard (openBrackets > 0) *> symbol ']' *> linkPath openParens (openBrackets - 1)
Symbol '<' -> pure ()
Symbol c | isTrailingPunctuation c -> optional $
try (do skipMany1 trailingPunctuation
@@ -86,6 +103,7 @@
urlAutolink :: Monad m => InlineParser m Text
urlAutolink = try $ do
+ guardPreceded
satisfyWord (`elem` ["http", "https", "ftp"])
symbol ':'
symbol '/'
diff --git a/src/Commonmark/Extensions/DefinitionList.hs b/src/Commonmark/Extensions/DefinitionList.hs
--- a/src/Commonmark/Extensions/DefinitionList.hs
+++ b/src/Commonmark/Extensions/DefinitionList.hs
@@ -38,9 +38,9 @@
, blockContinue = \n -> (,n) <$> getPosition
, blockConstructor = \(Node bdata items) -> do
let listType = fromDyn (blockData bdata) LooseList
- let getItem item@(Node _ ds) = do
+ let getItem item = do
term <- runInlineParser (getBlockText item)
- defs <- mapM (\c -> blockConstructor (bspec c) c) ds
+ defs <- renderChildren item
return $! (term, defs)
definitionList listType <$> mapM getItem items
, blockFinalize = \(Node cdata children) parent -> do
diff --git a/src/Commonmark/Extensions/FancyList.hs b/src/Commonmark/Extensions/FancyList.hs
--- a/src/Commonmark/Extensions/FancyList.hs
+++ b/src/Commonmark/Extensions/FancyList.hs
@@ -103,7 +103,7 @@
Tok WordChars _ ds <- satisfyWord (\t ->
T.length t < 10 &&
T.all isLowerRoman t)
- case parse (romanNumeral False) "" ds of
+ case parse (romanNumeral False <* eof) "" ds of
Left _ -> mzero
Right x -> return $! (x, LowerRoman)
@@ -111,7 +111,7 @@
Tok WordChars _ ds <- satisfyWord (\t ->
T.length t < 10 &&
T.all isUpperRoman t)
- case parse (romanNumeral True) "" ds of
+ case parse (romanNumeral True <* eof) "" ds of
Left _ -> mzero
Right x -> return $! (x, UpperRoman)
diff --git a/src/Commonmark/Extensions/Footnote.hs b/src/Commonmark/Extensions/Footnote.hs
--- a/src/Commonmark/Extensions/Footnote.hs
+++ b/src/Commonmark/Extensions/Footnote.hs
@@ -4,6 +4,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Commonmark.Extensions.Footnote
( footnoteSpec
, HasFootnote(..)
@@ -19,9 +20,10 @@
import Commonmark.TokParsers
import Commonmark.ReferenceMap
import Control.Monad.Trans.Class (lift)
-import Control.Monad (mzero)
+import Control.Monad (mzero, foldM)
+import Data.Graph (stronglyConnComp, flattenSCC)
import Data.List
-import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Maybe (fromMaybe, mapMaybe, catMaybes)
import Data.Dynamic
import Data.Tree
import Text.Parsec
@@ -30,17 +32,34 @@
import qualified Data.Map as M
data FootnoteDef bl m =
- FootnoteDef Int Text (ReferenceMap -> m (Either ParseError bl))
+ FootnoteDef Int Text [Text] (ReferenceMap -> m (Either ParseError bl))
+ -- ^ number, label, labels of footnote references in the body
+ -- (conservative approximation, used only for ordering the
+ -- memoization pass in addFootnoteList), parser for contents
deriving Typeable
instance Eq (FootnoteDef bl m) where
- FootnoteDef num1 lab1 _ == FootnoteDef num2 lab2 _
+ FootnoteDef num1 lab1 _ _ == FootnoteDef num2 lab2 _ _
= num1 == num2 && lab1 == lab2
instance Ord (FootnoteDef bl m) where
- (FootnoteDef num1 lab1 _) `compare` (FootnoteDef num2 lab2 _) =
+ (FootnoteDef num1 lab1 _ _) `compare` (FootnoteDef num2 lab2 _ _) =
(num1, lab1) `compare` (num2, lab2)
+-- | Memoized rendered contents of a footnote, stored in the reference
+-- map (alongside the FootnoteDef) once the note has been rendered, so
+-- that each note body is parsed only once no matter how many times it
+-- is referenced.
+data FootnoteRendered bl = FootnoteRendered Int Text bl
+ deriving Typeable
+
+-- | Marker inserted into the reference map passed to a note body's
+-- parser while that note is being rendered. A reference to an
+-- in-progress note is a cycle; pFootnoteRef treats it as unresolved,
+-- so it falls back to literal text instead of looping forever.
+data FootnoteInProgress = FootnoteInProgress
+ deriving Typeable
+
footnoteSpec :: (Monad m, Typeable m, IsBlock il bl, IsInline il,
Typeable il, Typeable bl, HasFootnote il bl)
=> SyntaxSpec m il bl
@@ -79,10 +98,7 @@
<|> (skipWhile (hasType Spaces) >> () <$ lookAhead lineEnd)
pos <- getPosition
return $! (pos, n)
- , blockConstructor = \node ->
- mconcat <$> mapM (\n ->
- blockConstructor (blockSpec (rootLabel n)) n)
- (subForest (reverseSubforests node))
+ , blockConstructor = fmap mconcat . renderChildren . reverseSubforests
, blockFinalize = \(Node root children) parent -> do
let (num, lab') = fromDyn (blockData root) (1, mempty)
st <- getState
@@ -91,14 +107,29 @@
(blockConstructor (blockSpec root) (Node root children))
st{ referenceMap = refmap }
"source" []
+ let bodytoks = concatMap (concat . reverse . blockLines)
+ (flatten (Node root children))
updateState $ \s -> s{
referenceMap = insertReference lab'
- (FootnoteDef num lab' mkNoteContents)
+ (FootnoteDef num lab' (extractNoteRefs bodytoks)
+ mkNoteContents)
(referenceMap s)
}
return $! parent
}
+-- Conservatively extract the labels of footnote references occurring
+-- in a note body. These are used only to order the rendering of
+-- notes in addFootnoteList so that referenced notes are rendered (and
+-- memoized) before the notes that reference them; inaccuracies affect
+-- only performance, not correctness.
+extractNoteRefs :: [Tok] -> [Text]
+extractNoteRefs toks =
+ case parse (catMaybes <$> many ((Just <$> try pFootnoteLabel)
+ <|> (Nothing <$ anyTok))) "" toks of
+ Left _ -> []
+ Right labs -> labs
+
pFootnoteLabel :: Monad m => ParsecT [Tok] u m Text
pFootnoteLabel = try $ do
lab <- untokenize
@@ -110,36 +141,70 @@
-> return $! t'
_ -> mzero
-pFootnoteRef :: (Monad m, Typeable m, Typeable 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 = try $ do
lab <- pFootnoteLabel
rm <- getReferenceMap
- case lookupReference lab rm of
- Just (FootnoteDef num _ mkContents) -> do
- res <- lift . lift $ mkContents rm
- case res of
- Left err -> mkPT (\_ -> return (Empty (return (Error err))))
- Right contents -> return $!
- footnoteRef (T.pack (show num)) lab contents
- Nothing -> mzero
+ case lookupReference lab rm :: Maybe FootnoteInProgress of
+ Just _ -> mzero -- cyclic reference: leave it as literal text
+ Nothing ->
+ case lookupReference lab rm :: Maybe (FootnoteRendered b) of
+ -- memoized contents (notes are pre-rendered in addFootnoteList,
+ -- which runs before inline parsing of the main document):
+ Just (FootnoteRendered num _ contents) -> return $!
+ footnoteRef (T.pack (show num)) lab contents
+ Nothing ->
+ case lookupReference lab rm :: Maybe (FootnoteDef b m) of
+ -- not yet rendered (only happens while another note that
+ -- references this one is itself being rendered):
+ Just (FootnoteDef num _ _ mkContents) -> do
+ res <- lift . lift $ mkContents
+ (insertReference lab FootnoteInProgress rm)
+ case res of
+ Left err -> mkPT (\_ -> return (Empty (return (Error err))))
+ Right contents -> return $!
+ footnoteRef (T.pack (show num)) lab contents
+ Nothing -> mzero
-addFootnoteList :: (Monad m, Typeable m, Typeable bl, HasFootnote il bl,
+addFootnoteList :: forall m il bl.
+ (Monad m, Typeable m, Typeable bl, HasFootnote il bl,
IsBlock il bl) => BlockParser m il bl bl
addFootnoteList = do
rm <- referenceMap <$> getState
let keys = M.keys . unReferenceMap $ rm
- let getNote key = lookupReference key rm
+ let getNote key = lookupReference key rm :: Maybe (FootnoteDef bl m)
let notes = sort $ mapMaybe getNote keys
- let renderNote (FootnoteDef num lab mkContents) = do
- res <- lift $ mkContents rm
+ -- Render each note's contents exactly once, in dependency order
+ -- (so that notes referenced by other notes are rendered, and
+ -- memoized, first), caching the results in the reference map.
+ -- Since final parsers run before inline parsing of the main
+ -- document, every footnote reference outside of a note body will
+ -- find the memoized contents. Cyclic references are cut off by
+ -- the FootnoteInProgress marker (see pFootnoteRef).
+ let sccs = stronglyConnComp
+ [ (def, normalizeLabel lab, map normalizeLabel refs)
+ | def@(FootnoteDef _ lab refs _) <- notes ]
+ let renderNote rm' (FootnoteDef num lab _ mkContents) = do
+ res <- lift $ mkContents (insertReference lab FootnoteInProgress rm')
case res of
Left err -> mkPT (\_ -> return (Empty (return (Error err))))
- Right contents -> return $! footnote num lab contents
+ Right contents -> return $!
+ insertReference lab (FootnoteRendered num lab contents) rm'
+ rm' <- foldM renderNote rm (concatMap flattenSCC sccs)
+ updateState $ \s -> s{ referenceMap = rm' }
+ let renderedNote (FootnoteDef num lab _ _) = do
+ FootnoteRendered _ _ contents <- lookupReference lab rm'
+ return $! footnote num lab contents
if null notes
then return mempty
- else footnoteList <$> mapM renderNote notes
+ else return $! footnoteList $ mapMaybe renderedNote notes
+
+-- Must match the label normalization performed by insertReference
+-- and lookupReference (see Commonmark.ReferenceMap).
+normalizeLabel :: Text -> Text
+normalizeLabel = T.toCaseFold . T.unwords . T.words
class IsBlock il bl => HasFootnote il bl | il -> bl where
footnote :: Int -> Text -> bl -> bl
diff --git a/src/Commonmark/Extensions/Math.hs b/src/Commonmark/Extensions/Math.hs
--- a/src/Commonmark/Extensions/Math.hs
+++ b/src/Commonmark/Extensions/Math.hs
@@ -41,10 +41,10 @@
parseMath = try $ do
symbol '$'
display <- (True <$ symbol '$') <|> (False <$ notFollowedBy whitespace)
- contents <- try $ untokenize <$> pDollarsMath 0
+ contents <- try $ untokenize <$> pDollarsMath display 0
let isWs c = c == ' ' || c == '\t' || c == '\r' || c == '\n'
if display
- then displayMath contents <$ symbol '$'
+ then pure $ displayMath contents
else do
-- don't allow empty inline math
guard $ not $ T.null contents
@@ -55,18 +55,25 @@
notFollowedBy $ satisfyWord startsWithDigit
pure $ inlineMath contents
--- Int is number of embedded groupings
-pDollarsMath :: Monad m => Int -> InlineParser m [Tok]
-pDollarsMath n = do
+-- Bool is display math (closed by $$); Int is number of embedded groupings.
+-- Consumes the closing $ (or $$) but does not include it in the result.
+pDollarsMath :: Monad m => Bool -> Int -> InlineParser m [Tok]
+pDollarsMath display n = do
guard (n <= 1000) -- bail on pathological inputs
tk@(Tok toktype _ _) <- anyTok
case toktype of
Symbol '$'
- | n == 0 -> return []
+ | n == 0 ->
+ if display
+ -- an unbraced single $ is ordinary content in
+ -- display math; only $$ closes it
+ then ([] <$ symbol '$')
+ <|> ((tk :) <$> pDollarsMath display n)
+ else return []
Symbol '\\' -> do
tk' <- anyTok
- (tk :) . (tk' :) <$> pDollarsMath n
- Symbol '{' -> (tk :) <$> pDollarsMath (n+1)
- Symbol '}' | n > 0 -> (tk :) <$> pDollarsMath (n-1)
+ (tk :) . (tk' :) <$> pDollarsMath display n
+ Symbol '{' -> (tk :) <$> pDollarsMath display (n+1)
+ Symbol '}' | n > 0 -> (tk :) <$> pDollarsMath display (n-1)
| otherwise -> mzero
- _ -> (tk :) <$> pDollarsMath n
+ _ -> (tk :) <$> pDollarsMath display n
diff --git a/src/Commonmark/Extensions/TaskList.hs b/src/Commonmark/Extensions/TaskList.hs
--- a/src/Commonmark/Extensions/TaskList.hs
+++ b/src/Commonmark/Extensions/TaskList.hs
@@ -78,7 +78,11 @@
blockBlanks' <- case childrenData of
c:_ | listItemBlanksAtEnd c -> do
curline <- sourceLine <$> getPosition
- return $! curline - 1 : blockBlanks cdata
+ return $! case blockBlanks cdata of
+ lb:b | lb == curline - 1 ->
+ lb:b
+ b ->
+ curline - 1 : b
_ -> return $! blockBlanks cdata
let ldata' = toDyn (ListData lt ls)
-- need to transform paragraphs on tight lists
@@ -165,16 +169,17 @@
let lidata = fromDyn (blockData cdata)
(ListItemData (BulletList '*') False
0 False False)
- let blanks = removeConsecutive $ sort $
- concat $ blockBlanks cdata :
+ let allblanks = reverse . sort . concat $ blockBlanks cdata :
map (blockBlanks . rootLabel)
- (filter ((== "List") . blockType .
- blockSpec . rootLabel) children)
+ (filter ((\t -> t == "List" ||
+ t == "TaskList") .
+ blockType . blockSpec . rootLabel)
+ children)
curline <- sourceLine <$> getPosition
- let blanksAtEnd = case blanks of
+ let blanksAtEnd = case allblanks of
(l:_) -> l >= curline - 1
_ -> False
- let blanksInside = case length blanks of
+ let blanksInside = case length (removeConsecutive allblanks) of
n | n > 1 -> True
| n == 1 -> not blanksAtEnd
| otherwise -> False
diff --git a/test/autolinks.md b/test/autolinks.md
--- a/test/autolinks.md
+++ b/test/autolinks.md
@@ -23,6 +23,20 @@
````````````````````````````````
+An autolink preceded by any other character is not recognized:
+
+```````````````````````````````` example
+a-www.foo.com
+
+foo(www.foo.com)
+
+see:http://example.com
+.
+
+````````````````````````````````
+
After a [valid domain], zero or more non-space non-`<` characters may follow:
```````````````````````````````` example
@@ -88,6 +102,25 @@
.
+````````````````````````````````
+
+The same applies to square brackets: balanced pairs may be included,
+but an unbalanced `]` ends the autolink (and open parentheses don't
+affect this):
+
+```````````````````````````````` example
+www.example.com/a[b]c
+
+www.example.com/a]b
+
+www.example.com/a(b]c
+
+[www.example.com/a]
+.
+
````````````````````````````````
+
+A word made of Roman-numeral letters is a list marker only if the
+*whole* word is a valid Roman numeral; a valid prefix with leftover
+letters (`vv`) or a malformed subtractive form (`il`) is not:
+
+```````````````````````````````` example
+vv. not a list
+
+il. not a list
+
+iv. a list
+.
+
vv. not a list
+
il. not a list
+
+
a list
+
+````````````````````````````````
diff --git a/test/math.md b/test/math.md
--- a/test/math.md
+++ b/test/math.md
@@ -62,6 +62,15 @@
````````````````````````````````
+Display math may contain an unbraced single `$`;
+only `$$` closes it:
+
+```````````````````````````````` example
+$$a $ b$$
+.
+
\[a $ b\]
+````````````````````````````````
+
To avoid treating currency signs as math delimiters,
one may occasionally have to backslash-escape them:
diff --git a/test/task_lists.md b/test/task_lists.md
--- a/test/task_lists.md
+++ b/test/task_lists.md
@@ -101,3 +101,42 @@
b
````````````````````````````````
+
+Tight/loose classification should match plain lists. Blank lines
+after a list don't make it loose:
+
+```````````````````````````````` example
+- [ ] a
+- [ ] b
+
+
+x
+.
+
+
a
+
b
+
+
x
+````````````````````````````````
+
+A blank line after a nested task list makes the outer list loose,
+just as with plain lists:
+
+```````````````````````````````` example
+- [ ] a
+ - [ ] b
+
+- [ ] c
+.
+