commonmark 0.1.1.4 → 0.2

raw patch · 10 files changed

+302/−55 lines, 10 filesdep +tasty-benchdep +unicode-transformsdep −QuickCheckdep −criterionPVP ok

version bump matches the API change (PVP)

Dependencies added: tasty-bench, unicode-transforms

Dependencies removed: QuickCheck, criterion

API changes (from Hackage documentation)

Files

• benchmark/benchmark.hs +2/−2
• changelog.md +12/−0
• commonmark.cabal +11/−7
• src/Commonmark/Blocks.hs +24/−23
• src/Commonmark/Html.hs +230/−9
• src/Commonmark/Inlines.hs +11/−8
• src/Commonmark/ReferenceMap.hs +6/−2
• src/Commonmark/TokParsers.hs +1/−1
• src/Commonmark/Tokens.hs +3/−2
• test/test-commonmark.hs +2/−1

@@ -1,7 +1,7 @@ {-# LANGUAGE CPP                 #-} {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-}-import Criterion.Main+import Test.Tasty.Bench import Data.Text (Text) import Data.Functor.Identity  -- base >= 4.8 import Commonmark@@ -14,7 +14,7 @@ main :: IO () main = do   sample <- T.replicate 10 <$> TIO.readFile "benchmark/sample.md"-  defaultMainWith defaultConfig+  defaultMain     [ bgroup "tokenize"       [ benchTokenize ("sample.md", sample) ]     , bgroup "parse sample.md"

@@ -1,5 +1,17 @@ # Changelog for commonmark +## 0.2++* Commonmark.Inlines: export LinkInfo(..) [API change].+* Commonmark.Inlines: export pLink [API chage].+* Comonmark.ReferenceMap: Add linkPos field to LinkInfo [API change].+* Commonmark.Tokens: normalize unicode to NFC before tokenizing (#57).+  Normalization might affect detection of flankingness, recognition+  of reference links, etc.+* Commonmark.Html:  add data-prefix to non-HTML5 attributes, as pandoc does.+* Remove unnecessary build-depends.+* Use lightweight tasty-bench instead of criterion for benchmarks.+ ## 0.1.1.4  * Fix build with GHC 9.0.1 (Simon Jakobi, #72).

@@ -1,6 +1,6 @@ cabal-version:  2.2 name:           commonmark-version:        0.1.1.4+version:        0.2 synopsis:       Pure Haskell commonmark parser. description:    This library provides the core data types and functions@@ -35,7 +35,7 @@ stability:      experimental author:         John MacFarlane maintainer:     jgm@berkeley.edu-copyright:      2018-2020 John MacFarlane+copyright:      2018-2021 John MacFarlane license:        BSD-3-Clause license-file:   LICENSE build-type:     Simple@@ -60,6 +60,7 @@     , containers     , transformers     , parsec+    , unicode-transforms   exposed-modules:       Commonmark       Commonmark.Parser@@ -74,6 +75,8 @@       Commonmark.SourceMap       Commonmark.Tag       Commonmark.Entity+  if impl(ghc >= 8.10)+    ghc-options:      -Wunused-packages   if impl(ghc >= 8.8)     ghc-options:  -fwrite-ide-info -hiedir=.hie   ghc-options: -Wall -fno-warn-unused-do-bind -funbox-small-strict-fields@@ -86,14 +89,16 @@   hs-source-dirs:       test   ghc-options: -threaded -rtsopts -with-rtsopts=-K40K+  if impl(ghc >= 8.10)+    ghc-options:      -Wunused-packages   build-depends:       base >= 4.9 && <5     , commonmark     , text+    , unicode-transforms     , tasty     , tasty-quickcheck     , tasty-hunit-    , QuickCheck     , parsec   default-language: Haskell2010 @@ -105,9 +110,8 @@        commonmark      , base >= 4.9 && < 5      , text-     , transformers-     , containers-     , bytestring-     , criterion >= 1.0 && < 1.6+     , tasty-bench   ghc-options: -threaded -rtsopts -with-rtsopts=-K10K+  if impl(ghc >= 8.10)+    ghc-options:      -Wunused-packages   default-language: Haskell2010

@@ -108,7 +108,7 @@              -> BlockParser m il bl bl processLines specs finalParsers = {-# SCC processLines #-} do   let go = eof <|> (processLine specs >> go) in go-  tree <- (nodeStack <$> getState) >>= collapseNodeStack+  tree <- getState >>= collapseNodeStack . nodeStack   updateState $ \st -> st{ nodeStack = [reverseSubforests tree] }   endContent <- mconcat <$> sequence finalParsers   tree':_ <- nodeStack <$> getState@@ -237,7 +237,7 @@                 else (matched, new:unmatched))        <|> (matched, nd:unmatched) <$ updateState (\st -> st{                                          blockMatched = False })-     else return $! (matched, nd:unmatched)+     else return (matched, nd:unmatched)   {-@@ -404,7 +404,7 @@      go [] = []      go ((!startpos1, !endpos1):(!startpos2, !endpos2):rest)        | endpos1 == startpos2 = go ((startpos1, endpos2):rest)-     go (!x:xs) = x : go xs+     go (x:xs) = x : go xs  -- Add a new node to the block stack.  If current tip can contain -- it, add it there; otherwise, close the tip and repeat til we get@@ -475,10 +475,10 @@          let linkdefs = fromDyn (blockData (rootLabel node))                   undefined :: [((SourceRange, Text), LinkInfo)]          return $! mconcat $ map (\((range, lab), linkinfo) ->-            (ranged range+            ranged range               (addAttributes (linkAttributes linkinfo)                 (referenceLinkDefinition lab (linkDestination linkinfo,-                                            linkTitle linkinfo))))) linkdefs+                                            linkTitle linkinfo)))) linkdefs      , blockFinalize       = defaultFinalizer      } @@ -495,7 +495,7 @@                         many1 (linkReferenceDef (choice $ attributeParsers st)))                   <*> getInput) st "" (getBlockText node)   case res of-        Left _ -> return $! (Just node, Nothing)+        Left _ -> return (Just node, Nothing)         Right (linkdefs, toks') -> do           mapM_             (\((_,lab),linkinfo) ->@@ -523,7 +523,7 @@                    , blockData = toDyn linkdefs                    , blockSpec = refLinkDefSpec                  }}-          return $! (node', Just refnode)+          return (node', Just refnode)  attributeSpec :: (Monad m, IsBlock il bl)               => BlockSpec m il bl@@ -556,7 +556,7 @@          lookAhead (void lineEnd <|> eof)          let oldattrs = fromDyn (blockData (rootLabel n)) mempty :: Attributes          let attrs' = oldattrs <> attrs-         return $! (pos, n{ rootLabel = (rootLabel n){+         return  (pos, n{ rootLabel = (rootLabel n){                           blockData = toDyn attrs' }})      , blockConstructor    = \_ -> return $! mempty      , blockFinalize       = \node parent -> do@@ -617,6 +617,7 @@   guard $ not $ T.all isSpace lab   symbol ':'   optional whitespace+  linkpos <- getPosition   dest <- pLinkDestination   (title, attrs) <- option (mempty, mempty) $ try $ do              tit <- option mempty $ try (whitespace *> pLinkTitle)@@ -624,13 +625,14 @@              as <- option mempty attrParser              skipWhile (hasType Spaces)              lookAhead (void lineEnd <|> eof)-             return $! (tit, as)+             return (tit, as)   endpos <- getPosition   void lineEnd <|> eof-  return $! ((SourceRange [(startpos, endpos)], lab),+  return ((SourceRange [(startpos, endpos)], lab),                 LinkInfo{ linkDestination = unEntity dest                         , linkTitle = unEntity title-                        , linkAttributes = attrs })+                        , linkAttributes = attrs+                        , linkPos = Just linkpos })  atxHeadingSpec :: (Monad m, IsBlock il bl)             => BlockSpec m il bl@@ -677,7 +679,7 @@          let oldAttr = blockAttributes cdata          let toks = getBlockText node          (newtoks, attr) <- parseFinalAttributes True toks-                        <|> (return $! (toks, mempty))+                        <|> (return (toks, mempty))          defaultFinalizer (Node cdata{ blockAttributes = oldAttr <> attr                                      , blockLines = [newtoks] }                                 children) parent@@ -731,7 +733,7 @@          let oldAttr = blockAttributes cdata          let toks = getBlockText node          (newtoks, attr) <- parseFinalAttributes True toks-                        <|> (return $! (toks, mempty))+                        <|> (return (toks, mempty))          defaultFinalizer (Node cdata{ blockAttributes = oldAttr <> attr                                      , blockLines = [newtoks] }                                 children) parent@@ -751,7 +753,7 @@             <*> option [] pAttr') st "heading contents" ts   case res of     Left _         -> mzero-    Right (xs, ys) -> return $! (xs, ys)+    Right (xs, ys) -> return (xs, ys)  blockQuoteSpec :: (Monad m, IsBlock il bl) => BlockSpec m il bl blockQuoteSpec = BlockSpec@@ -773,9 +775,8 @@              pos <- getPosition              _ <- symbol '>'              _ <- gobbleUpToSpaces 1-             return $! (pos, n)-     , blockConstructor    = \node ->-           (blockQuote . mconcat) <$> renderChildren node+             return (pos, n)+     , blockConstructor    = fmap (blockQuote . mconcat) . renderChildren      , blockFinalize       = defaultFinalizer      } @@ -829,7 +830,7 @@                      not (null children)              pos <- getPosition              gobbleSpaces (listItemIndent lidata) <|> 0 <$ lookAhead blankLine-             return $! (pos, node)+             return (pos, node)      , blockConstructor    = fmap mconcat . renderChildren      , blockFinalize       = \(Node cdata children) parent -> do           let lidata = fromDyn (blockData cdata)@@ -866,7 +867,7 @@   numspaces <- try (gobbleUpToSpaces 4 <* notFollowedBy whitespace)            <|> gobbleSpaces 1            <|> 1 <$ lookAhead lineEnd-  return $! (pos, ListItemData{+  return (pos, ListItemData{            listItemType = ty           , listItemIndent = (aftercol - beforecol) + numspaces           , listItemBlanksInside = False@@ -978,7 +979,7 @@              void (gobbleSpaces 4)                <|> try (skipWhile (hasType Spaces) <* lookAhead lineEnd)              pos <- getPosition-             return $! (pos, node)+             return (pos, node)       , blockConstructor    = \node ->              return $! codeBlock mempty (untokenize (getBlockText node))@@ -1020,7 +1021,7 @@               let infotoks = tokenize "info string" info              (content, attrs) <- parseFinalAttributes False infotoks-                                  <|> (return $! (infotoks, mempty))+                                  <|> (return (infotoks, mempty))              addNodeToStack $                 Node (defBlockData fencedCodeSpec){                           blockData = toDyn@@ -1050,7 +1051,7 @@                                    ('`', 3, 0, mempty, mempty)                        pos <- getPosition                        _ <- gobbleUpToSpaces indentspaces-                       return $! (pos, node))+                       return (pos, node))      , blockConstructor    = \node -> do            let ((_, _, _, info, attrs) :: (Char, Int, Int, Text, Attributes)) =                    fromDyn (blockData (rootLabel node)) ('`', 3, 0, mempty, mempty)@@ -1107,7 +1108,7 @@                     return $! (pos', Node ndata{                                     blockData = toDyn (0 :: Int)                                   , blockLines = (toks ++ le) : blockLines ndata-                                  } children)) <|> (return $! (pos, node))+                                  } children)) <|> (return (pos, node))      , blockConstructor    = \node ->              return $! rawBlock (Format "html")                            (untokenize (getBlockText node))

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP                        #-}-{-# LANGUAGE BangPatterns               #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE FlexibleInstances          #-}@@ -27,6 +26,7 @@                                          singleton) import           Data.Text.Encoding   (encodeUtf8) import qualified Data.ByteString.Char8 as B+import qualified Data.Set as Set import           Text.Printf          (printf) import           Data.Char            (ord, isAlphaNum, isAscii, isSpace) import           Data.Maybe           (fromMaybe)@@ -166,7 +166,7 @@   htmlInline :: Text -> Maybe (Html a) -> Html a-htmlInline tagname mbcontents = HtmlElement InlineElement tagname [] mbcontents+htmlInline tagname = HtmlElement InlineElement tagname []  htmlBlock :: Text -> Maybe (Html a) -> Html a htmlBlock tagname mbcontents = HtmlElement BlockElement tagname [] mbcontents@@ -181,23 +181,244 @@ addAttribute attr (HtmlElement eltType tagname attrs mbcontents) =   HtmlElement eltType tagname (incorporateAttribute attr attrs) mbcontents addAttribute attr (HtmlText t)-  = HtmlElement InlineElement "span" [attr] $ Just (HtmlText t)+  = addAttribute attr $ HtmlElement InlineElement "span" [] $ Just (HtmlText t) addAttribute _ elt = elt  incorporateAttribute :: Attribute -> [Attribute] -> [Attribute] incorporateAttribute (k, v) as =-  case lookup k as of-    Nothing            -> (k, v) : as-    Just v'            -> (if k == "class"+  case lookup k' as of+    Nothing            -> (k', v) : as+    Just v'            -> (if k' == "class"                               then ("class", v <> " " <> v')-                              else (k, v')) :-                          filter (\(x, _) -> x /= k) as+                              else (k', v')) :+                          filter (\(x, _) -> x /= k') as+ where+  k' = if k `Set.member` html5Attributes+            || "data-" `T.isPrefixOf` k+          then k+          else "data-" <> k +html5Attributes :: Set.Set Text+html5Attributes = Set.fromList+  [ "abbr"+  , "accept"+  , "accept-charset"+  , "accesskey"+  , "action"+  , "allow"+  , "allowfullscreen"+  , "allowpaymentrequest"+  , "allowusermedia"+  , "alt"+  , "as"+  , "async"+  , "autocapitalize"+  , "autocomplete"+  , "autofocus"+  , "autoplay"+  , "charset"+  , "checked"+  , "cite"+  , "class"+  , "color"+  , "cols"+  , "colspan"+  , "content"+  , "contenteditable"+  , "controls"+  , "coords"+  , "crossorigin"+  , "data"+  , "datetime"+  , "decoding"+  , "default"+  , "defer"+  , "dir"+  , "dirname"+  , "disabled"+  , "download"+  , "draggable"+  , "enctype"+  , "enterkeyhint"+  , "for"+  , "form"+  , "formaction"+  , "formenctype"+  , "formmethod"+  , "formnovalidate"+  , "formtarget"+  , "headers"+  , "height"+  , "hidden"+  , "high"+  , "href"+  , "hreflang"+  , "http-equiv"+  , "id"+  , "imagesizes"+  , "imagesrcset"+  , "inputmode"+  , "integrity"+  , "is"+  , "ismap"+  , "itemid"+  , "itemprop"+  , "itemref"+  , "itemscope"+  , "itemtype"+  , "kind"+  , "label"+  , "lang"+  , "list"+  , "loading"+  , "loop"+  , "low"+  , "manifest"+  , "max"+  , "maxlength"+  , "media"+  , "method"+  , "min"+  , "minlength"+  , "multiple"+  , "muted"+  , "name"+  , "nomodule"+  , "nonce"+  , "novalidate"+  , "onabort"+  , "onafterprint"+  , "onauxclick"+  , "onbeforeprint"+  , "onbeforeunload"+  , "onblur"+  , "oncancel"+  , "oncanplay"+  , "oncanplaythrough"+  , "onchange"+  , "onclick"+  , "onclose"+  , "oncontextmenu"+  , "oncopy"+  , "oncuechange"+  , "oncut"+  , "ondblclick"+  , "ondrag"+  , "ondragend"+  , "ondragenter"+  , "ondragexit"+  , "ondragleave"+  , "ondragover"+  , "ondragstart"+  , "ondrop"+  , "ondurationchange"+  , "onemptied"+  , "onended"+  , "onerror"+  , "onfocus"+  , "onhashchange"+  , "oninput"+  , "oninvalid"+  , "onkeydown"+  , "onkeypress"+  , "onkeyup"+  , "onlanguagechange"+  , "onload"+  , "onloadeddata"+  , "onloadedmetadata"+  , "onloadend"+  , "onloadstart"+  , "onmessage"+  , "onmessageerror"+  , "onmousedown"+  , "onmouseenter"+  , "onmouseleave"+  , "onmousemove"+  , "onmouseout"+  , "onmouseover"+  , "onmouseup"+  , "onoffline"+  , "ononline"+  , "onpagehide"+  , "onpageshow"+  , "onpaste"+  , "onpause"+  , "onplay"+  , "onplaying"+  , "onpopstate"+  , "onprogress"+  , "onratechange"+  , "onrejectionhandled"+  , "onreset"+  , "onresize"+  , "onscroll"+  , "onsecuritypolicyviolation"+  , "onseeked"+  , "onseeking"+  , "onselect"+  , "onstalled"+  , "onstorage"+  , "onsubmit"+  , "onsuspend"+  , "ontimeupdate"+  , "ontoggle"+  , "onunhandledrejection"+  , "onunload"+  , "onvolumechange"+  , "onwaiting"+  , "onwheel"+  , "open"+  , "optimum"+  , "pattern"+  , "ping"+  , "placeholder"+  , "playsinline"+  , "poster"+  , "preload"+  , "readonly"+  , "referrerpolicy"+  , "rel"+  , "required"+  , "reversed"+  , "role"+  , "rows"+  , "rowspan"+  , "sandbox"+  , "scope"+  , "selected"+  , "shape"+  , "size"+  , "sizes"+  , "slot"+  , "span"+  , "spellcheck"+  , "src"+  , "srcdoc"+  , "srclang"+  , "srcset"+  , "start"+  , "step"+  , "style"+  , "tabindex"+  , "target"+  , "title"+  , "translate"+  , "type"+  , "typemustmatch"+  , "updateviacache"+  , "usemap"+  , "value"+  , "width"+  , "workertype"+  , "wrap"+  ]++ renderHtml :: Html a -> TL.Text renderHtml = {-# SCC renderHtml #-} toLazyText . toBuilder  toBuilder :: Html a -> Builder-toBuilder (HtmlNull) = mempty+toBuilder HtmlNull = mempty toBuilder (HtmlConcat x y) = toBuilder x <> toBuilder y toBuilder (HtmlRaw t) = fromText t toBuilder (HtmlText t) = escapeHtml t

@@ -17,8 +17,10 @@   , defaultFormattingSpecs   , BracketedSpec(..)   , defaultBracketedSpecs+  , LinkInfo(..)   , imageSpec   , linkSpec+  , pLink   , pLinkLabel   , pLinkDestination   , pLinkTitle@@ -290,13 +292,13 @@ pLinkSuffix :: IsInline il             => ReferenceMap -> Text -> Parsec [Tok] s (il -> il) pLinkSuffix rm key = do-  LinkInfo target title attrs <- pLink rm key+  LinkInfo target title attrs _mbpos <- pLink rm key   return $! addAttributes attrs . link target title  pImageSuffix :: IsInline il              => ReferenceMap -> Text -> Parsec [Tok] s (il -> il) pImageSuffix rm key = do-  LinkInfo target title attrs <- pLink rm key+  LinkInfo target title attrs _mbpos <- pLink rm key   return $! addAttributes attrs . image target title  ---@@ -408,7 +410,7 @@ withAttributes p = do   x <- p   attrParser <- attributeParser <$> getState-  option x $ (\attr -> addAttributes attr x) <$> attrParser+  option x $ (`addAttributes` x) <$> attrParser  pInline :: (IsInline a, Monad m)         => [InlineParser m a]@@ -426,7 +428,7 @@  rangeFromToks :: [Tok] -> SourcePos -> SourceRange rangeFromToks [] _ = SourceRange mempty-rangeFromToks (!z:zs) !endpos+rangeFromToks (z:zs) !endpos   | sourceLine (tokPos z) == sourceLine endpos     = SourceRange [(tokPos z, endpos)]   | otherwise@@ -436,8 +438,8 @@           case break (hasType LineEnd) ts of              ([], [])     -> []              ([], _:ys)   -> go ys-             (!x:_, [])   -> [(tokPos x, endpos)]-             (!x:_, !y:ys) ->+             (x:_, [])   -> [(tokPos x, endpos)]+             (x:_, y:ys) ->                case ys of                  (Tok _ !pos _ : _) | sourceColumn pos == 1 -> go (x:ys)                  _ -> (tokPos x, tokPos y) : go ys@@ -851,7 +853,7 @@ -- isn't. fixSingleQuote :: Cursor (Chunk a) -> Cursor (Chunk a) fixSingleQuote-  (Cursor (Just (Chunk d@(Delim{ delimType = '\'' }) pos toks)) xs ys) =+  (Cursor (Just (Chunk d@Delim{ delimType = '\'' } pos toks)) xs ys) =   Cursor (Just (Chunk d{ delimCanOpen = False } pos toks)) xs ys fixSingleQuote cursor = cursor @@ -870,7 +872,8 @@   _ <- symbol ')'   return $! LinkInfo { linkDestination = target                     , linkTitle = title-                    , linkAttributes = mempty }+                    , linkAttributes = mempty+                    , linkPos = Nothing }  pLinkDestination :: Monad m => ParsecT [Tok] s m [Tok] pLinkDestination = pAngleDest <|> pNormalDest 0

