diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +## MMark 0.0.2.0 + +* Now punctuation is stripped from header ids in + `Text.MMark.Extension.headerId`. + +* Added `scannerM` in `Text.MMark.Extension` and `runScannerM` in + `Text.MMark`. + +* Added support for block quotes. + +* Added support for unordered and ordered lists. + ## MMark 0.0.1.1 * Fixed a bug in skipping of headers (only one newline after the header line diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -174,14 +174,24 @@ Block-level parsing: -* Headings, thematic breaks, code blocks should be separated from paragraphs - by at least one empty line. This makes the parser a lot simpler and forces - markdown sources to be in a more readable form too. +* Code blocks should be separated from paragraphs and lists by at least one + empty line. * If a line starts with hash signs it is expected to be a valid *non-empty* header (level 1–6 inclusive). If you want to start a paragraph with hashes, just escape the first hash with backslash and that will be enough. +* Setext headings are not supported for the sake of simplicity. * Fenced code blocks must be explicitly closed by a closing fence. They are not closed by the end of document or by start of another block. +* Lists and block quotes are defined by column at which their content + starts. Content belonging to a particular list or block quote should start + at the same column (or greater column, up to the column where indented + code blocks start). As a consequence of this, block quotes do not feature + “laziness” +* Block quotes are started by a single `>` character, it's not necessary to + put a `>` character at beginning of every line belonging to a quote (in + fact, this would make every line a separate block quote). +* Paragraphs can be interrupted by unordered list and ordered lists with any + valid starting index. Inline-level parsing: @@ -201,9 +211,6 @@ Not-yet-implemented things: * Separate declaration of image's source and title is not (yet?) supported. -* Blockquotes are not implemented yet. -* Lists (unordered and ordered) are not implemented yet. -* Setext headings are not implemented yet. * Reference links are not implemented yet. * HTML blocks are not implemented yet. * HTML inlines are not implemented yet. diff --git a/Text/MMark.hs b/Text/MMark.hs --- a/Text/MMark.hs +++ b/Text/MMark.hs @@ -63,14 +63,53 @@ -- The structure of the documentation below corresponds to these stages and -- should clarify the details. -- +-- === “Getting started” example +-- +-- Here is a complete example of a program that reads a markdown file named +-- @\"input.md\"@ and outputs an HTML file named @\"output.md\"@: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > module Main (main) where +-- > +-- > import qualified Data.Text.IO as T +-- > import qualified Data.Text.Lazy.IO as TL +-- > import qualified Lucid as L +-- > import qualified Text.MMark as MMark +-- > +-- > main :: IO () +-- > main = do +-- > let input = "input.md" +-- > txt <- T.readFile input -- (1) +-- > case MMark.parse input txt of -- (2) +-- > Left errs -> putStrLn (MMark.parseErrorsPretty txt errs) -- (3) +-- > Right r -> TL.writeFile "output.html" -- (6) +-- > . L.renderText -- (5) +-- > . MMark.render -- (4) +-- > $ r +-- +-- Let's break it down: +-- +-- 1. We read a source markdown file as strict 'Text'. +-- 2. The source is fed into the 'parse' function which does the +-- parsing. It can either fail with a collection of parse errors +-- or succeed returning a value of the opaque 'MMark' type. +-- 3. If parsing fails, we pretty-print the parse errors with +-- 'parseErrorsPretty'. +-- 4. Then we just render the document with `render` first to Lucid's +-- @'Lucid.Html' ()@. +-- 5. …and then to lazy 'Data.Text.Lazy.Text' with 'Lucid.renderText'. +-- 6. Finally we write the result as @\"output.html\"@. +-- -- === Other modules of interest -- --- This module contains all the “core” functionality you may need. However, --- one of the main selling points of MMark is that it's possible to write --- your own extensions which stay highly composable (if done right), so --- proliferation of third-party extensions is to be expected and encouraged. --- To write an extension of your own import the "Text.MMark.Extension" --- module, which has some documentation focusing on extension writing. +-- The "Text.MMark" module contains all the “core” functionality you may +-- need. However, one of the main selling points of MMark is that it's +-- possible to write your own extensions which stay highly composable (if +-- done right), so proliferation of third-party extensions is to be expected +-- and encouraged. To write an extension of your own import the +-- "Text.MMark.Extension" module, which has some documentation focusing on +-- extension writing. module Text.MMark ( -- * Parsing @@ -84,6 +123,7 @@ , useExtensions -- * Scanning , runScanner + , runScannerM , projectYaml -- * Rendering , render ) diff --git a/Text/MMark/Extension.hs b/Text/MMark/Extension.hs --- a/Text/MMark/Extension.hs +++ b/Text/MMark/Extension.hs @@ -53,6 +53,7 @@ , inlineRender -- * Scanner construction , scanner + , scannerM -- * Utils , asPlainText , headerId @@ -111,3 +112,16 @@ -> L.Fold Bni a -- ^ Resulting 'L.Fold' scanner a f = L.Fold f a id {-# INLINE scanner #-} + +-- | Create a 'L.FoldM' from an initial state and a folding function +-- operating in monadic context. +-- +-- @since 0.0.2.0 + +scannerM + :: Monad m + => m a -- ^ Initial state + -> (a -> Bni -> m a) -- ^ Folding function + -> L.FoldM m Bni a -- ^ Resulting 'L.FoldM' +scannerM a f = L.FoldM f a return +{-# INLINE scannerM #-} diff --git a/Text/MMark/Internal.hs b/Text/MMark/Internal.hs --- a/Text/MMark/Internal.hs +++ b/Text/MMark/Internal.hs @@ -27,6 +27,7 @@ , Inline (..) -- * Extensions , runScanner + , runScannerM , useExtension , useExtensions -- * Renders @@ -46,7 +47,7 @@ import Control.DeepSeq import Control.Monad import Data.Aeson -import Data.Char (isSpace) +import Data.Char (isSpace, isAlphaNum) import Data.Data (Data) import Data.Function (on) import Data.List.NonEmpty (NonEmpty (..)) @@ -163,8 +164,8 @@ -- ^ Paragraph, leaf block | Blockquote [Block a] -- ^ Blockquote container block - | OrderedList (NonEmpty [Block a]) - -- ^ Ordered list, 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 @@ -238,6 +239,21 @@ runScanner MMark {..} f = L.fold f mmarkBlocks {-# INLINE runScanner #-} +-- | 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 +{-# INLINE runScannerM #-} + ---------------------------------------------------------------------------- -- Renders @@ -320,24 +336,26 @@ newline Paragraph (_,html) -> p_ html >> newline - Blockquote blocks -> - blockquote_ (mapM_ defaultBlockRender blocks) - OrderedList items -> do - ol_ $ do + 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_ (mapM_ defaultBlockRender x) + li_ (newline <* mapM_ defaultBlockRender x) newline newline UnorderedList items -> do ul_ $ do newline forM_ items $ \x -> do - li_ (mapM_ defaultBlockRender x) + li_ (newline <* mapM_ defaultBlockRender x) newline newline Naked (_,html) -> - html + html >> newline where mkId (Ois x) = [id_ (headerId x)] @@ -405,7 +423,11 @@ -- See also: 'headerFragment'. headerId :: NonEmpty Inline -> Text -headerId = T.intercalate "-" . T.words . T.toLower . asPlainText +headerId = T.intercalate "-" + . T.words + . T.filter (\x -> isAlphaNum x || isSpace x) + . T.toLower + . asPlainText -- | Generate a 'URI' with just fragment from its textual representation. -- Useful for getting URL from id of a header. diff --git a/Text/MMark/Parser.hs b/Text/MMark/Parser.hs --- a/Text/MMark/Parser.hs +++ b/Text/MMark/Parser.hs @@ -7,7 +7,7 @@ -- Stability : experimental -- Portability : portable -- --- MMark parser. +-- MMark markdown parser. {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} @@ -30,13 +30,15 @@ import Control.Applicative import Control.DeepSeq import Control.Monad +import Control.Monad.Reader import Control.Monad.State.Strict import Data.Bifunctor (Bifunctor (..)) import Data.Data (Data) import Data.Default.Class import Data.List.NonEmpty (NonEmpty (..), (<|)) import Data.Maybe (isNothing, fromJust, fromMaybe) -import Data.Semigroup ((<>)) +import Data.Monoid (Any (..)) +import Data.Semigroup (Semigroup (..)) import Data.Text (Text) import Data.Typeable (Typeable) import Data.Void @@ -59,15 +61,38 @@ ---------------------------------------------------------------------------- -- Data types --- | Parser type we use internally. +-- | Block-level parser type. -type Parser = Parsec MMarkErr Text +type BParser = ParsecT MMarkErr Text (Reader BlockEnv) +-- | Block-level parser environment. + +data BlockEnv = BlockEnv + { benvAllowNaked :: !Bool + -- ^ Should we consider a paragraph that does not end with a blank line + -- 'Naked'? It does not make sense to do so for top-level document, but + -- in lists, 'Naked' text is pretty common. + , benvRefLevel :: !Pos + -- ^ Current reference level: 1 column for top-level of document, column + -- where content starts for block quotes and lists. + } + +instance Default BlockEnv where + def = BlockEnv + { benvAllowNaked = False + , benvRefLevel = pos1 + } + -- | MMark custom parse errors. data MMarkErr = YamlParseError String -- ^ YAML error that occurred during parsing of a YAML block + | ListStartIndexTooBig Word + -- ^ Ordered list start numbers must be nine digits or less + | 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 deriving (Eq, Ord, Show, Read, Generic, Typeable, Data) @@ -76,24 +101,35 @@ showErrorComponent = \case YamlParseError str -> "YAML parse error: " ++ str + 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 " + ++ show expected NonFlankingDelimiterRun dels -> showTokens dels ++ " should be in left- or right- flanking position" instance NFData MMarkErr --- | Parser type for inlines. +-- | Inline-level parser type. We store type of the last consumed character +-- in the state. type IParser = StateT CharType (Parsec MMarkErr Text) -- | 'Inline' source pending parsing. -data Isp = Isp SourcePos Text - deriving (Eq, Ord, Show) +data Isp + = IspSpan SourcePos Text + -- ^ We have an inline source pending parsing + | IspError (ParseError Char MMarkErr) + -- ^ We should just return this parse error + deriving (Eq, Show) -- | Type of last seen character. data CharType - = SpaceChar -- ^ White space + = SpaceChar -- ^ White space or a transparent character | LeftFlankingDel -- ^ Left flanking delimiter | RightFlankingDel -- ^ Right flaking delimiter | OtherChar -- ^ Other character @@ -119,7 +155,7 @@ | DoubleFrame InlineFrame InlineFrame -- ^ Two frames to be closed deriving (Eq, Ord, Show) --- | Configuration in inline parser. +-- | Configuration of inline parser. data InlineConfig = InlineConfig { iconfigAllowEmpty :: !Bool @@ -137,16 +173,27 @@ , iconfigAllowImages = True } --- | A shortcut type synonym for sub-parsers that may fail and we can --- recover from the failure. +-- | An auxiliary type for collapsing levels of 'Either's. -type E = Either (ParseError Char MMarkErr) +data Pair s a + = PairL s + | PairR ([a] -> [a]) +instance Semigroup s => Semigroup (Pair s a) where + (PairL l) <> (PairL r) = PairL (l <> r) + (PairL l) <> (PairR _) = PairL l + (PairR _) <> (PairL r) = PairL r + (PairR l) <> (PairR r) = PairR (l . r) + +instance Semigroup s => Monoid (Pair s a) where + mempty = PairR id + mappend = (<>) + ---------------------------------------------------------------------------- --- Block parser +-- Top-level API -- | Parse a markdown document in the form of a strict 'Text' value and --- either report parse errors or return a 'MMark' document. Note that the +-- either report parse errors or return an 'MMark' document. Note that the -- parser has the ability to report multiple parse errors at once. parse @@ -157,30 +204,51 @@ -> Either (NonEmpty (ParseError Char MMarkErr)) MMark -- ^ Parse errors or parsed document parse file input = - case runParser ((,) <$> optional pYamlBlock <*> pBlocks) file input of + case runReader (runParserT pMMark file input) def of -- NOTE This parse error only happens when document structure on block -- level cannot be parsed even with recovery, which should not normally - -- happen. + -- happen except for the cases when we deal with YAML parsing errors. Left err -> Left (nes err) - Right (myaml, blocks) -> - let parsed = doInline <$> blocks - doInline = \case - Left err -> Naked (Left err) - Right x -> first (replaceEof "end of inline block") - . runIsp (pInlines def <* eof) <$> x - getErrs (Left e) es = e : es - getErrs _ es = es - fromRight (Right x) = x - fromRight _ = - error "Text.MMark.Parser.parse: the impossible happened" - in case NE.nonEmpty (foldMap (foldr getErrs []) parsed) of - Nothing -> Right MMark + Right (myaml, rawBlocks) -> + let parsed = doInline <$> rawBlocks + doInline = fmap + $ first (nes . replaceEof "end of inline block") + . runIsp (pInlines def <* eof) + f block = + case foldMap e2p block of + PairL errs -> PairL errs + PairR _ -> PairR (fmap fromRight block :) + in case foldMap f parsed of + PairL errs -> Left errs + PairR blocks -> Right MMark { mmarkYaml = myaml - , mmarkBlocks = fmap fromRight <$> parsed + , mmarkBlocks = blocks [] , mmarkExtension = mempty } - Just es -> Left es -pYamlBlock :: Parser Yaml.Value +---------------------------------------------------------------------------- +-- Block parser + +-- | Parse an MMark document on block level. + +pMMark :: BParser (Maybe Yaml.Value, [Block Isp]) +pMMark = do + meyaml <- optional pYamlBlock + setTabWidth (mkPos 4) + blocks <- pBlocks + eof + return $ case meyaml of + Nothing -> + (Nothing, blocks) + Just (Left (pos, err)) -> + (Nothing, prependErr pos (YamlParseError err) blocks) + Just (Right yaml) -> + (Just yaml, blocks) + +-- | Parse a YAML block. On success return the actual parsed 'Yaml.Value' in +-- 'Right', otherwise return 'SourcePos' of parse error and 'String' +-- describing the error as generated by the @yaml@ package in 'Left'. + +pYamlBlock :: BParser (Either (SourcePos, String) Yaml.Value) pYamlBlock = do dpos <- getPosition string "---" *> sc' *> eol @@ -195,37 +263,56 @@ case (Yaml.decodeEither . TE.encodeUtf8 . T.intercalate "\n") ls of Left err' -> do let (apos, err) = splitYamlError (sourceName dpos) err' - setPosition (fromMaybe dpos apos) - (fancyFailure . E.singleton . ErrorCustom . YamlParseError) err + return $ Left (fromMaybe dpos apos, err) Right v -> - return v + return (Right v) -pBlocks :: Parser [E (Block Isp)] -pBlocks = do - setTabWidth (mkPos 4) - sc *> manyTill pBlock eof +-- | Parse several (possibly zero) blocks in a row. -pBlock :: Parser (E (Block Isp)) -pBlock = choice - [ try (pure <$> pThematicBreak) - , pAtxHeading - , pure <$> pFencedCodeBlock - , try (pure <$> pIndentedCodeBlock) - , pure <$> pParagraph ] +pBlocks :: BParser [Block Isp] +pBlocks = many pBlock -pThematicBreak :: Parser (Block Isp) +-- | Parse a single block of markdown document. + +pBlock :: BParser (Block Isp) +pBlock = do + sc + rlevel <- asks benvRefLevel + alevel <- L.indentLevel + done <- atEnd + if done || alevel < rlevel then empty else + case compare alevel (ilevel rlevel) of + LT -> choice + [ pThematicBreak + , pAtxHeading + , pFencedCodeBlock + , pUnorderedList + , pOrderedList + , pBlockquote + , pParagraph ] + _ -> + pIndentedCodeBlock + +-- | Parse a thematic break. + +pThematicBreak :: BParser (Block Isp) pThematicBreak = do - void casualLevel - l <- lookAhead nonEmptyLine - if isThematicBreak l + l' <- lookAhead nonEmptyLine + let l = T.filter (not . isSpace) l' + if T.length l >= 3 && + (T.all (== '*') l || + T.all (== '-') l || + T.all (== '_') l) then ThematicBreak <$ nonEmptyLine <* sc else empty -pAtxHeading :: Parser (E (Block Isp)) +-- | Parse an ATX heading. + +pAtxHeading :: BParser (Block Isp) pAtxHeading = do - (void . lookAhead . try) start + (void . lookAhead . try) hashIntro withRecovery recover $ do - hlevel <- length <$> start + hlevel <- length <$> hashIntro sc1' ispPos <- getPosition r <- someTill (satisfy notNewline "heading character") . try $ @@ -237,19 +324,21 @@ 4 -> Heading4 5 -> Heading5 _ -> Heading6 - (Right . toBlock) (Isp ispPos (T.strip (T.pack r))) <$ sc + toBlock (IspSpan ispPos (T.strip (T.pack r))) <$ sc where - start = casualLevel *> count' 1 6 (char '#') + hashIntro = count' 1 6 (char '#') recover err = - Left err <$ takeWhileP Nothing notNewline <* sc + Heading1 (IspError err) <$ takeWhileP Nothing notNewline <* sc -pFencedCodeBlock :: Parser (Block Isp) +-- | Parse a fenced code block. + +pFencedCodeBlock :: BParser (Block Isp) pFencedCodeBlock = do - level <- casualLevel let p ch = try $ do void $ count 3 (char ch) n <- (+ 3) . length <$> many (char ch) - ml <- optional (T.strip <$> someEscapedWith notNewline "info string") + ml <- optional + (T.strip <$> someEscapedWith notNewline "info string") guard (maybe True (not . T.any (== '`')) ml) return (ch, n, @@ -259,60 +348,211 @@ if T.null l then Nothing else Just l) + alevel <- L.indentLevel (ch, n, infoString) <- (p '`' <|> p '~') <* eol let content = label "code block content" (option "" nonEmptyLine <* eol) closingFence = try . label "closing code fence" $ do - void casualLevel' + clevel <- ilevel <$> asks benvRefLevel + void $ L.indentGuard sc' LT clevel void $ count n (char ch) (void . many . char) ch sc' eof <|> eol ls <- manyTill content closingFence - CodeBlock infoString (assembleCodeBlock level ls) <$ sc + CodeBlock infoString (assembleCodeBlock alevel ls) <$ sc -pIndentedCodeBlock :: Parser (Block Isp) +-- | Parse an indented code block. + +pIndentedCodeBlock :: BParser (Block Isp) pIndentedCodeBlock = do - initialIndent <- codeBlockLevel + alevel <- L.indentLevel + clevel <- ilevel <$> asks benvRefLevel let go ls = do - immediate <- lookAhead (True <$ try codeBlockLevel' <|> pure False) - eventual <- lookAhead (True <$ try codeBlockLevel <|> pure False) - if not immediate && not eventual - then return ls - else do + immediate <- lookAhead $ + (>= clevel) <$> (sc' *> L.indentLevel) + eventual <- lookAhead $ + (>= clevel) <$> (sc *> L.indentLevel) + if immediate || eventual + then do l <- option "" nonEmptyLine continue <- eol' if continue then go (l:ls) else return (l:ls) + else return ls -- NOTE This is a bit unfortunate, but it's difficult to guarantee -- that preceding space is not yet consumed when we get to -- interpreting input as an indented code block, so we need to restore -- the space this way. - f x = T.replicate (unPos initialIndent - 1) " " <> x + f x = T.replicate (unPos alevel - 1) " " <> x g [] = [] g (x:xs) = f x : xs ls <- g . reverse . dropWhile isBlank <$> go [] - CodeBlock Nothing (assembleCodeBlock (mkPos 5) ls) <$ sc + CodeBlock Nothing (assembleCodeBlock clevel ls) <$ sc -pParagraph :: Parser (Block Isp) +-- | Parse an unorederd list. + +pUnorderedList :: BParser (Block Isp) +pUnorderedList = do + (bullet, bulletPos, minLevel, indLevel) <- + pListBullet Nothing + x <- innerBlocks bulletPos minLevel indLevel + xs <- many $ do + (_, bulletPos', minLevel', indLevel') <- + pListBullet (Just (bullet, bulletPos)) + innerBlocks bulletPos' minLevel' indLevel' + return (UnorderedList (normalizeListItems (x:|xs))) + where + innerBlocks bulletPos minLevel indLevel = do + p <- getPosition + let tooFar = sourceLine p > sourceLine bulletPos <> pos1 + rlevel = slevel minLevel indLevel + if tooFar || sourceColumn p < minLevel + then return [if tooFar then emptyParagraph else emptyNaked] + else subEnv True rlevel pBlocks + +-- | Parse a list bullet. Return a tuple with the following components (in +-- order): +-- +-- * 'Char' used to represent the bullet +-- * 'SourcePos' at which the bullet was located +-- * the closest column position where content could start +-- * the indentation level after the bullet + +pListBullet + :: Maybe (Char, SourcePos) + -- ^ 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 <- + case mbullet of + Nothing -> char '-' <|> char '+' <|> char '*' + Just (bullet, bulletPos) -> do + guard (sourceColumn pos >= sourceColumn bulletPos) + char bullet + eof <|> sc1 + l' <- L.indentLevel + return (bullet, pos, l, l') + +-- | Parse an ordered list. + +pOrderedList :: BParser (Block Isp) +pOrderedList = do + (startIx, del, startPos, minLevel, indLevel) <- + pListIndex Nothing + x <- innerBlocks startPos minLevel indLevel + xs <- manyIndexed (startIx + 1) $ \expectedIx -> do + (actualIx, _, startPos', minLevel', indLevel') <- + pListIndex (Just (del, startPos)) + let f blocks = + if actualIx == expectedIx + then blocks + else prependErr + startPos' + (ListIndexOutOfOrder actualIx expectedIx) + blocks + f <$> innerBlocks startPos' minLevel' indLevel' + return . OrderedList startIx . normalizeListItems $ + (if startIx <= 999999999 + then x + else prependErr startPos (ListStartIndexTooBig startIx) x) + :| xs + where + innerBlocks indexPos minLevel indLevel = do + p <- getPosition + let tooFar = sourceLine p > sourceLine indexPos <> pos1 + rlevel = slevel minLevel indLevel + if tooFar || sourceColumn p < minLevel + then return [if tooFar then emptyParagraph else emptyNaked] + else subEnv True rlevel pBlocks + +-- | Parse a list index. Return a tuple with the following components (in +-- order): +-- +-- * 'Word' parsed numeric index +-- * 'Char' used as delimiter after the numeric index +-- * 'SourcePos' at which the index was located +-- * the closest column position where content could start +-- * the indentation level after the index + +pListIndex + :: Maybe (Char, SourcePos) + -- ^ Delimiter 'Char' and start position of the first index in a list + -> BParser (Word, Char, SourcePos, Pos, Pos) +pListIndex mstart = try $ do + pos <- getPosition + i <- L.decimal + del <- case mstart of + Nothing -> char '.' <|> char ')' + Just (del, startPos) -> do + guard (sourceColumn pos >= sourceColumn startPos) + char del + l <- (<> pos1) <$> L.indentLevel + eof <|> sc1 + l' <- L.indentLevel + return (i, del, pos, l, l') + +-- | Parse a block quote. + +pBlockquote :: BParser (Block Isp) +pBlockquote = do + minLevel <- try $ do + minLevel <- (<> pos1) <$> L.indentLevel + void (char '>') + eof <|> sc + l <- L.indentLevel + return $ + if l > minLevel + then minLevel <> pos1 + else minLevel + indLevel <- L.indentLevel + if indLevel >= minLevel + then do + let rlevel = slevel minLevel indLevel + xs <- subEnv False rlevel pBlocks + return (Blockquote xs) + else return (Blockquote []) + +-- | Parse a paragraph or naked text (is some cases). + +pParagraph :: BParser (Block Isp) pParagraph = do - void casualLevel - startPos <- getPosition - let go = do - ml <- lookAhead (optional nonEmptyLine) - case ml of - Nothing -> return [] - Just l -> - if isBlank l - then return [] - else do - void nonEmptyLine - continue <- eol' - (l :) <$> if continue then go else return [] + startPos <- getPosition + allowNaked <- asks benvAllowNaked + rlevel <- asks benvRefLevel + let go ls = do + l <- lookAhead (option "" nonEmptyLine) + broken <- succeeds . lookAhead . try $ do + sc + alevel <- L.indentLevel + guard (alevel < ilevel rlevel) + unless (alevel < rlevel) . choice $ + [ void (char '>') + , void pThematicBreak + , void pAtxHeading + , void (pListBullet Nothing) + , void (pListIndex Nothing) ] + if isBlank l + then return (ls, Paragraph) + else if broken + then return (ls, Naked) + else do + void nonEmptyLine + continue <- eol' + let ls' = ls . (l:) + if continue + then go ls' + else return (ls', Naked) l <- nonEmptyLine continue <- eol' - ls <- if continue then go else return [] - Paragraph (Isp startPos (assembleParagraph (l:ls))) <$ sc + (ls, toBlock) <- + if continue + then go id + else return (id, Naked) + (if allowNaked then toBlock else Paragraph) + (IspSpan startPos (assembleParagraph (l:ls []))) <$ sc ---------------------------------------------------------------------------- -- Inline parser @@ -323,7 +563,8 @@ :: IParser a -- ^ The parser to run -> Isp -- ^ Input for the parser -> Either (ParseError Char MMarkErr) a -- ^ Result of parsing -runIsp p (Isp startPos input) = +runIsp _ (IspError err) = Left err +runIsp p (IspSpan startPos input) = snd (runParser' (evalStateT p SpaceChar) pst) where pst = State @@ -332,6 +573,8 @@ , stateTokensProcessed = 0 , stateTabWidth = mkPos 4 } +-- | Parse inlines using settings from given 'InlineConfig'. + pInlines :: InlineConfig -> IParser (NonEmpty Inline) pInlines InlineConfig {..} = if iconfigAllowEmpty @@ -348,6 +591,8 @@ , pPlain ] angel = between (char '<') (char '>') +-- | Parse a code span. + pCodeSpan :: IParser Inline pCodeSpan = do n <- try (length <$> some (char '`')) @@ -362,6 +607,8 @@ put OtherChar return r +-- | Parse a link. + pInlineLink :: IParser Inline pInlineLink = do xs <- between (char '[') (char ']') $ @@ -373,6 +620,8 @@ put OtherChar return (Link xs dest mtitle) +-- | Parse an image. + pImage :: IParser Inline pImage = do let nonEmptyDesc = char '!' *> between (char '[') (char ']') @@ -385,6 +634,8 @@ put OtherChar return (Image alt src mtitle) +-- | Parse a URI. + pUri :: IParser URI pUri = do uri <- between (char '<') (char '>') URI.parser <|> naked @@ -411,6 +662,8 @@ fancyFailure xs Right x -> return x +-- | Parse a title of a link or an image. + pTitle :: IParser Text pTitle = choice [ p '\"' '\"' @@ -420,6 +673,8 @@ p start end = between (char start) (char end) $ manyEscapedWith (/= end) "unescaped character" +-- | Parse an autolink. + pAutolink :: IParser Inline pAutolink = do notFollowedBy (char '>') -- empty links don't make sense @@ -434,6 +689,9 @@ uri' = URI.makeAbsolute mailtoScheme uri in Link txt uri' Nothing +-- | Parse inline content inside some sort of emphasis, strikeout, +-- superscript, and\/or subscript markup. + pEnclosedInline :: IParser Inline pEnclosedInline = do let noEmpty = def { iconfigAllowEmpty = False } @@ -467,15 +725,17 @@ return . liftFrame thatFrame $ liftFrame thisFrame inlines0 <| inlines1 +-- | Parse an opening markup sequence corresponding to given 'InlineState' + pLfdr :: InlineState -> IParser InlineState pLfdr st = try $ do let dels = inlineStateDel st - mpos <- getNextTokenPosition + pos <- getPosition void (string dels) leftChar <- get mrightChar <- lookAhead (optional anyChar) let failNow = do - forM_ mpos setPosition + setPosition pos (mmarkErr . NonFlankingDelimiterRun . toNesTokens) dels case (leftChar, isTransparent <$> mrightChar) of (_, Nothing) -> failNow @@ -487,15 +747,17 @@ put LeftFlankingDel return st +-- | Parse a closing markdup sequence corresponding to given 'InlineFrame'. + pRfdr :: InlineFrame -> IParser InlineFrame pRfdr frame = try $ do let dels = inlineFrameDel frame - mpos <- getNextTokenPosition + pos <- getPosition void (string dels) leftChar <- get mrightChar <- lookAhead (optional anyChar) let failNow = do - forM_ mpos setPosition + setPosition pos (mmarkErr . NonFlankingDelimiterRun . toNesTokens) dels case (leftChar, mrightChar) of (SpaceChar, _) -> failNow @@ -508,6 +770,8 @@ put RightFlankingDel return frame +-- | Parse a hard line break. + pHardLineBreak :: IParser Inline pHardLineBreak = do void (char '\\') @@ -517,6 +781,8 @@ put SpaceChar return LineBreak +-- | Parse plain text. + pPlain :: IParser Inline pPlain = Plain . T.pack <$> some (pEscapedChar <|> pNewline <|> pNonEscapedChar) @@ -537,19 +803,7 @@ ---------------------------------------------------------------------------- -- Parsing helpers -casualLevel :: Parser Pos -casualLevel = L.indentGuard sc LT (mkPos 5) - -casualLevel' :: Parser Pos -casualLevel' = L.indentGuard sc' LT (mkPos 5) - -codeBlockLevel :: Parser Pos -codeBlockLevel = L.indentGuard sc GT (mkPos 4) - -codeBlockLevel' :: Parser Pos -codeBlockLevel' = L.indentGuard sc' GT (mkPos 4) - -nonEmptyLine :: Parser Text +nonEmptyLine :: BParser Text nonEmptyLine = takeWhile1P Nothing notNewline manyEscapedWith :: MonadParsec e Text m => (Char -> Bool) -> String -> m Text @@ -583,20 +837,18 @@ eol' :: MonadParsec e Text m => m Bool eol' = option False (True <$ eol) ----------------------------------------------------------------------------- --- Block-level predicates - -isThematicBreak :: Text -> Bool -isThematicBreak l' = T.length l >= 3 && indentLevel l' < 4 && - (T.all (== '*') l || - T.all (== '-') l || - T.all (== '_') l) - where - l = T.filter (not . isSpace) l' +subEnv :: Bool -> Pos -> BParser a -> BParser a +subEnv benvAllowNaked benvRefLevel = local (const BlockEnv {..}) ---------------------------------------------------------------------------- -- Other helpers +slevel :: Pos -> Pos -> Pos +slevel a l = if l >= ilevel a then a else l + +ilevel :: Pos -> Pos +ilevel = (<> mkPos 4) + isSpace :: Char -> Bool isSpace x = x == ' ' || x == '\t' @@ -648,31 +900,14 @@ isTransparent :: Char -> Bool isTransparent x = Char.isSpace x || isTransparentPunctuation x -nes :: a -> NonEmpty a -nes a = a :| [] - -assembleParagraph :: [Text] -> Text -assembleParagraph = go - where - go [] = "" - go [x] = T.dropWhileEnd isSpace x - go (x:xs) = x <> "\n" <> go xs - assembleCodeBlock :: Pos -> [Text] -> Text assembleCodeBlock indent ls = T.unlines (stripIndent indent <$> ls) -indentLevel :: Text -> Int -indentLevel = T.foldl' f 0 . T.takeWhile isSpace - where - f n ch - | ch == ' ' = n + 1 - | ch == '\t' = n + 4 - | otherwise = n - stripIndent :: Pos -> Text -> Text stripIndent indent txt = T.drop m txt where - m = snd $ T.foldl' f (0, 0) (T.takeWhile isSpace txt) + m = snd $ T.foldl' f (0, 0) (T.takeWhile p txt) + p x = isSpace x || x == '>' f (!j, !n) ch | j >= i = (j, n) | ch == ' ' = (j + 1, n + 1) @@ -680,6 +915,13 @@ | otherwise = (j, n) i = unPos indent - 1 +assembleParagraph :: [Text] -> Text +assembleParagraph = go + where + go [] = "" + go [x] = T.dropWhileEnd isSpace x + go (x:xs) = x <> "\n" <> go xs + collapseWhiteSpace :: Text -> Text collapseWhiteSpace = T.stripEnd . T.filter (/= '\0') . snd . T.mapAccumL f True @@ -728,12 +970,6 @@ f EndOfInput = Label (NE.fromList altLabel) f x = x -mmarkErr :: MonadParsec MMarkErr s m => MMarkErr -> m a -mmarkErr = fancyFailure . E.singleton . ErrorCustom - -toNesTokens :: Text -> NonEmpty Char -toNesTokens = NE.fromList . T.unpack - isEmailUri :: URI -> Maybe Text isEmailUri uri = case URI.unRText <$> URI.uriPath uri of @@ -745,9 +981,6 @@ else Nothing _ -> Nothing -mailtoScheme :: URI.RText 'URI.Scheme -mailtoScheme = fromJust (URI.mkScheme "mailto") - splitYamlError :: FilePath -> String -> (Maybe SourcePos, String) splitYamlError file str = maybe (Nothing, str) (first pure) (parseMaybe p str) where @@ -760,3 +993,64 @@ void (string ":\n") r <- takeRest return (SourcePos file l c, r) + +emptyParagraph :: Block Isp +emptyParagraph = Paragraph (IspSpan (initialPos "") "") + +emptyNaked :: Block Isp +emptyNaked = Naked (IspSpan (initialPos "") "") + +manyIndexed :: (Alternative m, Num n) => n -> (n -> m a) -> m [a] +manyIndexed n' m = go n' + where + go !n = liftA2 (:) (m n) (go (n + 1)) <|> pure [] + +normalizeListItems :: NonEmpty [Block Isp] -> NonEmpty [Block Isp] +normalizeListItems xs' = + if getAny $ foldMap (foldMap (Any . isParagraph)) (drop 1 x :| xs) + then fmap toParagraph <$> xs' + else case x of + [] -> xs' + (y:ys) -> r $ (toNaked y : ys) :| xs + where + (x:|xs) = r xs' + r = NE.reverse . fmap reverse + isParagraph = \case + OrderedList _ _ -> False + UnorderedList _ -> False + Naked _ -> False + _ -> True + toParagraph (Naked inner) = Paragraph inner + toParagraph other = other + toNaked (Paragraph inner) = Naked inner + toNaked other = other + +e2p :: Either a b -> Pair a b +e2p = \case + Left a -> PairL a + Right b -> PairR (b:) + +succeeds :: Alternative m => m () -> m Bool +succeeds m = True <$ m <|> pure False + +prependErr :: SourcePos -> MMarkErr -> [Block Isp] -> [Block Isp] +prependErr pos custom blocks = Naked (IspError err) : blocks + where + err = FancyError (nes pos) (E.singleton $ ErrorCustom custom) + +mmarkErr :: MonadParsec MMarkErr s m => MMarkErr -> m a +mmarkErr = fancyFailure . E.singleton . ErrorCustom + +mailtoScheme :: URI.RText 'URI.Scheme +mailtoScheme = fromJust (URI.mkScheme "mailto") + +toNesTokens :: Text -> NonEmpty Char +toNesTokens = NE.fromList . T.unpack + +nes :: a -> NonEmpty a +nes a = a :| [] + +fromRight :: Either a b -> b +fromRight (Right x) = x +fromRight _ = + error "Text.MMark.Parser.fromRight: the impossible happened" diff --git a/mmark.cabal b/mmark.cabal --- a/mmark.cabal +++ b/mmark.cabal @@ -1,7 +1,7 @@ name: mmark -version: 0.0.1.1 +version: 0.0.2.0 cabal-version: >= 1.18 -tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.1 +tested-with: GHC==7.10.3, GHC==8.0.2, GHC==8.2.2 license: BSD3 license-file: LICENSE.md author: Mark Karpov diff --git a/tests/Text/MMarkSpec.hs b/tests/Text/MMarkSpec.hs --- a/tests/Text/MMarkSpec.hs +++ b/tests/Text/MMarkSpec.hs @@ -34,32 +34,34 @@ it "CM3" $ " a\ta\n ὐ\ta" ==-> "
a\ta\nὐ\ta\n
\n" - xit "CM4" $ -- FIXME pending lists + it "CM4" $ " - foo\n\n\tbar" ==-> "\n" - xit "CM5" $ -- FIXME pending lists + it "CM5" $ "- foo\n\n\t\tbar" ==-> "\n" - xit "CM6" $ -- FIXME pending blockquotes + it "CM6" $ ">\t\tfoo" ==-> "
\n
  foo\n
