commonmark 0.3 → 0.3.0.1
raw patch · 8 files changed
+254/−38 lines, 8 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ Commonmark.Inlines: getPrecedingTokType :: forall (m :: Type -> Type). Monad m => InlineParser m (Maybe TokType)
Files
- changelog.md +32/−0
- commonmark.cabal +3/−2
- src/Commonmark/Blocks.hs +2/−2
- src/Commonmark/Html.hs +25/−11
- src/Commonmark/Inlines.hs +83/−19
- src/Commonmark/Tokens.hs +7/−3
- test/regression.md +9/−0
- test/test-commonmark.hs +93/−1
changelog.md view
@@ -1,5 +1,37 @@ # Changelog for commonmark ++## 0.3.0.1++ * Add test for cmark#383 case that motivated f47801c.++ * Add pathological tests from commonmark.js to the test suite.+ Ports the 31 pathological cases from commonmark.js's test/test.js+ (sizes 1000 and 10000) as a tasty test group with a 5-second+ per-test timeout, so nonlinear parsing behavior shows up as a+ test failure.++ * Fix `stackBottoms` lookup key in `processEm`, restoring linear+ behavior. (Regression since f47801c.)++ * Track bracket balance incrementally in `processBs`. Avoids quadratic+ performance in pathological cases.++ * Replace U+0000 with U+FFFD in tokenize, in accordance with the+ commonmark spec.++ * Html: don't merge adjacent text nodes in (<>); fixes quadratic rendering.++ * Disallow ASCII control characters in link destinations, per the+ commonmark spec.++ * Speed up `escapeURI`.++ * Prune `backtickSpans` state when no closer is found. Avoids+ quadratic performance in pathological cases.++ * Autolink: implement GFM preceding-character restriction.+ ## 0.3 * Applicative instances of IsBlock, IsInline etc. (Ashley Yakeley).
commonmark.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: commonmark-version: 0.3+version: 0.3.0.1 synopsis: Pure Haskell commonmark parser. description: This library provides the core data types and functions@@ -40,9 +40,10 @@ license-file: LICENSE build-type: Simple -extra-source-files:+extra-doc-files: changelog.md README.md+extra-source-files: test/spec.txt test/regression.md
src/Commonmark/Blocks.hs view
@@ -97,8 +97,8 @@ , nextAttributes = mempty } "source" (length ts `seq` ts)- -- we evaluate length ts to make sure the list is- -- fully evaluated; this helps performance. note that+ -- we evaluate length ts to make sure the list spine is+ -- evaluated; this helps performance. note that -- we can't use deepseq because there's no instance for SourcePos. processLines :: (Monad m, IsBlock il bl)
src/Commonmark/Html.hs view
@@ -27,7 +27,6 @@ import Data.Text.Encoding (encodeUtf8) import qualified Data.ByteString.Char8 as B import qualified Data.Set as Set-import Text.Printf (printf) import Unicode.Char (ord, isAlphaNum, isAscii) import Unicode.Char.General.Compat (isSpace) import Data.Maybe (fromMaybe)@@ -49,9 +48,14 @@ instance Semigroup (Html a) where x <> HtmlNull = x HtmlNull <> x = x- HtmlText t1 <> HtmlText t2 = HtmlText (t1 <> t2)- HtmlRaw t1 <> HtmlRaw t2 = HtmlRaw (t1 <> t2) x <> y = HtmlConcat x y+ -- Note: adjacent HtmlText (or HtmlRaw) nodes must NOT be merged+ -- here with Text (<>): a paragraph is mconcat'ed from one node per+ -- word, and pairwise Text appends would copy the growing text at+ -- each step, making rendering quadratic in the paragraph size.+ -- renderHtml goes through a Builder, and escapeHtml is+ -- character-local, so keeping the nodes separate produces+ -- identical output in linear time. instance Monoid (Html a) where mempty = HtmlNull@@ -456,14 +460,24 @@ escapeHtmlChar c = singleton c escapeURI :: Text -> Text-escapeURI = mconcat . map escapeURIChar . B.unpack . encodeUtf8+escapeURI t+ | B.all isAllowedURIChar bs = t+ | otherwise = TL.toStrict $ toLazyText $+ B.foldr (\c b -> escapeURIChar c <> b) mempty bs+ where bs = encodeUtf8 t -escapeURIChar :: Char -> Text+isAllowedURIChar :: Char -> Bool+isAllowedURIChar c =+ (isAscii c && isAlphaNum c) ||+ c `elem` ("%/?:@-._~&#!$'()*+,;=" :: [Char])++-- Note: c is a byte of the UTF-8 encoding, so ord c <= 255.+escapeURIChar :: Char -> Builder escapeURIChar c- | isEscapable c = T.singleton '%' <> T.pack (printf "%02X" (ord c))- | otherwise = T.singleton c- where isEscapable d = not (isAscii d && isAlphaNum d)- && d `notElem` ['%','/','?',':','@','-','.','_','~','&',- '#','!','$','\'','(',')','*','+',',',- ';','=']+ | isAllowedURIChar c = singleton c+ | otherwise = singleton '%' <> singleton (hexDig hi) <> singleton (hexDig lo)+ where+ (hi, lo) = ord c `divMod` 16+ hexDig i | i < 10 = toEnum (i + fromEnum '0')+ | otherwise = toEnum (i - 10 + fromEnum 'A')
src/Commonmark/Inlines.hs view
@@ -13,6 +13,7 @@ , IPState , InlineParser , getReferenceMap+ , getPrecedingTokType , FormattingSpec(..) , defaultFormattingSpecs , BracketedSpec(..)@@ -204,8 +205,13 @@ precedingTokTypeMap = {-# SCC precedingTokTypeMap #-}fst $! foldl' go (mempty, LineEnd) ts go (!m, !prevTy) (Tok !ty !pos _) = case ty of- Symbol c | isDelimChar c -> (M.insert pos prevTy m, ty)- _ -> (m, ty)+ Symbol c | isDelimChar c -> (M.insert pos prevTy m, ty)+ -- record word tokens preceded by a symbol, so that extensions+ -- (e.g. autolinks) can check what precedes them; a word token+ -- not in the map is preceded by whitespace or begins the input+ -- (adjacent word characters are merged by the tokenizer):+ WordChars | Symbol _ <- prevTy -> (M.insert pos prevTy m, ty)+ _ -> (m, ty) data Chunk a = Chunk { chunkType :: ChunkType a@@ -484,6 +490,16 @@ getReferenceMap :: Monad m => InlineParser m ReferenceMap getReferenceMap = ipReferenceMap <$> getState +-- | Type of the token immediately preceding the current position,+-- if recorded. Preceding token types are recorded for positions of+-- delimiter characters, and for word tokens preceded by a symbol.+-- 'Nothing' at the start of a word token means it begins the input+-- or is preceded by whitespace.+getPrecedingTokType :: Monad m => InlineParser m (Maybe TokType)+getPrecedingTokType = do+ pos <- getPosition+ M.lookup pos . precedingTokTypes <$> getState+ pBacktickSpan :: Monad m => Tok -> InlineParser m (Either [Tok] [Tok]) pBacktickSpan tok = do@@ -498,7 +514,13 @@ updateState $ \st -> st{ backtickSpans = IntMap.insert numticks ps (backtickSpans st) } return $ Right codetoks- _ -> return $ Left ts+ Just [] -> do+ -- no closer ahead: remove the exhausted entry so that later+ -- spans of this length don't rescan the stale positions+ updateState $ \st ->+ st{ backtickSpans = IntMap.delete numticks (backtickSpans st) }+ return $ Left ts+ Nothing -> return $ Left ts normalizeCodeSpan :: Text -> Text normalizeCodeSpan = removeSurroundingSpace . T.map nltosp@@ -566,6 +588,14 @@ , refmap :: ReferenceMap , stackBottoms :: M.Map Text SourcePos , absoluteBottom :: SourcePos+ , middleBalance :: !Int+ -- ^ Bracket balance of the chunks strictly between the two+ -- cursors. Maintained incrementally by processBs (unused in+ -- processEm) so that checking for balanced brackets is O(1)+ -- instead of a scan over the chunks between the cursors.+ , middleHasBracket :: !Bool+ -- ^ Whether any chunk strictly between the two cursors is a+ -- bracket delimiter. Maintained incrementally by processBs. } @@ -581,7 +611,9 @@ , rightCursor = startcursor , refmap = emptyReferenceMap , stackBottoms = mempty- , absoluteBottom = chunkPos z }+ , absoluteBottom = chunkPos z+ , middleBalance = 0+ , middleHasBracket = False } {- for debugging: prettyCursors :: (IsInline a) => Cursor (Chunk a) -> Cursor (Chunk a) -> String@@ -673,7 +705,8 @@ } | Just (chunkPos chunk) <=- M.lookup (T.pack (c: show (length ts `mod` 3))) bottoms ->+ M.lookup (T.pack ([c, if canopen then '1' else '0']+ ++ show (length ts `mod` 3))) bottoms -> processEm st{ leftCursor = right , rightCursor = moveRight right@@ -709,9 +742,11 @@ bracketChunkToNumber (Chunk Delim{ delimType = '[' } _ _) = 1 bracketChunkToNumber (Chunk Delim{ delimType = ']' } _ _) = -1 bracketChunkToNumber _ = 0-bracketMatchedCount :: [Chunk a] -> Int-bracketMatchedCount chunksinside = sum $ map bracketChunkToNumber chunksinside +isBracketChunk :: Chunk a -> Bool+isBracketChunk (Chunk Delim{ delimType = c } _ _) = c == '[' || c == ']'+isBracketChunk _ = False+ -- | Process square brackets: links, images, and the span extension. -- -- DState tracks the current position and backtracking limits.@@ -743,6 +778,8 @@ , refmap = rm , stackBottoms = bottoms , absoluteBottom = chunkPos z+ , middleBalance = 0+ , middleHasBracket = False } data Cursor a = Cursor@@ -787,6 +824,8 @@ st{ leftCursor = moveRight right , rightCursor = moveRight right , absoluteBottom = chunkPos chunk+ , middleBalance = 0+ , middleHasBracket = False } (Just chunk, Just chunk')@@ -795,16 +834,15 @@ st { leftCursor = moveRight right , rightCursor = moveRight right , absoluteBottom = chunkPos chunk'+ , middleBalance = 0+ , middleHasBracket = False } (Just opener@(Chunk Delim{ delimType = '[' } _ _), Just closer@(Chunk Delim{ delimType = ']'} closePos _)) -> let chunksinside = takeWhile (\ch -> chunkPos ch /= closePos) (afters left)- isBracket (Chunk Delim{ delimType = c' } _ _) =- c' == '[' || c' == ']'- isBracket _ = False- key = if any isBracket chunksinside+ key = if middleHasBracket st then "" else case untokenize (concatMap chunkToks chunksinside) of@@ -827,7 +865,7 @@ suffixPos = incSourceColumn closePos 1 - in case (bracketMatchedCount chunksinside, parse+ in case (middleBalance st, parse (withRaw (do setPosition suffixPos (spec, constructor) <- choice $@@ -840,7 +878,10 @@ processBs bracketedSpecs st{ leftCursor = moveLeft (leftCursor st) , rightCursor = fixSingleQuote $- moveRight (rightCursor st) }+ moveRight (rightCursor st)+ -- the middle absorbs the opener and closer,+ -- which cancel out (+1 - 1):+ , middleHasBracket = True } (0, Right ((spec, constructor, newpos), desttoks)) -> let left' = case bracketedPrefix spec of Just _ -> moveLeft left@@ -880,7 +921,9 @@ st' = case addMissing afterchunks of [] -> st{ rightCursor = Cursor Nothing- (eltchunk : befores left') [] }+ (eltchunk : befores left') []+ , middleBalance = 0+ , middleHasBracket = False } (y:ys) -> let lbs = befores left' in st{@@ -888,6 +931,8 @@ Cursor (Just eltchunk) lbs (y:ys) , rightCursor = fixSingleQuote $ Cursor (Just y) (eltchunk:lbs) ys+ , middleBalance = 0+ , middleHasBracket = False , stackBottoms = -- if a link, we need to ensure that -- nothing matches as link containing it@@ -909,19 +954,36 @@ -- inlines, and a close bracket ]. _ -> processBs bracketedSpecs- st{ leftCursor = moveLeft left }+ st{ leftCursor = moveLeft left+ -- the middle absorbs the opener:+ , middleBalance = middleBalance st ++ bracketChunkToNumber opener+ , middleHasBracket = True } - (_, Just (Chunk Delim{ delimType = ']' } _ _))- -> processBs bracketedSpecs st{ leftCursor = moveLeft left }+ (Just lchunk, Just (Chunk Delim{ delimType = ']' } _ _))+ -> processBs bracketedSpecs+ st{ leftCursor = moveLeft left+ -- the middle absorbs the old left center:+ , middleBalance = middleBalance st ++ bracketChunkToNumber lchunk+ , middleHasBracket = middleHasBracket st ||+ isBracketChunk lchunk } (Just _, Just (Chunk Delim{ delimType = '[' } _ _)) -> processBs bracketedSpecs st{ leftCursor = right- , rightCursor = moveRight right }+ , rightCursor = moveRight right+ , middleBalance = 0+ , middleHasBracket = False } (_, _) -> processBs bracketedSpecs- st{ rightCursor = moveRight right }+ st{ rightCursor = moveRight right+ -- the middle absorbs the old right center:+ , middleBalance = middleBalance st ++ maybe 0 bracketChunkToNumber (center right)+ , middleHasBracket = middleHasBracket st ||+ maybe False isBracketChunk (center right) } -- This just changes a single quote Delim that occurs@@ -977,6 +1039,8 @@ satisfyTok (\case Tok (Symbol '\\') _ _ -> True Tok (Symbol ')') _ _ -> numparens >= 1+ -- spec: no ASCII control characters+ Tok (Symbol c) _ _ -> c >= ' ' && c /= '\x7F' Tok Spaces _ _ -> False Tok LineEnd _ _ -> False _ -> True)
src/Commonmark/Tokens.hs view
@@ -33,10 +33,13 @@ deriving (Show, Eq, Ord, Data, Typeable) -- | Convert a 'Text' into a list of 'Tok'. The first parameter--- species the source name.+-- species the source name. The text is normalized to NFC, and+-- U+0000 is replaced with U+FFFD, as required by the spec+-- (section 2.3, Insecure characters). tokenize :: String -> Text -> [Tok] tokenize name =- {-# SCC tokenize #-} go (initialPos name) . T.groupBy f . normalize NFC+ {-# SCC tokenize #-} go (initialPos name) . T.groupBy f .+ T.replace "\x0" "\xFFFD" . normalize NFC where -- We group \r\n, consecutive spaces, and consecutive alphanums; -- everything else gets in a token by itself.@@ -70,7 +73,8 @@ go (incSourceColumn pos 1) ts -- | Reverses 'tokenize'. @untokenize . tokenize@ should be--- the identity.+-- the identity on text that is NFC-normalized and does not+-- contain U+0000. untokenize :: [Tok] -> Text untokenize = {-# SCC untokenize #-} mconcat . map tokContents
test/regression.md view
@@ -507,3 +507,12 @@ <a href="https://example.com" title="test">a</a> <a href="https://example.com" title="test">a</a></p> ````````````````````````````````++cmark#383++```````````````````````````````` example+*****Hello*world****+.+<p>**<em><strong>Hello<em>world</em></strong></em></p>+````````````````````````````````+
test/test-commonmark.hs view
@@ -34,6 +34,7 @@ ] defaultMain $ testGroup "Tests" (testProperty "tokenize/untokenize roundtrip" tokenize_roundtrip+ : pathologicalTests defaultParser : toSpecTest defaultParser SpecTest { section = "Issue #24 (eof after HTML block)"@@ -50,6 +51,14 @@ , end_line = 2 , start_line = 2 , html = "<!-- a -->" }+ : toSpecTest defaultParser+ SpecTest+ { section = "Control character in link destination"+ , example = 1+ , markdown = "[foo](de\x01st)\n"+ , end_line = 1+ , start_line = 1+ , html = "<p>[foo](de\x01st)</p>\n" } : tests) getSpecTestTree :: FilePath@@ -99,6 +108,89 @@ (parser (tokenize "" (markdown st)) :: Either ParseError (Html ())) +-- Pathological tests, ported from commonmark.js's test/test.js.+-- Each case must produce the expected output within the timeout;+-- a timeout indicates nonlinear (typically quadratic) behavior.+pathologicalTests :: ([Tok] -> Either ParseError (Html ()))+ -> TestTree+pathologicalTests parser =+ localOption (mkTimeout (5 * 1000000)) $ -- 5 seconds per case+ testGroup "Pathological cases" $+ map toPathTest pathologicalCases+ where+ toPathTest (name, inp, expected) =+ testCase name $+ (normalizeHtml . TL.toStrict . renderHtml . fromRight mempty)+ (parser (tokenize "" inp))+ @?= normalizeHtml expected++pathologicalCases :: [(String, Text, Text)]+pathologicalCases =+ [ ("U+0000 in input",+ "abc\0xyz\0\n",+ "<p>abc\65533\&xyz\65533</p>\n")+ , ("alternate line endings",+ "- a\n- b\r- c\r\n- d",+ "<ul>\n<li>a</li>\n<li>b</li>\n<li>c</li>\n<li>d</li>\n</ul>\n")+ , ("paragraph of 200000 words",+ rep 200000 "lorem ",+ "<p>" <> rep 199999 "lorem " <> "lorem</p>\n")+ ] +++ concatMap forSize [1000, 10000] +++ map backslashTitle [10, 100, 1000]+ where+ rep = T.replicate+ forSize :: Int -> [(String, Text, Text)]+ forSize x =+ let sx = show x+ n = rep x+ in+ [ ("nested strong emph " <> sx <> " deep",+ n "*a **a " <> "b" <> n " a** a*",+ "<p>" <> n "<em>a <strong>a " <> "b" <>+ n " a</strong> a</em>" <> "</p>\n")+ , (sx <> " emph closers with no openers",+ n "a_ ",+ "<p>" <> rep (x - 1) "a_ " <> "a_</p>\n")+ , (sx <> " emph openers with no closers",+ n "_a ",+ "<p>" <> rep (x - 1) "_a " <> "_a</p>\n")+ , (sx <> " openers and closers multiple of 3",+ "a**b" <> n "c* ",+ "<p>a**b" <> rep (x - 1) "c* " <> "c*</p>\n")+ , (sx <> " #172",+ n "*_* _ ",+ "<p>" <> rep (x - 1) "<em>_</em> _ " <> "<em>_</em> _</p>\n")+ , (sx <> " link closers with no openers",+ n "a] ",+ "<p>" <> rep (x - 1) "a] " <> "a]</p>\n")+ , (sx <> " link openers with no closers",+ n "[a ",+ "<p>" <> rep (x - 1) "[a " <> "[a</p>\n")+ , (sx <> " link openers and emph closers",+ n "[ a_ ",+ "<p>" <> rep (x - 1) "[ a_ " <> "[ a_</p>\n")+ , (sx <> " mismatched openers and closers",+ n "*a_ ",+ "<p>" <> rep (x - 1) "*a_ " <> "*a_</p>\n")+ , (sx <> " pattern [ (](",+ n "[ (](",+ "<p>" <> n "[ (](" <> "</p>\n")+ , ("nested brackets " <> sx <> " deep",+ n "[" <> "a" <> n "]",+ "<p>" <> n "[" <> "a" <> n "]" <> "</p>\n")+ , ("nested block quote " <> sx <> " deep",+ n "> " <> "a\n",+ n "<blockquote>\n" <> "<p>a</p>\n" <> n "</blockquote>\n")+ , ("[\\\\... " <> sx <> " deep",+ "[" <> n "\\" <> "\n",+ "<p>[" <> rep (x `div` 2) "\\" <> "</p>\n")+ ]+ backslashTitle x =+ (show x <> " backslashes in unclosed link title",+ "[test](\\url \"" <> rep x "\\" <> "\n",+ "<p>[test](\\url "" <> rep (x `div` 2) "\\" <> "</p>\n")+ normalizeHtml :: Text -> Text normalizeHtml = T.replace "\n</li>" "</li>" . T.replace "<li>\n" "<li>"@@ -109,7 +201,7 @@ tokenize_roundtrip :: String -> Bool tokenize_roundtrip s = untokenize (tokenize "source" t) == t- where t = normalize NFC $ T.pack s+ where t = T.replace "\0" "\xFFFD" . normalize NFC $ T.pack s --- parser for spec test cases