mmark 0.0.3.2 → 0.0.4.0

raw patch · 18 files changed

+841/−514 lines, 18 filesdep ~criterionPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: criterion

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +63/−3
• Text/MMark.hs +69/−8
• Text/MMark/Extension.hs +3/−1
• Text/MMark/Internal.hs +0/−439
• Text/MMark/Parser.hs +89/−28
• Text/MMark/Parser/Internal.hs +0/−21
• Text/MMark/Parser/Internal/Type.hs +18/−11
• Text/MMark/Render.hs +171/−0
• Text/MMark/Type.hs +234/−0
• Text/MMark/Util.hs +67/−0
• bench/memory/Main.hs +2/−0
• bench/speed/Main.hs +2/−0
• data/bench-intensive-emphasis.md +6/−0
• data/table.html +30/−0
• data/table.md +25/−0
• mmark.cabal +5/−3
• tests/Text/MMarkSpec.hs +51/−0

@@ -1,3 +1,9 @@+## MMark 0.0.4.0++* Added support for pipe tables (like on GitHub).++* Fixed a nasty space leak in the parser, made it faster too.+ ## MMark 0.0.3.2  * Empty strings are not parsed as URIs anymore (even though a valid URI may

@@ -7,6 +7,15 @@ [![Build Status](https://travis-ci.org/mrkkrp/mmark.svg?branch=master)](https://travis-ci.org/mrkkrp/mmark) [![Coverage Status](https://coveralls.io/repos/mrkkrp/mmark/badge.svg?branch=master&service=github)](https://coveralls.io/github/mrkkrp/mmark?branch=master) +* [Quick start: MMark vs GitHub-flavored markdown](#quick-start-mmark-vs-github-flavored-markdown)+* [MMark and Common Mark](#mmark-and-common-mark)+    * [Differences in inline parsing](#differences-in-inline-parsing)+    * [Other differences](#other-differences)+* [About MMark-specific extensions](#about-mmark-specific-extensions)+* [Performance](#performance)+* [Contribution](#contribution)+* [License](#license)+ MMark (read “em-mark”) is a strict markdown processor for writers. “Strict” means that not every input is considered valid markdown document and parse errors are possible and even desirable, because they allow to spot markup@@ -19,15 +28,44 @@ * A parser that produces high-quality error messages and does not choke on   first parse error. It is capable of reporting many parse errors where   makes sense.+ * An extension system allowing to create extensions that alter parsed   markdown document in some way. Some of them are available in the   [`mmark-ext`](https://hackage.haskell.org/package/mmark-ext) package.+ * A [`lucid`](https://hackage.haskell.org/package/lucid)-based render.  There is also a blog post announcing the project:  https://markkarpov.com/post/announcing-mmark.html +## Quick start: MMark vs GitHub-flavored markdown++It's easy to start using MMark if you're used to GitHub-flavored markdown.+There are three main differences:++1. URIs are not automatically recognized, you must to enclose them in `<`+   and `>`.++2. Block quotes require only one `>` and they continue as long as long the+   inner content is indented.++   This is OK:++   ```+   > Here goes my block quote.+     And this is the second line of the quote.+   ```++   This produces *two* block quotes:++   ```+   > Here goes my block quote.+   > And this is another block quote!+   ```++3. See [differences in inline parsing](#differences-in-inline-parsing).+ ## MMark and Common Mark  MMark mostly tries to follow the Common Mark specification as given here:@@ -49,8 +87,7 @@ * superscript using `^this^` syntax * subscript using `~this~` syntax * automatic assignment of ids to headers-* PHP-style footnotes, e.g. `[^1]` (NOT YET)-* “pipe” tables (as used on GitHub) (NOT YET)+* pipe tables (as on GitHub)  One do not need to enable or tweak anything for these to work, they are built-in features.@@ -213,11 +250,34 @@ * HTML inlines are not supported for the same reason why HTML blocks are not   supported. -### Additional information about MMark-specific extensions+## About MMark-specific extensions  * YAML block must start with three hyphens `---` and end with three hyphens   `---`. It can only be placed at the beginning of a markdown document.   Trailing white space after the `---` sequences is allowed.++## Performance++I have compared speed and memory consumption of various Haskell markdown+libraries by running them on an identical, big-enough markdown document and+by rendering it as HTML:++Library             | Execution time | Allocated   | Max residency | Parsing library+--------------------|----------------|-------------|---------------|----------------+`cmark-0.5.6`       | 325.5 μs       |     228,440 |         9,608 | Custom C code+`mmark-0.0.4.0`     | 8.526 ms       |  36,282,776 |       313,632 | Megaparsec+`cheapskate-0.1.1`  | 10.84 ms       |  44,686,272 |       799,200 | Custom Haskell code+`markdown-0.1.16` † | 14.14 ms       |  69,261,816 |       699,656 | Attoparsec+`pandoc-2.0.5`      | 38.32 ms       | 141,868,840 |     1,471,080 | Parsec++*Results are ordered from fastest to slowest.*++† The `markdown` library is sloppy and parses markdown incorrectly. For+example, it parses the following `*My * text` as an inline containing+emphasis, while in reality both asterisks must form flanking delimiter runs+to create emphasis, like so `*My* text`. This allowed `markdown` to get away+with a far simpler approach to parsing at the price that it's not really a+valid markdown implementation.  ## Contribution 

@@ -36,8 +36,7 @@ --     * superscript using @^this^@ syntax --     * subscript using @~this~@ syntax --     * automatic assignment of ids to headers---     * PHP-style footnotes, e.g. @[^1]@ (NOT YET)---     * “pipe” tables (as used on GitHub) (NOT YET)+--     * pipe tables (as on GitHub) -- -- One do not need to enable or tweak anything for these to work, they are -- built-in features.@@ -111,6 +110,8 @@ -- "Text.MMark.Extension" module, which has some documentation focusing on -- extension writing. +{-# LANGUAGE RecordWildCards #-}+ module Text.MMark   ( -- * Parsing     MMark@@ -131,15 +132,16 @@  import Data.Aeson import Data.List.NonEmpty (NonEmpty (..))+import Data.Semigroup ((<>)) import Data.Text (Text)-import Text.MMark.Internal-import Text.MMark.Parser+import Text.MMark.Parser (MMarkErr (..), parse)+import Text.MMark.Render (render)+import Text.MMark.Type import Text.Megaparsec (ParseError (..), parseErrorPretty_, mkPos)---- | Extract contents of an optional YAML block that may have been parsed.+import qualified Control.Foldl as L -projectYaml :: MMark -> Maybe Value-projectYaml = mmarkYaml+----------------------------------------------------------------------------+-- Parsing  -- | Pretty-print a collection of parse errors returned from 'parse'. --@@ -152,3 +154,62 @@   -> NonEmpty (ParseError Char MMarkErr) -- ^ Collection of parse errors   -> String            -- ^ Result of pretty-printing parseErrorsPretty input = concatMap (parseErrorPretty_ (mkPos 4) input)++----------------------------------------------------------------------------+-- Extensions++-- | Apply an 'Extension' to an 'MMark' document. The order in which you+-- apply 'Extension's /does matter/. Extensions you apply first take effect+-- first. The extension system is designed in such a way that in many cases+-- the order doesn't matter, but sometimes the difference is important.++useExtension :: Extension -> MMark -> MMark+useExtension ext mmark =+  mmark { mmarkExtension = ext <> mmarkExtension mmark }++-- | Apply several 'Extension's to an 'MMark' document.+--+-- This is a simple shortcut:+--+-- > useExtensions exts = useExtension (mconcat exts)+--+-- As mentioned in the docs for 'useExtension', the order in which you apply+-- extensions matters. Extensions closer to beginning of the list are+-- applied later, i.e. the last extension in the list is applied first.++useExtensions :: [Extension] -> MMark -> MMark+useExtensions exts = useExtension (mconcat exts)++----------------------------------------------------------------------------+-- Scanning++-- | Scan an 'MMark' document efficiently in one pass. This uses the+-- excellent 'L.Fold' type, which see.+--+-- Take a look at the "Text.MMark.Extension" module if you want to create+-- scanners of your own.++runScanner+  :: MMark             -- ^ Document to scan+  -> L.Fold Bni a      -- ^ 'L.Fold' to use+  -> a                 -- ^ Result of scanning+runScanner MMark {..} f = L.fold f mmarkBlocks++-- | Like 'runScanner', but allows to run scanners with monadic context.+--+-- To bring 'L.Fold' and 'L.FoldM' types to the “least common denominator”+-- use 'L.generalize' and 'L.simplify'.+--+-- @since 0.0.2.0++runScannerM+  :: Monad m+  => MMark             -- ^ Document to scan+  -> L.FoldM m Bni a   -- ^ 'L.FoldM' to use+  -> m a               -- ^ Result of scanning+runScannerM MMark {..} f = L.foldM f mmarkBlocks++-- | Extract contents of an optional YAML block that may have been parsed.++projectYaml :: MMark -> Maybe Value+projectYaml = mmarkYaml

@@ -43,6 +43,7 @@     -- ** Block-level manipulation   , Bni   , Block (..)+  , CellAlign (..)   , blockTrans   , blockRender   , Ois@@ -62,7 +63,8 @@  import Data.Monoid hiding ((<>)) import Lucid-import Text.MMark.Internal+import Text.MMark.Type+import Text.MMark.Util import qualified Control.Foldl as L  -- | Create an extension that performs a transformation on 'Block's of

@@ -1,439 +0,0 @@--- |--- Module      :  Text.MMark.Internal--- Copyright   :  © 2017 Mark Karpov--- License     :  BSD 3 clause------ Maintainer  :  Mark Karpov <markkarpov92@gmail.com>--- Stability   :  experimental--- Portability :  portable------ Internal definitions.--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable     #-}-{-# LANGUAGE DeriveFunctor      #-}-{-# LANGUAGE DeriveGeneric      #-}-{-# LANGUAGE LambdaCase         #-}-{-# LANGUAGE OverloadedStrings  #-}-{-# LANGUAGE RankNTypes         #-}-{-# LANGUAGE RecordWildCards    #-}--module Text.MMark.Internal-  ( -- * Types-    MMark (..)-  , Extension (..)-  , Bni-  , Block (..)-  , Inline (..)-    -- * Extensions-  , runScanner-  , runScannerM-  , useExtension-  , useExtensions-    -- * Renders-  , render-  , Ois-  , getOis-  , Render (..)-  , defaultBlockRender-  , defaultInlineRender-    -- * Utils-  , asPlainText-  , headerId-  , headerFragment )-where--import Control.Arrow-import Control.DeepSeq-import Control.Monad-import Data.Aeson-import Data.Char (isSpace, isAlphaNum)-import Data.Data (Data)-import Data.Function (on)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Monoid hiding ((<>))-import Data.Semigroup-import Data.Text (Text)-import Data.Typeable (Typeable)-import GHC.Generics-import Lucid-import Text.URI (URI (..))-import qualified Control.Foldl as L-import qualified Data.Text     as T-import qualified Text.URI      as URI--------------------------------------------------------------------------------- Types---- | Representation of complete markdown document. You can't look inside of--- 'MMark' on purpose. The only way to influence an 'MMark' document you--- obtain as a result of parsing is via the extension mechanism.--data MMark = MMark-  { mmarkYaml :: Maybe Value-    -- ^ Parsed YAML document at the beginning (optional)-  , mmarkBlocks :: [Bni]-    -- ^ Actual contents of the document-  , mmarkExtension :: Extension-    -- ^ Extension specifying how to process and render the blocks-  }--instance NFData MMark where-  rnf MMark {..} = rnf mmarkYaml `seq` rnf mmarkBlocks---- | An extension. You can apply extensions with 'useExtension' and--- 'useExtensions' functions. The "Text.MMark.Extension" module provides--- tools for extension creation.------ Note that 'Extension' is an instance of 'Semigroup' and 'Monoid', i.e.--- you can combine several extensions into one. Since the @('<>')@ operator--- is right-associative and 'mconcat' is a right fold under the hood, the--- expression------ > l <> r------ means that the extension @r@ will be applied before the extension @l@,--- similar to how 'Endo' works. This may seem counter-intuitive, but only--- with this logic we get consistency of ordering with more complex--- expressions:------ > e2 <> e1 <> e0 == e2 <> (e1 <> e0)------ Here, @e0@ will be applied first, then @e1@, then @e2@. The same applies--- to expressions involving 'mconcat'—extensions closer to beginning of the--- list passed to 'mconcat' will be applied later.--data Extension = Extension-  { extBlockTrans :: Endo Bni-    -- ^ Block transformation-  , extBlockRender :: Render (Block (Ois, Html ()))-    -- ^ Block render-  , extInlineTrans :: Endo Inline-    -- ^ Inline transformation-  , extInlineRender :: Render Inline-    -- ^ Inline render-  }--instance Semigroup Extension where-  x <> y = Extension-    { extBlockTrans   = on (<>) extBlockTrans   x y-    , extBlockRender  = on (<>) extBlockRender  x y-    , extInlineTrans  = on (<>) extInlineTrans  x y-    , extInlineRender = on (<>) extInlineRender x y }--instance Monoid Extension where-  mempty = Extension-    { extBlockTrans   = mempty-    , extBlockRender  = mempty-    , extInlineTrans  = mempty-    , extInlineRender = mempty }-  mappend = (<>)---- | A shortcut for the frequently used type @'Block' ('NonEmpty'--- 'Inline')@.--type Bni = Block (NonEmpty Inline)---- | We can think of a markdown document as a collection of--- blocks—structural elements like paragraphs, block quotations, lists,--- headings, thematic breaks, and code blocks. Some blocks (like block--- quotes and list items) contain other blocks; others (like headings and--- paragraphs) contain inline content, see 'Inline'.------ We can divide blocks into two types: container blocks, which can contain--- other blocks, and leaf blocks, which cannot.--data Block a-  = ThematicBreak-    -- ^ Thematic break, leaf block-  | Heading1 a-    -- ^ Heading (level 1), leaf block-  | Heading2 a-    -- ^ Heading (level 2), leaf block-  | Heading3 a-    -- ^ Heading (level 3), leaf block-  | Heading4 a-    -- ^ Heading (level 4), leaf block-  | Heading5 a-    -- ^ Heading (level 5), leaf block-  | Heading6 a-    -- ^ Heading (level 6), leaf block-  | CodeBlock (Maybe Text) Text-    -- ^ Code block, leaf block with info string and contents-  | Paragraph a-    -- ^ Paragraph, leaf block-  | Blockquote [Block a]-    -- ^ Blockquote container block-  | OrderedList Word (NonEmpty [Block a])-    -- ^ Ordered list ('Word' is the start index), container block-  | UnorderedList (NonEmpty [Block a])-    -- ^ Unordered list, container block-  | Naked a-    -- ^ Naked content, without an enclosing tag-  deriving (Show, Eq, Ord, Data, Typeable, Generic, Functor, Foldable)--instance NFData a => NFData (Block a)---- | Inline markdown content.--data Inline-  = Plain Text-    -- ^ Plain text-  | LineBreak-    -- ^ Line break (hard)-  | Emphasis (NonEmpty Inline)-    -- ^ Emphasis-  | Strong (NonEmpty Inline)-    -- ^ Strong emphasis-  | Strikeout (NonEmpty Inline)-    -- ^ Strikeout-  | Subscript (NonEmpty Inline)-    -- ^ Subscript-  | Superscript (NonEmpty Inline)-    -- ^ Superscript-  | CodeSpan Text-    -- ^ Code span-  | Link (NonEmpty Inline) URI (Maybe Text)-    -- ^ Link with text, destination, and optionally title-  | Image (NonEmpty Inline) URI (Maybe Text)-    -- ^ Image with description, URL, and optionally title-  deriving (Show, Eq, Ord, Data, Typeable, Generic)--instance NFData Inline--------------------------------------------------------------------------------- Extensions---- | Apply an 'Extension' to an 'MMark' document. The order in which you--- apply 'Extension's /does matter/. Extensions you apply first take effect--- first. The extension system is designed in such a way that in many cases--- the order doesn't matter, but sometimes the difference is important.--useExtension :: Extension -> MMark -> MMark-useExtension ext mmark =-  mmark { mmarkExtension = ext <> mmarkExtension mmark }---- | Apply several 'Extension's to an 'MMark' document.------ This is a simple shortcut:------ > useExtensions exts = useExtension (mconcat exts)------ As mentioned in the docs for 'useExtension', the order in which you apply--- extensions matters. Extensions closer to beginning of the list are--- applied later, i.e. the last extension in the list is applied first.--useExtensions :: [Extension] -> MMark -> MMark-useExtensions exts = useExtension (mconcat exts)---- | Scan an 'MMark' document efficiently in one pass. This uses the--- excellent 'L.Fold' type, which see.------ Take a look at the "Text.MMark.Extension" module if you want to create--- scanners of your own.--runScanner-  :: MMark             -- ^ Document to scan-  -> L.Fold Bni a      -- ^ 'L.Fold' to use-  -> a                 -- ^ Result of scanning-runScanner MMark {..} f = L.fold f mmarkBlocks---- | Like 'runScanner', but allows to run scanners with monadic context.------ To bring 'L.Fold' and 'L.FoldM' types to the “least common denominator”--- use 'L.generalize' and 'L.simplify'.------ @since 0.0.2.0--runScannerM-  :: Monad m-  => MMark             -- ^ Document to scan-  -> L.FoldM m Bni a   -- ^ 'L.FoldM' to use-  -> m a               -- ^ Result of scanning-runScannerM MMark {..} f = L.foldM f mmarkBlocks--------------------------------------------------------------------------------- Renders---- | Render a 'MMark' markdown document. You can then render @'Html' ()@ to--- various things:------     * to lazy 'Data.Taxt.Lazy.Text' with 'renderText'---     * to lazy 'Data.ByteString.Lazy.ByteString' with 'renderBS'---     * directly to file with 'renderToFile'--render :: MMark -> Html ()-render MMark {..} =-  mapM_ produceBlock mmarkBlocks-  where-    Extension {..} = mmarkExtension-    produceBlock   = applyBlockRender extBlockRender-      . fmap ((Ois &&& mapM_ (applyInlineRender extInlineRender)) .-              fmap  (appEndo extInlineTrans))-      . appEndo extBlockTrans---- | A wrapper for “originial inlines”. Source inlines are wrapped in this--- during rendering of inline components and then it's available to block--- render, but only for inspection. Altering of 'Ois' is not possible--- because the user cannot construct a value of the 'Ois' type, she can only--- inspect it with 'getOis'.--newtype Ois = Ois (NonEmpty Inline)---- | Project @'NonEmpty' 'Inline'@ from 'Ois'.--getOis :: Ois -> NonEmpty Inline-getOis (Ois inlines) = inlines---- | An internal type that captures the extensible rendering process we use.--- 'Render' has a function inside which transforms a rendering function of--- the type @a -> Html ()@.--newtype Render a = Render-  { getRender :: (a -> Html ()) -> a -> Html () }--instance Semigroup (Render a) where-  Render f <> Render g = Render $ \h -> f (g h)--instance Monoid (Render a) where-  mempty  = Render id-  mappend = (<>)---- | Apply a 'Render' to a given @'Block' 'Html' ()@.--applyBlockRender-  :: Render (Block (Ois, Html ()))-  -> Block (Ois, Html ())-  -> Html ()-applyBlockRender r = getRender r defaultBlockRender---- | The default 'Block' render. Note that it does not care about what we--- have rendered so far because it always starts rendering. Thus it's OK to--- just pass it something dummy as the second argument of the inner--- function.--defaultBlockRender :: Block (Ois, Html ()) -> Html ()-defaultBlockRender = \case-  ThematicBreak ->-    hr_ [] >> newline-  Heading1 (h,html) ->-    h1_ (mkId h) html >> newline-  Heading2 (h,html) ->-    h2_ (mkId h) html >> newline-  Heading3 (h,html) ->-    h3_ (mkId h) html >> newline-  Heading4 (h,html) ->-    h4_ (mkId h) html >> newline-  Heading5 (h,html) ->-    h5_ (mkId h) html >> newline-  Heading6 (h,html) ->-    h6_ (mkId h) html >> newline-  CodeBlock infoString txt -> do-    let f x = class_ $ "language-" <> T.takeWhile (not . isSpace) x-    pre_ $ code_ (maybe [] (pure . f) infoString) (toHtml txt)-    newline-  Paragraph (_,html) ->-    p_ html >> newline-  Blockquote blocks -> do-    blockquote_ (newline <* mapM_ defaultBlockRender blocks)-    newline-  OrderedList i items -> do-    let startIndex = [start_ (T.pack $ show i) | i /= 1]-    ol_ startIndex $ do-      newline-      forM_ items $ \x -> do-        li_ (newline <* mapM_ defaultBlockRender x)-        newline-    newline-  UnorderedList items -> do-    ul_ $ do-      newline-      forM_ items $ \x -> do-        li_ (newline <* mapM_ defaultBlockRender x)-        newline-    newline-  Naked (_,html) ->-    html >> newline-  where-    mkId (Ois x) = [id_ (headerId x)]---- | Apply a render to a given 'Inline'.--applyInlineRender :: Render Inline -> Inline -> Html ()-applyInlineRender r = getRender r defaultInlineRender---- | The default render for 'Inline' elements. Comments about--- 'defaultBlockRender' apply here just as well.--defaultInlineRender :: Inline -> Html ()-defaultInlineRender = \case-  Plain txt ->-    toHtml txt-  LineBreak ->-    br_ [] >> newline-  Emphasis inner ->-    em_ (mapM_ defaultInlineRender inner)-  Strong inner ->-    strong_ (mapM_ defaultInlineRender inner)-  Strikeout inner ->-    del_ (mapM_ defaultInlineRender inner)-  Subscript inner ->-    sub_ (mapM_ defaultInlineRender inner)-  Superscript inner ->-    sup_ (mapM_ defaultInlineRender inner)-  CodeSpan txt ->-    code_ (toHtmlRaw txt)-  Link inner dest mtitle ->-    let title = maybe [] (pure . title_) mtitle-    in a_ (href_ (URI.render dest) : title) (mapM_ defaultInlineRender inner)-  Image desc src mtitle ->-    let title = maybe [] (pure . title_) mtitle-    in img_ (alt_ (asPlainText desc) : src_ (URI.render src) : title)---- | HTML containing a newline.--newline :: Html ()-newline = "\n"--------------------------------------------------------------------------------- Utils---- | Convert a non-empty collection of 'Inline's into their plain text--- representation. This is used e.g. to render image descriptions.--asPlainText :: NonEmpty Inline -> Text-asPlainText = foldMap $ \case-  Plain      txt -> txt-  LineBreak      -> "\n"-  Emphasis    xs -> asPlainText xs-  Strong      xs -> asPlainText xs-  Strikeout   xs -> asPlainText xs-  Subscript   xs -> asPlainText xs-  Superscript xs -> asPlainText xs-  CodeSpan   txt -> txt-  Link    xs _ _ -> asPlainText xs-  Image   xs _ _ -> asPlainText xs---- | Generate value of id attribute for a given header. This is used during--- rendering and also can be used to get id of a header for linking to it in--- extensions.------ See also: 'headerFragment'.--headerId :: NonEmpty Inline -> Text-headerId = T.intercalate "-"-  . T.words-  . T.filter (\x -> isAlphaNum x || isSpace x)-  . T.toLower-  . asPlainText---- | Generate a 'URI' containing only a fragment from its textual--- representation. Useful for getting URL from id of a header.--headerFragment :: Text -> URI-headerFragment fragment = URI-  { uriScheme    = Nothing-  , uriAuthority = Left False-  , uriPath      = []-  , uriQuery     = []-  , uriFragment  = URI.mkFragment fragment }

@@ -9,13 +9,14 @@ -- -- MMark markdown parser. -{-# LANGUAGE BangPatterns      #-}-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes        #-}-{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE BangPatterns              #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE LambdaCase                #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RankNTypes                #-}+{-# LANGUAGE TypeFamilies              #-}  module Text.MMark.Parser   ( MMarkErr (..)@@ -30,11 +31,13 @@ import Data.List.NonEmpty (NonEmpty (..), (<|)) import Data.Maybe (isNothing, fromJust, fromMaybe, catMaybes, isJust) import Data.Monoid (Any (..))+import Data.Ratio ((%)) import Data.Semigroup (Semigroup (..)) import Data.Text (Text) import Data.Void-import Text.MMark.Internal import Text.MMark.Parser.Internal+import Text.MMark.Type+import Text.MMark.Util import Text.Megaparsec hiding (parse, State (..)) import Text.Megaparsec.Char hiding (eol) import Text.URI (URI)@@ -90,9 +93,6 @@      -- ^ Parse errors or parsed document parse file input =   case runBParser pMMark file input of-    -- NOTE This parse error only happens when document structure on block-    -- level cannot be parsed even with recovery, which should not normally-    -- happen except for the cases when we deal with YAML parsing errors.     Left errs -> Left errs     Right ((myaml, rawBlocks), defs) ->       let parsed = doInline <$> rawBlocks@@ -142,12 +142,12 @@           then return []           else (l :) <$> go   ls <- go-  case (Yaml.decodeEither . TE.encodeUtf8 . T.intercalate "\n") ls of-    Left err' -> do-      let (apos, err) = splitYamlError (sourceName dpos) err'-      return $ Left (fromMaybe dpos apos, err)-    Right v ->-      return (Right v)+  return $+    case (Yaml.decodeEither . TE.encodeUtf8 . T.intercalate "\n") ls of+      Left err' ->+        let (apos, err) = splitYamlError (sourceName dpos) err'+        in Left (fromMaybe dpos apos, err)+      Right v -> Right v  -- | Parse several (possibly zero) blocks in a row. @@ -172,6 +172,7 @@         , Just <$> pOrderedList         , Just <$> pBlockquote         , pReferenceDef+        , Just <$> pTable         , Just <$> pParagraph ]       _  ->           Just <$> pIndentedCodeBlock@@ -287,8 +288,8 @@ pUnorderedList = do   (bullet, bulletPos, minLevel, indLevel) <-     pListBullet Nothing-  x      <- innerBlocks bulletPos minLevel indLevel-  xs     <- many $ do+  x  <- innerBlocks bulletPos minLevel indLevel+  xs <- many $ do     (_, bulletPos', minLevel', indLevel') <-       pListBullet (Just (bullet, bulletPos))     innerBlocks bulletPos' minLevel' indLevel'@@ -315,16 +316,16 @@      -- ^ Bullet 'Char' and start position of the first bullet in a list   -> BParser (Char, SourcePos, Pos, Pos) pListBullet mbullet = try $ do-  pos     <- getPosition-  l       <- (<> mkPos 2) <$> L.indentLevel-  bullet  <-+  pos    <- getPosition+  l      <- (<> mkPos 2) <$> L.indentLevel+  bullet <-     case mbullet of       Nothing -> char '-' <|> char '+' <|> char '*'       Just (bullet, bulletPos) -> do         guard (sourceColumn pos >= sourceColumn bulletPos)         char bullet   eof <|> sc1-  l'      <- L.indentLevel+  l'     <- L.indentLevel   return (bullet, pos, l, l')  -- | Parse an ordered list.@@ -433,6 +434,59 @@     recover err =       Just (Naked (IspError err)) <$ takeWhileP Nothing notNewline <* sc +-- | Parse a pipe table.++pTable :: BParser (Block Isp)+pTable = do+  (n, headerRow) <- try $ do+    let pipe' = option False (True <$ pipe)+    l <- pipe'+    headerRow <- NE.sepBy1 cell (try (pipe <* notFollowedBy eol))+    r <- pipe'+    let n = NE.length headerRow+    guard (n > 1 || l || r)+    eol <* sc'+    lookAhead nonEmptyLine >>= guard . isHeaderLike+    return (n, headerRow)+  caligns <- rowWrapper (NE.fromList <$> sepByCount n calign pipe)+  otherRows <- many $ do+    lookAhead (option True (isBlank <$> nonEmptyLine)) >>= guard . not+    rowWrapper (NE.fromList <$> sepByCount n cell pipe)+  Table caligns (headerRow :| otherRows) <$ sc+  where+    cell = do+      startPos <- getPosition+      txt      <- fmap (T.stripEnd . bakeText) . foldMany . choice $+        [ (++) . reverse . T.unpack <$> hidden (string "\\|")+        , (:) <$> label "inline content" (satisfy cellChar) ]+      return (IspSpan startPos txt)+    cellChar x = x /= '|' && notNewline x+    rowWrapper p = do+      void (optional pipe)+      r <- p+      void (optional pipe)+      eof <|> eol+      sc'+      return r+    pipe = char '|' <* sc'+    calign = do+      let colon' = option False (True <$ char ':')+      l <- colon'+      void (count 3 (char '-') <* many (char '-'))+      r <- colon'+      sc'+      return $+        case (l, r) of+          (False, False) -> CellAlignDefault+          (True,  False) -> CellAlignLeft+          (False, True)  -> CellAlignRight+          (True,  True)  -> CellAlignCenter+    isHeaderLike txt =+      T.length (T.filter isHeaderConstituent txt) % T.length txt >+      8 % 10+    isHeaderConstituent x =+      isSpace x || x == '|' || x == '-' || x == ':'+ -- | Parse a paragraph or naked text (is some cases).  pParagraph :: BParser (Block Isp)@@ -803,13 +857,20 @@   where     go !n = liftA2 (:) (m n) (go (n + 1)) <|> pure [] -foldMany :: Alternative f => f (a -> a) -> f (a -> a)-foldMany f = go+foldMany :: MonadPlus m => m (a -> a) -> m (a -> a)+foldMany f = go id   where-    go = (flip (.) <$> f <*> go) <|> pure id+    go g =+      optional f >>= \case+        Nothing -> pure g+        Just h  -> go (h . g) -foldSome :: Alternative f => f (a -> a) -> f (a -> a)-foldSome f = flip (.) <$> f <*> foldMany f+foldSome :: MonadPlus m => m (a -> a) -> m (a -> a)+foldSome f = liftA2 (flip (.)) f (foldMany f)++sepByCount :: Applicative f => Int -> f a -> f sep -> f [a]+sepByCount 0 _ _   = pure []+sepByCount n p sep = liftA2 (:) p (count (n - 1) (sep *> p))  nonEmptyLine :: BParser Text nonEmptyLine = takeWhile1P Nothing notNewline

@@ -20,7 +20,6 @@   , refLevel   , subEnv   , registerReference-  , registerFootnote     -- * Inline-level parser monad   , IParser   , runIParser@@ -35,7 +34,6 @@   , lastSpace   , lastOther   , lookupReference-  , lookupFootnote   , Isp (..)     -- * Reference and footnote definitions   , Defs@@ -53,7 +51,6 @@ import Data.Text.Metrics (damerauLevenshteinNorm) import Lens.Micro (Lens', (^.), (.~), set, over, to) import Lens.Micro.Extras (view)-import Text.MMark.Internal import Text.MMark.Parser.Internal.Type import Text.Megaparsec hiding (State) import Text.URI (URI)@@ -112,14 +109,6 @@   -> BParser Bool      -- ^ 'True' if there is a conflicting definition registerReference = registerGeneric referenceDefs --- | Register a footnote definition.--registerFootnote-  :: Text              -- ^ Reference name-  -> NonEmpty Inline   -- ^ FIXME Footnote definition-  -> BParser Bool      -- ^ 'True' if there is a conflicting definition-registerFootnote = registerGeneric footnoteDefs- -- | A generic function for registering definitions in 'BParser'.  registerGeneric@@ -228,16 +217,6 @@      -- ^ A collection of suggested reference names in 'Left' (typo      -- corrections) or the requested definition in 'Right' lookupReference = lookupGeneric referenceDefs---- | Lookup a footnote definition.--lookupFootnote-  :: Text-     -- ^ Footnote name-  -> IParser (Either [Text] (NonEmpty Inline))-     -- ^ A collection of suggested reference names in 'Left' (typo-     -- corrections) or the requested definition in 'Right'-lookupFootnote = lookupGeneric footnoteDefs  -- | A generic function for looking up definition in 'IParser'. 

@@ -33,7 +33,6 @@     -- * Reference and footnote definitions   , Defs   , referenceDefs-  , footnoteDefs   , DefLabel   , mkDefLabel   , unDefLabel@@ -54,7 +53,6 @@ import Data.Typeable (Typeable) import GHC.Generics import Lens.Micro.TH-import Text.MMark.Internal import Text.Megaparsec import Text.URI (URI) import qualified Data.CaseInsensitive as CI@@ -134,17 +132,14 @@  -- | An opaque container for reference and footnote definitions. -data Defs = Defs+newtype Defs = Defs   { _referenceDefs :: HashMap DefLabel (URI, Maybe Text)     -- ^ Reference definitions containing a 'URI' and optionally title-  , _footnoteDefs :: HashMap DefLabel (NonEmpty Inline)-    -- ^ FIXME Footnote definitions   }  instance Default Defs where   def = Defs     { _referenceDefs = HM.empty-    , _footnoteDefs  = HM.empty     }  -- | An opaque type for definition label.@@ -170,36 +165,48 @@ data MMarkErr   = YamlParseError String     -- ^ YAML error that occurred during parsing of a YAML block+  | NonFlankingDelimiterRun (NonEmpty Char)+    -- ^ This delimiter run should be in left- or right- flanking position   | ListStartIndexTooBig Word     -- ^ Ordered list start numbers must be nine digits or less+    --+    -- @since 0.0.2.0   | ListIndexOutOfOrder Word Word     -- ^ The index in an ordered list is out of order, first number is the     -- actual index we ran into, the second number is the expected index-  | NonFlankingDelimiterRun (NonEmpty Char)-    -- ^ This delimiter run should be in left- or right- flanking position+    --+    -- @since 0.0.2.0   | DuplicateReferenceDefinition Text     -- ^ Duplicate reference definitions are not allowed+    --+    -- @since 0.0.3.0   | CouldNotFindReferenceDefinition Text [Text]     -- ^ Could not find this reference definition, the second argument is     -- the collection of close names (typo corrections)+    --+    -- @since 0.0.3.0   | InvalidNumericCharacter Int     -- ^ This numeric character is invalid+    --+    -- @since 0.0.3.0   | UnknownHtmlEntityName Text     -- ^ Unknown HTML5 entity name+    --+    -- @since 0.0.3.0   deriving (Eq, Ord, Show, Read, Generic, Typeable, Data)  instance ShowErrorComponent MMarkErr where   showErrorComponent = \case     YamlParseError str ->       "YAML parse error: " ++ str+    NonFlankingDelimiterRun dels ->+      showTokens dels ++ " should be in left- or right- flanking position"     ListStartIndexTooBig n ->       "ordered list start numbers must be nine digits or less, " ++ show n         ++ " is too big"     ListIndexOutOfOrder actual expected ->-      "list index out of order: " ++ show actual ++ ", expected "+      "list index is out of order: " ++ show actual ++ ", expected "         ++ show expected-    NonFlankingDelimiterRun dels ->-      showTokens dels ++ " should be in left- or right- flanking position"     DuplicateReferenceDefinition name ->       "duplicate reference definitions are not allowed: \""         ++ T.unpack name ++ "\""

@@ -0,0 +1,171 @@+-- |+-- Module      :  Text.MMark.Render+-- Copyright   :  © 2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- MMark rendering machinery.++{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++module Text.MMark.Render+  ( render )+where++import Control.Arrow+import Control.Monad+import Data.Char (isSpace)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Monoid hiding ((<>))+import Data.Semigroup+import Lucid+import Text.MMark.Type+import Text.MMark.Util+import qualified Data.List.NonEmpty as NE+import qualified Data.Text          as T+import qualified Text.URI           as URI++-- | Render a 'MMark' markdown document. You can then render @'Html' ()@ to+-- various things:+--+--     * to lazy 'Data.Taxt.Lazy.Text' with 'renderText'+--     * to lazy 'Data.ByteString.Lazy.ByteString' with 'renderBS'+--     * directly to file with 'renderToFile'++render :: MMark -> Html ()+render MMark {..} =+  mapM_ rBlock mmarkBlocks+  where+    Extension {..} = mmarkExtension+    rBlock+      = applyBlockRender extBlockRender+      . fmap rInlines+      . appEndo extBlockTrans+    rInlines+      = (mkOisInternal &&& mapM_ (applyInlineRender extInlineRender))+      . fmap (appEndo extInlineTrans)++-- | Apply a 'Render' to a given @'Block' 'Html' ()@.++applyBlockRender+  :: Render (Block (Ois, Html ()))+  -> Block (Ois, Html ())+  -> Html ()+applyBlockRender r = getRender r defaultBlockRender++-- | The default 'Block' render. Note that it does not care about what we+-- have rendered so far because it always starts rendering. Thus it's OK to+-- just pass it something dummy as the second argument of the inner+-- function.++defaultBlockRender :: Block (Ois, Html ()) -> Html ()+defaultBlockRender = \case+  ThematicBreak ->+    hr_ [] >> newline+  Heading1 (h,html) ->+    h1_ (mkId h) html >> newline+  Heading2 (h,html) ->+    h2_ (mkId h) html >> newline+  Heading3 (h,html) ->+    h3_ (mkId h) html >> newline+  Heading4 (h,html) ->+    h4_ (mkId h) html >> newline+  Heading5 (h,html) ->+    h5_ (mkId h) html >> newline+  Heading6 (h,html) ->+    h6_ (mkId h) html >> newline+  CodeBlock infoString txt -> do+    let f x = class_ $ "language-" <> T.takeWhile (not . isSpace) x+    pre_ $ code_ (maybe [] (pure . f) infoString) (toHtml txt)+    newline+  Naked (_,html) ->+    html >> newline+  Paragraph (_,html) ->+    p_ html >> newline+  Blockquote blocks -> do+    blockquote_ (newline <* mapM_ defaultBlockRender blocks)+    newline+  OrderedList i items -> do+    let startIndex = [start_ (T.pack $ show i) | i /= 1]+    ol_ startIndex $ do+      newline+      forM_ items $ \x -> do+        li_ (newline <* mapM_ defaultBlockRender x)+        newline+    newline+  UnorderedList items -> do+    ul_ $ do+      newline+      forM_ items $ \x -> do+        li_ (newline <* mapM_ defaultBlockRender x)+        newline+    newline+  Table calign (hs :| rows) -> do+    table_ $ do+      newline+      thead_ $ do+        newline+        tr_ $+          forM_ (NE.zip calign hs) $ \(a, h) ->+            th_ (alignStyle a) (snd h)+        newline+      newline+      tbody_ $ do+        newline+        forM_ rows $ \row -> do+          tr_ $+            forM_ (NE.zip calign row) $ \(a, h) ->+              td_ (alignStyle a) (snd h)+          newline+      newline+    newline+  where+    mkId ois = [(id_ . headerId . getOis) ois]+    alignStyle = \case+      CellAlignDefault -> []+      CellAlignLeft    -> [style_ "text-align:left"]+      CellAlignRight   -> [style_ "text-align:right"]+      CellAlignCenter  -> [style_ "text-align:center"]++-- | Apply a render to a given 'Inline'.++applyInlineRender :: Render Inline -> Inline -> Html ()+applyInlineRender r = getRender r defaultInlineRender++-- | The default render for 'Inline' elements. Comments about+-- 'defaultBlockRender' apply here just as well.++defaultInlineRender :: Inline -> Html ()+defaultInlineRender = \case+  Plain txt ->+    toHtml txt+  LineBreak ->+    br_ [] >> newline+  Emphasis inner ->+    em_ (mapM_ defaultInlineRender inner)+  Strong inner ->+    strong_ (mapM_ defaultInlineRender inner)+  Strikeout inner ->+    del_ (mapM_ defaultInlineRender inner)+  Subscript inner ->+    sub_ (mapM_ defaultInlineRender inner)+  Superscript inner ->+    sup_ (mapM_ defaultInlineRender inner)+  CodeSpan txt ->+    code_ (toHtmlRaw txt)+  Link inner dest mtitle ->+    let title = maybe [] (pure . title_) mtitle+    in a_ (href_ (URI.render dest) : title) (mapM_ defaultInlineRender inner)+  Image desc src mtitle ->+    let title = maybe [] (pure . title_) mtitle+    in img_ (alt_ (asPlainText desc) : src_ (URI.render src) : title)++-- | HTML containing a newline.++newline :: Html ()+newline = "\n"

@@ -0,0 +1,234 @@+-- |+-- Module      :  Text.MMark.Type+-- Copyright   :  © 2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Internal type definitions. Some of these are re-exported in the public+-- modules.++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable     #-}+{-# LANGUAGE DeriveFunctor      #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE RecordWildCards    #-}++module Text.MMark.Type+  ( MMark (..)+  , Extension (..)+  , Render (..)+  , Bni+  , Block (..)+  , CellAlign (..)+  , Inline (..)+  , Ois+  , mkOisInternal+  , getOis )+where++import Control.DeepSeq+import Data.Aeson+import Data.Data (Data)+import Data.Function (on)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Monoid hiding ((<>))+import Data.Semigroup+import Data.Text (Text)+import Data.Typeable (Typeable)+import GHC.Generics+import Lucid+import Text.URI (URI (..))++-- | Representation of complete markdown document. You can't look inside of+-- 'MMark' on purpose. The only way to influence an 'MMark' document you+-- obtain as a result of parsing is via the extension mechanism.++data MMark = MMark+  { mmarkYaml :: Maybe Value+    -- ^ Parsed YAML document at the beginning (optional)+  , mmarkBlocks :: [Bni]+    -- ^ Actual contents of the document+  , mmarkExtension :: Extension+    -- ^ Extension specifying how to process and render the blocks+  }++instance NFData MMark where+  rnf MMark {..} = rnf mmarkYaml `seq` rnf mmarkBlocks++-- | An extension. You can apply extensions with 'useExtension' and+-- 'useExtensions' functions. The "Text.MMark.Extension" module provides+-- tools for extension creation.+--+-- Note that 'Extension' is an instance of 'Semigroup' and 'Monoid', i.e.+-- you can combine several extensions into one. Since the @('<>')@ operator+-- is right-associative and 'mconcat' is a right fold under the hood, the+-- expression+--+-- > l <> r+--+-- means that the extension @r@ will be applied before the extension @l@,+-- similar to how 'Endo' works. This may seem counter-intuitive, but only+-- with this logic we get consistency of ordering with more complex+-- expressions:+--+-- > e2 <> e1 <> e0 == e2 <> (e1 <> e0)+--+-- Here, @e0@ will be applied first, then @e1@, then @e2@. The same applies+-- to expressions involving 'mconcat'—extensions closer to beginning of the+-- list passed to 'mconcat' will be applied later.++data Extension = Extension+  { extBlockTrans :: Endo Bni+    -- ^ Block transformation+  , extBlockRender :: Render (Block (Ois, Html ()))+    -- ^ Block render+  , extInlineTrans :: Endo Inline+    -- ^ Inline transformation+  , extInlineRender :: Render Inline+    -- ^ Inline render+  }++instance Semigroup Extension where+  x <> y = Extension+    { extBlockTrans   = on (<>) extBlockTrans   x y+    , extBlockRender  = on (<>) extBlockRender  x y+    , extInlineTrans  = on (<>) extInlineTrans  x y+    , extInlineRender = on (<>) extInlineRender x y }++instance Monoid Extension where+  mempty = Extension+    { extBlockTrans   = mempty+    , extBlockRender  = mempty+    , extInlineTrans  = mempty+    , extInlineRender = mempty }+  mappend = (<>)++-- | An internal type that captures the extensible rendering process we use.+-- 'Render' has a function inside which transforms a rendering function of+-- the type @a -> Html ()@.++newtype Render a = Render+  { getRender :: (a -> Html ()) -> a -> Html () }++instance Semigroup (Render a) where+  Render f <> Render g = Render $ \h -> f (g h)++instance Monoid (Render a) where+  mempty  = Render id+  mappend = (<>)++-- | A shortcut for the frequently used type @'Block' ('NonEmpty'+-- 'Inline')@.++type Bni = Block (NonEmpty Inline)++-- | We can think of a markdown document as a collection of+-- blocks—structural elements like paragraphs, block quotations, lists,+-- headings, thematic breaks, and code blocks. Some blocks (like block+-- quotes and list items) contain other blocks; others (like headings and+-- paragraphs) contain inline content, see 'Inline'.+--+-- We can divide blocks into two types: container blocks, which can contain+-- other blocks, and leaf blocks, which cannot.++data Block a+  = ThematicBreak+    -- ^ Thematic break, leaf block+  | Heading1 a+    -- ^ Heading (level 1), leaf block+  | Heading2 a+    -- ^ Heading (level 2), leaf block+  | Heading3 a+    -- ^ Heading (level 3), leaf block+  | Heading4 a+    -- ^ Heading (level 4), leaf block+  | Heading5 a+    -- ^ Heading (level 5), leaf block+  | Heading6 a+    -- ^ Heading (level 6), leaf block+  | CodeBlock (Maybe Text) Text+    -- ^ Code block, leaf block with info string and contents+  | Naked a+    -- ^ Naked content, without an enclosing tag+  | Paragraph a+    -- ^ Paragraph, leaf block+  | Blockquote [Block a]+    -- ^ Blockquote container block+  | OrderedList Word (NonEmpty [Block a])+    -- ^ Ordered list ('Word' is the start index), container block+  | UnorderedList (NonEmpty [Block a])+    -- ^ Unordered list, container block+  | Table (NonEmpty CellAlign) (NonEmpty (NonEmpty a))+    -- ^ Table, first argument is the alignment options, then we have a+    -- 'NonEmpty' list of rows, where every row is a 'NonEmpty' list of+    -- cells, where every cell is an @a@ thing.+    --+    -- The first row is always the header row, because pipe-tables that we+    -- support cannot lack a header row.+    --+    -- @since 0.0.4.0+  deriving (Show, Eq, Ord, Data, Typeable, Generic, Functor, Foldable)++instance NFData a => NFData (Block a)++-- | Options for cell alignment in tables.+--+-- @since 0.0.4.0++data CellAlign+  = CellAlignDefault   -- ^ No specific alignment specified+  | CellAlignLeft      -- ^ Left-alignment+  | CellAlignRight     -- ^ Right-alignment+  | CellAlignCenter    -- ^ Center-alignment+  deriving (Show, Eq, Ord, Data, Typeable, Generic)++instance NFData CellAlign++-- | Inline markdown content.++data Inline+  = Plain Text+    -- ^ Plain text+  | LineBreak+    -- ^ Line break (hard)+  | Emphasis (NonEmpty Inline)+    -- ^ Emphasis+  | Strong (NonEmpty Inline)+    -- ^ Strong emphasis+  | Strikeout (NonEmpty Inline)+    -- ^ Strikeout+  | Subscript (NonEmpty Inline)+    -- ^ Subscript+  | Superscript (NonEmpty Inline)+    -- ^ Superscript+  | CodeSpan Text+    -- ^ Code span+  | Link (NonEmpty Inline) URI (Maybe Text)+    -- ^ Link with text, destination, and optionally title+  | Image (NonEmpty Inline) URI (Maybe Text)+    -- ^ Image with description, URL, and optionally title+  deriving (Show, Eq, Ord, Data, Typeable, Generic)++instance NFData Inline++-- | A wrapper for “originial inlines”. Source inlines are wrapped in this+-- during rendering of inline components and then it's available to block+-- render, but only for inspection. Altering of 'Ois' is not possible+-- because the user cannot construct a value of the 'Ois' type, she can only+-- inspect it with 'getOis'.++newtype Ois = Ois (NonEmpty Inline)++-- | Make an 'Ois' value. This is an internal constructor that should not be+-- exposed!++mkOisInternal :: NonEmpty Inline -> Ois+mkOisInternal = Ois++-- | Project @'NonEmpty' 'Inline'@ from 'Ois'.++getOis :: Ois -> NonEmpty Inline+getOis (Ois inlines) = inlines

@@ -0,0 +1,67 @@+-- |+-- Module      :  Text.MMark.Util+-- Copyright   :  © 2017 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>+-- Stability   :  experimental+-- Portability :  portable+--+-- Internal utilities.++{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}++module Text.MMark.Util+  ( asPlainText+  , headerId+  , headerFragment )+where++import Data.Char (isSpace, isAlphaNum)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Text (Text)+import Text.MMark.Type+import Text.URI (URI (..))+import qualified Data.Text as T+import qualified Text.URI  as URI++-- | Convert a non-empty collection of 'Inline's into their plain text+-- representation. This is used e.g. to render image descriptions.++asPlainText :: NonEmpty Inline -> Text+asPlainText = foldMap $ \case+  Plain      txt -> txt+  LineBreak      -> "\n"+  Emphasis    xs -> asPlainText xs+  Strong      xs -> asPlainText xs+  Strikeout   xs -> asPlainText xs+  Subscript   xs -> asPlainText xs+  Superscript xs -> asPlainText xs+  CodeSpan   txt -> txt+  Link    xs _ _ -> asPlainText xs+  Image   xs _ _ -> asPlainText xs++-- | Generate value of id attribute for a given header. This is used during+-- rendering and also can be used to get id of a header for linking to it in+-- extensions.+--+-- See also: 'headerFragment'.++headerId :: NonEmpty Inline -> Text+headerId = T.intercalate "-"+  . T.words+  . T.filter (\x -> isAlphaNum x || isSpace x)+  . T.toLower+  . asPlainText++-- | Generate a 'URI' containing only a fragment from its textual+-- representation. Useful for getting URL from id of a header.++headerFragment :: Text -> URI+headerFragment fragment = URI+  { uriScheme    = Nothing+  , uriAuthority = Left False+  , uriPath      = []+  , uriQuery     = []+  , uriFragment  = URI.mkFragment fragment }

@@ -12,10 +12,12 @@   bparser "data/bench-heading.md"   bparser "data/bench-fenced-code-block.md"   bparser "data/bench-indented-code-block.md"+  bparser "data/bench-intensive-emphasis.md"   bparser "data/bench-unordered-list.md"   bparser "data/bench-ordered-list.md"   bparser "data/bench-blockquote.md"   bparser "data/bench-paragraph.md"+  bparser "data/table.md"   bparser "data/comprehensive.md"  ----------------------------------------------------------------------------

@@ -11,10 +11,12 @@   , bparser "data/bench-heading.md"   , bparser "data/bench-fenced-code-block.md"   , bparser "data/bench-indented-code-block.md"+  , bparser "data/bench-intensive-emphasis.md"   , bparser "data/bench-unordered-list.md"   , bparser "data/bench-ordered-list.md"   , bparser "data/bench-blockquote.md"   , bparser "data/bench-paragraph.md"+  , bparser "data/table.md"   , bparser "data/comprehensive.md"   ] 

@@ -0,0 +1,6 @@+*Lorem* **ipsum** _dolor_ __sit__ amet, ****consectetur** adipiscing** elit.+*Integer* **varius** __mi__ _orci_, ^rhoncus^ ~ornare~ ~~nunc~~ *tincidunt*+**nec**. _Aliquam_ __cursus__ ^posuere^ ~ornare~. ~~Quisque~~ *posuere*+**euismod** _nunc_, __sed__ ____pellentesque__ metus__ *hendrerit* **eu**.+^Donec^ ~scelerisque~ ~~accumsan~~ *ante* **quis** _interdum_. __Nullam__+^nec^ ~mauris~ ~~dolor~~.

@@ -0,0 +1,30 @@+<table>+<thead>+<tr><th style="text-align:left">Left-aligned</th><th style="text-align:center">Center-aligned</th><th style="text-align:right">Right-aligned</th><th>Default-aligned</th></tr>+</thead>+<tbody>+<tr><td style="text-align:left">git <em>status</em></td><td style="text-align:center">git status</td><td style="text-align:right">git status</td><td>foo</td></tr>+<tr><td style="text-align:left">git diff</td><td style="text-align:center">git <em>diff</em></td><td style="text-align:right">git diff</td><td>bar</td></tr>+<tr><td style="text-align:left">git status</td><td style="text-align:center">git status</td><td style="text-align:right">git <em>status</em></td><td>baz</td></tr>+<tr><td style="text-align:left">git <em>diff</em></td><td style="text-align:center">git diff</td><td style="text-align:right">git diff</td><td>bar</td></tr>+<tr><td style="text-align:left">git status</td><td style="text-align:center">git <em>status</em></td><td style="text-align:right">git status</td><td>foo</td></tr>+<tr><td style="text-align:left">git diff</td><td style="text-align:center">git diff</td><td style="text-align:right">git <em>diff</em></td><td>bar</td></tr>+<tr><td style="text-align:left">git <em>status</em></td><td style="text-align:center">git status</td><td style="text-align:right">git status</td><td>baz</td></tr>+<tr><td style="text-align:left">git diff</td><td style="text-align:center">git <em>diff</em></td><td style="text-align:right">git diff</td><td>bar</td></tr>+<tr><td style="text-align:left">git status</td><td style="text-align:center">git status</td><td style="text-align:right">git <em>status</em></td><td>foo</td></tr>+<tr><td style="text-align:left">git <em>diff</em></td><td style="text-align:center">git diff</td><td style="text-align:right">git diff</td><td>bar</td></tr>+<tr><td style="text-align:left">git status</td><td style="text-align:center">git <em>status</em></td><td style="text-align:right">git status</td><td>baz</td></tr>+<tr><td style="text-align:left">git diff</td><td style="text-align:center">git diff</td><td style="text-align:right">git <em>diff</em></td><td>bar</td></tr>+<tr><td style="text-align:left">git <em>status</em></td><td style="text-align:center">git status</td><td style="text-align:right">git status</td><td>foo</td></tr>+<tr><td style="text-align:left">git diff</td><td style="text-align:center">git <em>diff</em></td><td style="text-align:right">git diff</td><td>bar</td></tr>+<tr><td style="text-align:left">git status</td><td style="text-align:center">git status</td><td style="text-align:right">git <em>status</em></td><td>baz</td></tr>+<tr><td style="text-align:left">git <em>diff</em></td><td style="text-align:center">git diff</td><td style="text-align:right">git diff</td><td>bar</td></tr>+<tr><td style="text-align:left">git status</td><td style="text-align:center">git <em>status</em></td><td style="text-align:right">git status</td><td>foo</td></tr>+<tr><td style="text-align:left">git diff</td><td style="text-align:center">git diff</td><td style="text-align:right">git <em>diff</em></td><td>bar</td></tr>+<tr><td style="text-align:left">git <em>status</em></td><td style="text-align:center">git status</td><td style="text-align:right">git status</td><td>baz</td></tr>+<tr><td style="text-align:left">git diff</td><td style="text-align:center">git <em>diff</em></td><td style="text-align:right">git diff</td><td>bar</td></tr>+<tr><td style="text-align:left">git status</td><td style="text-align:center">git status</td><td style="text-align:right">git <em>status</em></td><td>foo</td></tr>+<tr><td style="text-align:left">git <em>diff</em></td><td style="text-align:center">git diff</td><td style="text-align:right">git diff</td><td>bar</td></tr>+<tr><td style="text-align:left">git status</td><td style="text-align:center">git <em>status</em></td><td style="text-align:right">git status</td><td>baz</td></tr>+</tbody>+</table>

@@ -0,0 +1,25 @@+| Left-aligned | Center-aligned | Right-aligned | Default-aligned |+| :---         |     :---:      |          ---: | --------------- |+| git *status* | git status     | git status    | foo             |+| git diff     | git *diff*     | git diff      |       bar       |+| git status   | git status     | git *status*  |             baz |+| git _diff_   | git diff       | git diff      |       bar       |+| git status   | git _status_   | git status    | foo             |+| git diff     | git diff       | git _diff_    |       bar       |+| git *status* | git status     | git status    |             baz |+| git diff     | git *diff*     | git diff      |       bar       |+| git status   | git status     | git *status*  | foo             |+| git _diff_   | git diff       | git diff      |       bar       |+| git status   | git _status_   | git status    |             baz |+| git diff     | git diff       | git _diff_    |       bar       |+| git *status* | git status     | git status    | foo             |+| git diff     | git *diff*     | git diff      |       bar       |+| git status   | git status     | git *status*  |             baz |+| git _diff_   | git diff       | git diff      |       bar       |+| git status   | git _status_   | git status    | foo             |+| git diff     | git diff       | git _diff_    |       bar       |+| git *status* | git status     | git status    |             baz |+| git diff     | git *diff*     | git diff      |       bar       |+| git status   | git status     | git *status*  | foo             |+| git _diff_   | git diff       | git diff      |       bar       |+| git status   | git _status_   | git status    |             baz |

@@ -1,5 +1,5 @@ name:                 mmark-version:              0.0.3.2+version:              0.0.4.0 cabal-version:        >= 1.18 tested-with:          GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 license:              BSD3@@ -57,10 +57,12 @@     build-depends:    semigroups       == 0.18.*   exposed-modules:    Text.MMark                     , Text.MMark.Extension-  other-modules:      Text.MMark.Internal-                    , Text.MMark.Parser+  other-modules:      Text.MMark.Parser                     , Text.MMark.Parser.Internal                     , Text.MMark.Parser.Internal.Type+                    , Text.MMark.Render+                    , Text.MMark.Type+                    , Text.MMark.Util   if flag(dev)     ghc-options:      -O0 -Wall -Werror   else

@@ -1800,6 +1800,57 @@         in s ~-> err (posN 23 s)            (utoks "so" <> etok '\'' <> etok '\"' <> etok '(' <>             elabel "white space" <> elabel "newline")+    context "tables" $ do+      it "recognizes single column tables" $ do+        let o = "<table>\n<thead>\n<tr><th>Foo</th></tr>\n</thead>\n<tbody>\n<tr><td>foo</td></tr>\n</tbody>\n</table>\n"+        "|Foo\n---\nfoo" ==-> o+        "Foo|\n---\nfoo" ==-> o+        "| Foo |\n  ---  \n  foo  " ==-> o+        "| Foo |\n| --- |\n| foo |" ==-> o+      it "reports correct parse errors when parsing the header line" $+        (let s = "Foo | Bar\na-- | ---"+         in s ~-> err (posN 10 s) (utok 'a' <> etok '-' <> etok ':' <> etok '|' <> elabel "white space"))+        >>+        (let s = "Foo | Bar\n-a- | ---"+         in s ~-> err (posN 11 s) (utok 'a' <> etok '-'))+        >>+        (let s = "Foo | Bar\n--a | ---"+         in s ~-> err (posN 12 s) (utok 'a' <> etok '-'))+        >>+        (let s = "Foo | Bar\n---a | ---"+         in s ~-> err (posN 13 s) (utok 'a' <> etok '-' <> etok ':' <> etok '|' <> elabel "white space"))+      it "falls back to paragraph when header line is weird enough" $+        "Foo | Bar\nab- | ---" ==->+          "<p>Foo | Bar\nab- | ---</p>\n"+      it "demands that number of columns in rows match number of columns in header" $+        (let s = "Foo | Bar | Baz\n--- | --- | ---\nfoo | bar"+         in s ~-> err (posN 41 s) (ueof <> etok '|' <> eic))+        >>+        (let s = "Foo | Bar | Baz\n--- | --- | ---\nfoo | bar\n\nHere it goes."+         in s ~-> err (posN 41 s) (utok '\n' <> etok '|' <> eic))+      it "recognizes escaped pipes" $+        "Foo \\| | Bar\n--- | ---\nfoo | \\|" ==->+          "<table>\n<thead>\n<tr><th>Foo |</th><th>Bar</th></tr>\n</thead>\n<tbody>\n<tr><td>foo</td><td>|</td></tr>\n</tbody>\n</table>\n"+      it "escaped characters preserve backslashes for inline-level parser" $+        "Foo | Bar\n--- | ---\n\\*foo\\* | bar" ==->+          "<table>\n<thead>\n<tr><th>Foo</th><th>Bar</th></tr>\n</thead>\n<tbody>\n<tr><td>*foo*</td><td>bar</td></tr>\n</tbody>\n</table>\n"+      it "escaped pipes do not fool position tracking" $+        let s = "Foo | Bar\n--- | ---\n\\| *fo | bar"+        in s ~-> err (posN 26 s) (ueib <> etok '*' <> elabel "inline content")+      it "parses tables with just header row" $+        "Foo | Bar\n--- | ---" ==->+          "<table>\n<thead>\n<tr><th>Foo</th><th>Bar</th></tr>\n</thead>\n<tbody>\n</tbody>\n</table>\n"+      it "recognizes end of table correctly" $+        "Foo | Bar\n--- | ---\nfoo | bar\n\nHere goes a paragraph." ==->+          "<table>\n<thead>\n<tr><th>Foo</th><th>Bar</th></tr>\n</thead>\n<tbody>\n<tr><td>foo</td><td>bar</td></tr>\n</tbody>\n</table>\n<p>Here goes a paragraph.</p>\n"+      it "is capable of reporting a parse error per cell" $+        let s = "Foo | *Bar\n--- | ----\n_foo | bar_"+        in s ~~->+           [ err (posN 10 s) (ueib <> etok '*' <> eic)+           , err (posN 26 s) (ueib <> etok '_' <> eic)+           , errFancy (posN 32 s) (nonFlanking "_") ]+      it "renders a comprehensive table correctly" $+        withFiles "data/table.md" "data/table.html"     context "multiple parse errors" $ do       it "they are reported in correct order" $ do         let s = "Foo `\n\nBar `.\n"