\n
\n" - xit "CM7" $ -- FIXME pending lists + it "CM7" $ "-\t\tfoo" ==-> "\n" it "CM8" $ " foo\n\tbar" ==-> "
foo\nbar\n
\n" - xit "CM9" $ -- FIXME pending lists + it "CM9" $ " - foo\n - bar\n\t - baz" ==-> - "\n" + "\n" it "CM10" $ "#\tFoo" ==-> "

Foo

\n" it "CM11" $ "*\t*\t*\t" ==-> "
\n" context "3.1 Precedence" $ - xit "CM12" $ -- FIXME pending lists - "- `one\n- two`" ==-> - "\n" + it "CM12" $ + let s = "- `one\n- two`" + in s ~~-> + [ err (posN 6 s) (ueib <> etok '`' <> elabel "code span content") + , err (posN 13 s) (ueib <> etok '`' <> elabel "code span content") ] context "4.1 Thematic breaks" $ do it "CM13" $ "***\n---\n___" ==-> "
\n
\n
\n" @@ -76,7 +78,7 @@ " ***" ==-> "
***\n
\n" it "CM19" $ let s = "Foo\n ***\n" - in s ~-> errFancy (posN 10 s) (nonFlanking "*") + in s ~-> errFancy (posN 10 s) (nonFlanking "*") it "CM20" $ "_____________________________________" ==-> "
\n" @@ -93,21 +95,21 @@ in s ~-> errFancy posI (nonFlanking "_") it "CM26" $ " *\\-*" ==-> "