@@ -22,7 +22,11 @@  data LinkInfo = LinkInfo{ linkDestination :: !Text                         , linkTitle       :: !Text-                        , linkAttributes  :: !Attributes }+                        , linkAttributes  :: !Attributes+                        , linkPos         :: !(Maybe SourcePos)+                            -- ^ Position of the reference link definition+                            -- for references links.+                        }      deriving (Show, Typeable)  emptyReferenceMap :: ReferenceMap@@ -35,7 +39,7 @@                 -> ReferenceMap                 -> ReferenceMap insertReference label x (ReferenceMap m) =-  ReferenceMap (M.insertWith (\new old -> old ++ new)+  ReferenceMap (M.insertWith (flip (++))     (T.toCaseFold $! normalizeSpaces label) [toDyn x] m)  -- | Lookup a reference in a reference map.  If there are several

@@ -119,7 +119,7 @@                let newtok = Tok Spaces newpos                       (T.replicate (n - numspaces) " ")                getInput >>= setInput . (newtok:)-               setPosition $ newpos+               setPosition newpos                return $! numspaces)     <|> if requireAll            then mzero

@@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE BangPatterns #-}  module Commonmark.Tokens@@ -16,6 +15,7 @@ import qualified Data.Text       as T import           Data.Data       (Data, Typeable) import           Text.Parsec.Pos+import           Data.Text.Normalize (normalize, NormalizationMode(NFC))  data Tok = Tok { tokType     :: !TokType                , tokPos      :: !SourcePos@@ -34,7 +34,8 @@ -- | Convert a 'Text' into a list of 'Tok'. The first parameter -- species the source name. tokenize :: String -> Text -> [Tok]-tokenize name = {-# SCC tokenize #-} go (initialPos name) . T.groupBy f+tokenize name =+  {-# SCC tokenize #-} go (initialPos name) . T.groupBy f . normalize NFC   where     -- We group \r\n, consecutive spaces, and consecutive alphanums;     -- everything else gets in a token by itself.

@@ -12,6 +12,7 @@ import           System.IO             (hSetEncoding, utf8, openFile,                                         IOMode(..)) import qualified Data.Text.Lazy        as TL+import           Data.Text.Normalize   (normalize, NormalizationMode(NFC)) import           Test.Tasty import           Test.Tasty.HUnit import           Test.Tasty.QuickCheck@@ -111,7 +112,7 @@  tokenize_roundtrip :: String -> Bool tokenize_roundtrip s = untokenize (tokenize "source" t) == t-  where t = T.pack s+  where t = normalize NFC $ T.pack s  --- parser for spec test cases