-

\n" - xit "CM27" $ -- FIXME pending lists + it "CM27" $ "- foo\n***\n- bar" ==-> - "\n
\n\n" + "\n
\n\n" it "CM28" $ - let s = "Foo\n***\nbar" - in s ~-> errFancy (posN 6 s) (nonFlanking "*") + "Foo\n***\nbar" ==-> + "

Foo

\n
\n

bar

\n" xit "CM29" $ -- FIXME pending setext headings "Foo\n---\nbar" ==-> "

Foo

\n

bar

\n" - xit "CM30" $ -- FIXME pending lists + it "CM30" $ "* Foo\n* * *\n* Bar" ==-> - "\n
\n\n" - xit "CM31" $ -- FIXME pending lists + "\n" + it "CM31" $ "- Foo\n- * * *" ==-> - "\n" + "\n" context "4.2 ATX headings" $ do it "CM32" $ "# foo\n## foo\n### foo\n#### foo\n##### foo\n###### foo" ==-> @@ -123,7 +125,7 @@ it "CM35" $ "\\## foo" ==-> "

## foo

\n" it "CM36" $ - "# foo *bar* \\*baz\\*" ==-> "

foo bar *baz*

\n" + "# foo *bar* \\*baz\\*" ==-> "

foo bar *baz*

\n" it "CM37" $ "# foo " ==-> "

foo

\n" @@ -143,18 +145,18 @@ it "CM43" $ "### foo ### " ==-> "

foo

\n" it "CM44" $ - "### foo ### b" ==-> "

foo ### b

\n" + "### foo ### b" ==-> "

foo ### b

\n" it "CM45" $ - "# foo#" ==-> "

foo#

\n" + "# foo#" ==-> "

foo#

\n" it "CM46" $ "### foo \\###\n## foo #\\##\n# foo \\#" ==-> - "

foo ###

\n

foo ###

\n

foo #

\n" + "

foo ###

\n

foo ###

\n

foo #

\n" it "CM47" $ "****\n## foo\n****" ==-> "
\n

foo

\n
\n" it "CM48" $ "Foo bar\n# baz\nBar foo" ==-> - "

Foo bar\n# baz\nBar foo

\n" + "

Foo bar

\n

baz

\n

Bar foo

\n" it "CM49" $ let s = "## \n#\n### ###" in s ~~-> @@ -164,12 +166,12 @@ it "CM76" $ " a simple\n indented code block" ==-> "
a simple\n  indented code block\n
\n" - xit "CM77" $ -- FIXME pending lists + it "CM77" $ " - foo\n\n bar" ==-> "\n" - xit "CM78" $ -- FIXME pending lists + it "CM78" $ "1. foo\n\n - bar" ==-> - "
    \n
  1. \n

    foo

    \n
      \n
    • bar
      • \n
    \n
    2. \n
\n" + "
    \n
  1. \n

    foo

    \n
      \n
    • \nbar\n
      • \n
    \n
    2. \n
\n" it "CM79" $ " \n *hi*\n\n - one" ==-> "
<a/>\n*hi*\n\n- one\n
\n" @@ -224,9 +226,9 @@ let s = "`````\n\n```\naaa\n" in s ~-> err (posN 15 s) (ueof <> elabel "closing code fence" <> elabel "code block content") - xit "CM96" $ -- FIXME pending blockquotes - "> ```\n> aaa\n\nbbb" ==-> - "
\n
aaa\n
\n
\n

bbb

\n" + it "CM96" $ + let s = "> ```\n> aaa\n\nbbb\n" + in s ~-> err (posN 17 s) (ueof <> elabel "closing code fence" <> elabel "code block content") it "CM97" $ "```\n\n \n```" ==-> "
\n  \n
\n" @@ -311,6 +313,303 @@ it "CM188" $ " \n\naaa\n \n\n# aaa\n\n " ==-> "

aaa

\n

aaa

\n" + context "5.1 Block quotes" $ do + it "CM189" $ + "> # Foo\n bar\n baz" ==-> + "
\n

Foo

\n

bar\nbaz

\n
\n" + it "CM190" $ + "># Foo\n bar\n baz" ==-> + "
\n

Foo

\n

bar\nbaz

\n
\n" + it "CM191" $ + " > # Foo\n bar\n baz" ==-> + "
\n

Foo

\n

bar\nbaz

\n
\n" + it "CM192" $ + " > # Foo\n > bar\n > baz" ==-> + "
> # Foo\n> bar\n> baz\n
\n" + it "CM193" $ + "> # Foo\n> bar\nbaz" ==-> + "
\n

Foo

\n
\n
\n

bar

\n
\n

baz

\n" + it "CM194" $ + "> bar\nbaz\n> foo" ==-> + "
\n

bar

\n
\n

baz

\n
\n

foo

\n
\n" + it "CM195" $ + "> foo\n---" ==-> + "
\n

foo

\n
\n
\n" + it "CM196" $ + "> - foo\n- bar" ==-> + "
\n
    \n
  • \nfoo\n
    • \n
\n
\n\n" + it "CM197" $ + "> foo\n bar" ==-> + "
\n
foo\n
\n

bar

\n
\n" + it "CM198" $ + "> ```\nfoo\n```" ==-> + "
\n
foo\n
\n
\n" + it "CM199" $ + "> foo\n - bar" ==-> + "
\n

foo

\n
    \n
  • \nbar\n
    • \n
\n
\n" + it "CM200" $ + ">" ==-> + "
\n
\n" + it "CM201" $ + ">\n> \n> " ==-> + "
\n
\n
\n
\n
\n
\n" + it "CM202" $ + ">\n foo\n " ==-> + "
\n

foo

\n
\n" + it "CM203" $ + "> foo\n\n> bar" ==-> + "
\n

foo

\n
\n
\n

bar

\n
\n" + it "CM204" $ + "> foo\n bar" ==-> + "
\n

foo\nbar

\n
\n" + it "CM205" $ + "> foo\n\n bar" ==-> + "
\n

foo

\n

bar

\n
\n" + it "CM206" $ + "foo\n> bar" ==-> + "

foo

\n
\n

bar

\n
\n" + it "CM207" $ + "> aaa\n***\n> bbb" ==-> + "
\n

aaa

\n
\n
\n
\n

bbb

\n
\n" + it "CM208" $ + "> bar\n baz" ==-> + "
\n

bar\nbaz

\n
\n" + it "CM209" $ + "> bar\n\nbaz" ==-> + "
\n

bar

\n
\n

baz

\n" + it "CM210" $ + "> bar\n\nbaz" ==-> + "
\n

bar

\n
\n

baz

\n" + it "CM211" $ + "> > > foo\nbar" ==-> + "
\n
\n
\n

foo

\n
\n
\n
\n

bar

\n" + it "CM212" $ + ">>> foo\n bar\n baz" ==-> + "
\n
\n
\n

foo\nbar\nbaz

\n
\n
\n
\n" + it "CM213" $ + "> code\n\n> not code" ==-> + "
\n
code\n
\n
\n
\n

not code

\n
\n" + context "5.2 List items" $ do + it "CM214" $ + "A paragraph\nwith two lines.\n\n indented code\n\n> A block quote." ==-> + "

A paragraph\nwith two lines.

\n
indented code\n
\n
\n

A block quote.

\n
\n" + it "CM215" $ + "1. A paragraph\n with two lines.\n\n indented code\n\n > A block quote." ==-> + "
    \n
  1. \n

    A paragraph\nwith two lines.

    \n
    indented code\n
    \n
    \n

    A block quote.

    \n
    \n
    2. \n
\n" + it "CM216" $ + "- one\n\n two" ==-> + "\n

two

\n" + it "CM217" $ + "- one\n\n two" ==-> + "\n" + it "CM218" $ + " - one\n\n two" ==-> + "\n
 two\n
\n" + it "CM219" $ + " - one\n\n two" ==-> + "\n" + it "CM220" $ + " > > 1. one\n\n two" ==-> + "
\n
\n
    \n
  1. \none\n
    2. \n
\n

two

\n
\n
\n" + it "CM221" $ + ">>- one\n\n two" ==-> + "
\n
\n
    \n
  • \n

    one

    \n

    two

    \n
    • \n
\n
\n
\n" + it "CM222" $ + "-one\n\n2.two" ==-> + "

-one

\n

2.two

\n" + it "CM223" $ + "- foo\n\n\n bar" ==-> + "\n" + it "CM224" $ + "1. foo\n\n ```\n bar\n ```\n\n baz\n\n > bam" ==-> + "
    \n
  1. \n

    foo

    \n
    bar\n
    \n

    baz

    \n
    \n

    bam

    \n
    \n
    2. \n
\n" + it "CM225" $ + "- Foo\n\n bar\n\n\n baz" ==-> + "\n" + it "CM226" $ + "123456789. ok" ==-> + "
    \n
  1. \nok\n
    2. \n
\n" + it "CM227" $ + let s = "1234567890. not ok\n" + in s ~-> errFancy posI (indexTooBig 1234567890) + it "CM228" $ + "0. ok" ==-> + "
    \n
  1. \nok\n
    2. \n
\n" + it "CM229" $ + "003. ok" ==-> + "
    \n
  1. \nok\n
    2. \n
\n" + it "CM230" $ + "-1. not ok" ==-> + "

-1. not ok

\n" + it "CM231" $ + "- foo\n\n bar" ==-> + "\n" + it "CM232" $ + " 10. foo\n\n bar" ==-> + "
    \n
  1. \n

    foo

    \n
    bar\n
    \n
    2. \n
\n" + it "CM233" $ + " indented code\n\nparagraph\n\n more code" ==-> + "
indented code\n
\n

paragraph

\n
more code\n
\n" + it "CM234" $ + "1. indented code\n\n paragraph\n\n more code" ==-> + "
    \n
  1. \n
    indented code\n
    \n

    paragraph

    \n
    more code\n
    \n
    2. \n
\n" + it "CM235" $ + "1. indented code\n\n paragraph\n\n more code" ==-> + "
    \n
  1. \n
     indented code\n
    \n

    paragraph

    \n
    more code\n
    \n
    2. \n
\n" + it "CM236" $ + " foo\n\nbar" ==-> + "

foo

\n

bar

\n" + it "CM237" $ + "- foo\n\n bar" ==-> + "\n

bar

\n" + it "CM238" $ + "- foo\n\n bar" ==-> + "\n" + it "CM239" $ + "-\n foo\n-\n ```\n bar\n ```\n-\n baz" ==-> + "\n" + it "CM240" $ + "- \n foo" ==-> + "\n" + it "CM241" $ + "-\n\n foo" ==-> + "\n

foo

\n" + it "CM241b" $ + "1.\n\n foo" ==-> + "
    \n
  1. \n\n
    2. \n
\n

foo

\n" + it "CM242" $ + "- foo\n-\n- bar" ==-> + "\n" + it "CM243" $ + "- foo\n- \n- bar" ==-> + "\n" + it "CM244" $ + "1. foo\n2.\n3. bar" ==-> + "
    \n
  1. \nfoo\n
    2. \n
  2. \n\n
    3. \n
  3. \nbar\n
    4. \n
\n" + it "CM245" $ + "*" ==-> + "\n" + it "CM246" $ + "foo\n*\n\nfoo\n1." ==-> + "

foo

\n\n

foo

\n
    \n
  1. \n\n
    2. \n
\n" + it "CM247" $ + " 1. A paragraph\n with two lines.\n\n indented code\n\n > A block quote." ==-> + "
    \n
  1. \n

    A paragraph\nwith two lines.

    \n
    indented code\n
    \n
    \n

    A block quote.

    \n
    \n
    2. \n
\n" + it "CM248" $ + " 1. A paragraph\n with two lines.\n\n indented code\n\n > A block quote." ==-> + "
    \n
  1. \n

    A paragraph\nwith two lines.

    \n
    indented code\n
    \n
    \n

    A block quote.

    \n
    \n
    2. \n
\n" + it "CM249" $ + " 1. A paragraph\n with two lines.\n\n indented code\n\n > A block quote." ==-> + "
    \n
  1. \n

    A paragraph\nwith two lines.

    \n
    indented code\n
    \n
    \n

    A block quote.

    \n
    \n
    2. \n
\n" + it "CM250" $ + " 1. A paragraph\n with two lines.\n\n indented code\n\n > A block quote." ==-> + "
1.  A paragraph\n    with two lines.\n\n        indented code\n\n    > A block quote.\n
\n" + it "CM251" $ + " 1. A paragraph\nwith two lines.\n\n indented code\n\n > A block quote." ==-> + "
    \n
  1. \nA paragraph\n
    2. \n
\n

with two lines.

\n
      indented code\n\n  > A block quote.\n
\n" + it "CM252" $ + " 1. A paragraph\n with two lines." ==-> + "
    \n
  1. \nA paragraph\n
    2. \n
\n
with two lines.\n
\n" + it "CM253" $ + "> 1. > Blockquote\ncontinued here." ==-> + "
\n
    \n
  1. \n
    \n

    Blockquote

    \n
    \n
    2. \n
\n
\n

continued here.

\n" + it "CM254" $ + "> 1. > Blockquote\n continued here." ==-> + "
\n
    \n
  1. \n
    \n

    Blockquote

    \n
    \n
    2. \n
\n

continued here.

\n
\n" + it "CM255" $ + "- foo\n - bar\n - baz\n - boo" ==-> + "\n" + it "CM256" $ + "- foo\n - bar\n - baz\n - boo" ==-> + "\n" + it "CM257" $ + "10) foo\n - bar" ==-> + "
    \n
  1. \nfoo\n
      \n
    • \nbar\n
      • \n
    \n
    2. \n
\n" + it "CM258" $ + "10) foo\n - bar" ==-> + "
    \n
  1. \nfoo\n
    2. \n
\n\n" + it "CM259" $ + "- - foo" ==-> + "\n" + it "CM260" $ + "1. - 2. foo" ==-> + "
    \n
  1. \n
      \n
    • \n
        \n
      1. \nfoo\n
        2. \n
      \n
      • \n
    \n
    2. \n
\n" + it "CM261" $ + "- # Foo\n- Bar\n ---\n baz" ==-> + "\n" + context "5.3 Lists" $ do + it "CM262" $ + "- foo\n- bar\n+ baz" ==-> + "\n\n" + it "CM263" $ + "1. foo\n2. bar\n3) baz" ==-> + "
    \n
  1. \nfoo\n
    2. \n
  2. \nbar\n
    3. \n
\n
    \n
  1. \nbaz\n
    2. \n
\n" + it "CM264" $ + "Foo\n- bar\n- baz" ==-> + "

Foo

\n\n" + it "CM265" $ + "The number of windows in my house is\n14. The number of doors is 6." ==-> + "

The number of windows in my house is

\n
    \n
  1. \nThe number of doors is 6.\n
    2. \n
\n" + it "CM266" $ + "The number of windows in my house is\n1. The number of doors is 6." ==-> + "

The number of windows in my house is

\n
    \n
  1. \nThe number of doors is 6.\n
    2. \n
\n" + it "CM267" $ + "- foo\n\n- bar\n\n\n- baz" ==-> + "\n" + it "CM268" $ + "- foo\n - bar\n - baz\n\n\n bim" ==-> + "\n" + xit "CM269" $ -- FIXME pending HTML blocks + "- foo\n- bar\n\n\n\n- baz\n- bim" ==-> + "\n\n\n" + xit "CM270" $ -- FIXME pending HTML blocks + "- foo\n\n notcode\n\n- foo\n\n\n\n code" ==-> + "\n\n
code\n
\n" + it "CM271" $ + "- a\n - b\n - c\n - d\n - e\n - f\n - g\n - h\n- i" ==-> + "\n" + it "CM272" $ + "1. a\n\n 2. b\n\n 3. c" ==-> + "
    \n
  1. \n

    a

    \n
    2. \n
  2. \n

    b

    \n
    3. \n
  3. \n

    c

    \n
    4. \n
\n" + it "CM273" $ + "- a\n- b\n\n- c" ==-> + "\n" + it "CM274" $ + "* a\n*\n\n* c" ==-> + "\n" + it "CM275" $ + "- a\n- b\n\n c\n- d" ==-> + "\n" + xit "CM276" $ -- FIXME pending reference links + "- a\n- b\n\n [ref]: /url\n- d" ==-> + "\n" + it "CM277" $ + "- a\n- ```\n b\n\n\n ```\n- c" ==-> + "\n" + it "CM278" $ + "- a\n - b\n\n c\n- d" ==-> + "\n" + it "CM279" $ + "* a\n > b\n >\n* c" ==-> + "\n" + it "CM280" $ + "- a\n > b\n ```\n c\n ```\n- d" ==-> + "\n" + it "CM281" $ + "- a" ==-> + "\n" + it "CM282" $ + "- a\n - b" ==-> + "\n" + it "CM283" $ + "1. ```\n foo\n ```\n\n bar" ==-> + "
    \n
  1. \n
    foo\n
    \n

    bar

    \n
    2. \n
\n" + it "CM284" $ + "* foo\n * bar\n\n baz" ==-> + "\n" + it "CM285" $ + "- a\n - b\n - c\n\n- d\n - e\n - f" ==-> + "\n" context "6 Inlines" $ it "CM286" $ let s = "`hi`lo`\n" @@ -454,7 +753,7 @@ in s ~-> errFancy (posN 9 s) (nonFlanking "*") it "CM345" $ let s = "*foo bar\n*\n" - in s ~-> errFancy (posN 9 s) (nonFlanking "*") + in s ~-> err (posN 8 s) (ueib <> etok '*' <> eic <> eric) it "CM346" $ let s = "*(*foo)\n" in s ~-> errFancy posI (nonFlanking "*") @@ -903,8 +1202,8 @@ it "CM544" $ "![foo [bar](/url)](/url2)" ==-> "

\"foo

\n" - it "CM545" pending - it "CM546" pending + it "CM545" pending -- FIXME pending reference images + it "CM546" pending -- FIXME pending reference images it "CM547" $ "![foo](train.jpg)" ==-> "

\"foo\"

\n" @@ -916,7 +1215,7 @@ "

\"foo\"

\n" it "CM550" $ "![](/url)" ==-> "

\n" - it "CM551-CM562" pending -- pending reference-style stuff + it "CM551-CM562" pending -- FIXME pending reference-style stuff context "6.7 Autolinks" $ do it "CM563" $ "" ==-> @@ -1005,7 +1304,7 @@ xit "CM615" $ "foo " ==-> "

foo

\n" it "CM616" $ - "### foo\\" ==-> "

foo\\

\n" + "### foo\\" ==-> "

foo\\

\n" it "CM617" $ "### foo " ==-> "

foo

\n" context "6.10 Soft line breaks" $ do @@ -1065,6 +1364,40 @@ s ~~-> [ err (posN 1 s) (utok 'M' <> etok '#' <> elabel "white space") , errFancy (posN 35 s) (nonFlanking "_") ] + describe "every block in a list gets its parse error propagated" $ do + context "with unordered list" $ + it "works" $ do + let s = "- *foo\n\n *bar\n- *baz\n\n *quux\n" + e = ueib <> etok '*' <> eic <> eric + s ~~-> + [ err (posN 6 s) e + , err (posN 14 s) e + , err (posN 21 s) e + , err (posN 30 s) e ] + context "with ordered list" $ + it "works" $ do + let s = "1. *foo\n\n *bar\n2. *baz\n\n *quux\n" + e = ueib <> etok '*' <> eic <> eric + s ~~-> + [ err (posN 7 s) e + , err (posN 16 s) e + , err (posN 24 s) e + , err (posN 34 s) e ] + it "too big start index of ordered list does not prevent validation of inner inlines" $ do + let s = "1234567890. *something\n1234567891. [\n" + s ~~-> + [ errFancy posI (indexTooBig 1234567890) + , err (posN 22 s) (ueib <> etok '*' <> eic <> eric) + , err (posN 36 s) (ueib <> etok ']') ] + it "non-consecutive indices in ordered list do not prevent further validation" $ do + let s = "1. *foo\n3. *bar\n4. *baz\n" + e = ueib <> etok '*' <> eic <> eric + s ~~-> + [ err (posN 7 s) e + , errFancy (posN 8 s) (indexNonCons 3 2) + , err (posN 15 s) e + , errFancy (posN 16 s) (indexNonCons 4 3) + , err (posN 23 s) e ] context "given a complete, comprehensive document" $ it "outputs expected the HTML fragment" $ withFiles "data/comprehensive.md" "data/comprehensive.html" @@ -1112,17 +1445,23 @@ context "when document contains a YAML section" $ do context "when it is valid" $ it "returns the YAML section" $ do - doc <- mkDoc "---\nx: 100\ny: 200\n---Here we go." + doc <- mkDoc "---\nx: 100\ny: 200\n---\nHere we go." let r = object [ "x" .= Number 100 , "y" .= Number 200 ] MMark.projectYaml doc `shouldBe` Just r - context "when it is invalid" $ + context "when it is invalid" $ do + let mappingErr = fancy . ErrorCustom . YamlParseError $ + "mapping values are not allowed in this context" it "signal correct parse error" $ - let s = "---\nx: 100\ny: x:\n---Here we go." - in s ~-> errFancy (posN 15 s) - (fancy . ErrorCustom . YamlParseError $ - "mapping values are not allowed in this context") + let s = "---\nx: 100\ny: x:\n---\nHere we go." + in s ~-> errFancy (posN 15 s) mappingErr + it "does not choke and can report more parse errors" $ + let s = "---\nx: 100\ny: x:\n---\nHere we *go." + in s ~~-> + [ errFancy (posN 15 s) mappingErr + , err (posN 33 s) (ueib <> etok '*' <> eic <> eric) + ] ---------------------------------------------------------------------------- -- Testing extensions @@ -1200,3 +1539,16 @@ nonFlanking :: Text -> EF MMarkErr nonFlanking = fancy . ErrorCustom . NonFlankingDelimiterRun . NE.fromList . T.unpack + +-- | Create a error component complaining that the given starting index of +-- an ordered list is too big. + +indexTooBig :: Word -> EF MMarkErr +indexTooBig = fancy . ErrorCustom . ListStartIndexTooBig + +-- | Create a error component complaining about non-consecutive indices in +-- an ordered list. + +indexNonCons :: Word -> Word -> EF MMarkErr +indexNonCons actual expected = fancy . ErrorCustom $ + ListIndexOutOfOrder actual expected