comark-parser (empty) → 0.1.0
raw patch · 18 files changed
+2431/−0 lines, 18 filesdep +QuickCheckdep +basedep +cmarksetup-changed
Dependencies added: QuickCheck, base, cmark, comark-parser, comark-syntax, comark-testutils, containers, control-bool, criterion, deepseq, file-embed, hspec, html5-entity, syb, text, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- bench/Main.hs +40/−0
- comark-parser.cabal +86/−0
- extended/Data/Char/Extended.hs +14/−0
- extended/Data/Sequence/Extended.hs +26/−0
- extended/Data/Text/Extended.hs +46/−0
- src/Comark/Parser.hs +797/−0
- src/Comark/Parser/Inline.hs +475/−0
- src/Comark/Parser/Inline/EmphLink.hs +105/−0
- src/Comark/Parser/Options.hs +58/−0
- src/Comark/Parser/Util.hs +111/−0
- src/Comark/ParserCombinators.hs +165/−0
- src/Comark/ParserCombinators/Prim.hs +328/−0
- src/Text/Html/Email/Validate.hs +29/−0
- tests/Blocks.hs +43/−0
- tests/Inline.hs +52/−0
- tests/Main.hs +24/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, 2016, 2017, Konstantin Zudov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Konstantin Zudov nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/Main.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+module Main where++import Control.Arrow (second)+import Control.DeepSeq+import Criterion.Main+import Data.FileEmbed+import Data.Foldable+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text++import qualified Comark.Parser as Comark+import qualified Comark.Parser.Options as Comark+import qualified Comark.Syntax as Comark++samples :: [(FilePath, Text)]+samples = map (second Text.decodeUtf8) $(embedDir "bench/samples/")++main :: IO ()+main = defaultMain+ [ bgroup "pathological with normalization" $ benches [Comark.Normalize] pathological+ , bgroup "pathological without normalization" $ benches [] pathological+ , bgroup "markdown-it samples with normalization" $ benches [Comark.Normalize] samples+ , bgroup "markdown-it samples without normalization" $ benches [] samples+ ]++benches opts = map (\(n,c) -> bench n $ nf (Comark.parse opts) c)++pathological :: [(String, Text)]+pathological =+ [ ("nested brackets", nested 50000 "[" "foo" "]")+ , ("nested parenthesis", nested 50000 "(" "foo" ")")+ ]++nested :: Int -> Text -> Text -> Text -> Text+nested n opener inner closer = Text.replicate n opener <> inner <> Text.replicate n closer
+ comark-parser.cabal view
@@ -0,0 +1,86 @@+-- This file has been generated from package.yaml by hpack version 0.17.0.+--+-- see: https://github.com/sol/hpack++name: comark-parser+version: 0.1.0+synopsis: Parser for Commonmark (markdown)+description: See <https://github.com/zudov/haskell-comark#readme README>+license: BSD3+license-file: LICENSE+author: Konstantin Zudov+maintainer: co@zudov.me+copyright: (c) Konstantin Zudov, 2015, 2016, 2017+category: Text+build-type: Simple+cabal-version: >= 1.10++library+ hs-source-dirs:+ src/+ extended/+ exposed-modules:+ Comark.Parser+ Comark.Parser.Options+ Comark.Parser.Inline+ Comark.Parser.Inline.EmphLink+ Comark.ParserCombinators+ Comark.ParserCombinators.Prim+ other-modules:+ Comark.Parser.Util+ Text.Html.Email.Validate+ Data.Char.Extended+ Data.Sequence.Extended+ Data.Text.Extended+ Paths_comark_parser+ other-extensions: OverloadedStrings TupleSections TupleSections ViewPatterns OverloadedStrings LambdaCase RecordWildCards+ build-depends:+ text+ , comark-syntax+ , base >=4.7 && <5.0+ , html5-entity >=0.2.0.1+ , control-bool+ , containers+ , transformers+ default-language: Haskell2010+ ghc-options: -Wall++test-suite test+ hs-source-dirs:+ tests/+ main-is: Main.hs+ other-modules:+ Blocks+ Inline+ type: exitcode-stdio-1.0+ ghc-options: -Wall+ build-depends:+ text+ , comark-syntax+ , base >=4.7+ , hspec+ , syb+ , QuickCheck+ , deepseq+ , containers+ , comark-parser+ , comark-testutils+ , cmark+ default-language: Haskell2010++benchmark bench+ type: exitcode-stdio-1.0+ hs-source-dirs:+ bench/+ main-is: Main.hs+ build-depends:+ text+ , comark-syntax+ , base >=4.7 && <5+ , criterion+ , comark-testutils+ , comark-parser+ , deepseq+ , file-embed+ default-language: Haskell2010+ ghc-options: -O2
+ extended/Data/Char/Extended.hs view
@@ -0,0 +1,14 @@+module Data.Char.Extended+ ( module Data.Char+ , chrSafe+ ) where++import Data.Char+import Data.Ix (inRange)++-- | Invalid Unicode codepoints and NUL will be written as the "unknown codepoint"+-- character (0xFFFD)+chrSafe :: Int -> Char+chrSafe codepoint+ | inRange (0x1,0x10FFFF) codepoint = chr codepoint+ | otherwise = '\xFFFD'
+ extended/Data/Sequence/Extended.hs view
@@ -0,0 +1,26 @@+module Data.Sequence.Extended+ ( module Data.Sequence+ , module Data.Sequence.Extended+ ) where++import Data.Sequence++-- | Finds the leftmost element that satisfies the predicate.+-- Returns (prefix, element, suffix).+findl :: (a -> Bool) -> Seq a -> Maybe (Seq a, a, Seq a)+findl p s =+ case breakl p s of+ (prefix, rest) ->+ case viewl rest of+ EmptyL -> Nothing+ a :< suffix -> Just (prefix, a, suffix)++-- | Finds the rightmost element that satisfies the predicate.+-- Returns (suffix, element, prefix).+findr :: (a -> Bool) -> Seq a -> Maybe (Seq a, a, Seq a)+findr p s =+ case breakr p s of+ (suffix, rest) ->+ case viewr rest of+ EmptyR -> Nothing+ prefix :> a -> Just (suffix, a, prefix)
+ extended/Data/Text/Extended.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+module Data.Text.Extended+ ( module Data.Text+ , tabFilter+ , joinLines+ , lines'+ ) where++import Data.Text+import qualified Data.Text as T++-- Convert tabs to spaces using specified tab stop.+tabFilter :: Int -> Text -> Text+tabFilter tabstop = T.concat . pad . T.split (== '\t')+ where pad [] = []+ pad [t] = [t]+ pad (t:ts) = T.justifyLeft n ' ' t : pad ts+ where tl = T.length t+ n = tl + tabstop - (tl `mod` tabstop)++-- | Like unlines but does not add a final newline.+-- | Concatenates lines with newlines between.+joinLines :: [Text] -> Text+joinLines = T.intercalate "\n"++-- | Been commented out from Data.Text+-- /O(n)/ Portably breaks a 'Text' up into a list of 'Text's at line+-- boundaries.+--+-- A line boundary is considered to be either a line feed, a carriage+-- return immediately followed by a line feed, or a carriage return.+-- This accounts for both Unix and Windows line ending conventions,+-- and for the old convention used on Mac OS 9 and earlier.++lines' :: Text -> [Text]+lines' ps | T.null ps = []+ | otherwise = h : case T.uncons t of+ Nothing -> []+ Just (c,t')+ | c == '\n' -> lines' t'+ | c == '\r' -> case T.uncons t' of+ Just ('\n',t'') -> lines' t''+ _ -> lines' t'+ _ -> error "lines': IMPOSSIBLE HAPPENED"+ where (h,t) = T.span notEOL ps+ notEOL c = c /= '\n' && c /= '\r'
+ src/Comark/Parser.hs view
@@ -0,0 +1,797 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}+module Comark.Parser+ ( parse+ , ParserOption(..)+ ) where++import Prelude hiding (takeWhile)++import Control.Applicative+import Control.Arrow (second)+import Control.Bool+import Control.Monad+import Control.Monad.Trans.RWS.Strict+import Data.Char+import Data.Either+import Data.Foldable+import Data.List (intercalate)+import qualified Data.Map as Map+import Data.Maybe (mapMaybe)+import Data.Monoid+import Data.Sequence+ (Seq, ViewL(..), ViewR(..), singleton, viewl, viewr, (<|), (><), (|>))+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import Data.Text.Extended (Text)+import qualified Data.Text.Extended as Text++import Comark.Parser.Inline+import Comark.Parser.Options+import Comark.Parser.Util+import Comark.ParserCombinators+import Comark.Syntax++-- | Parses Commonmark document. Any sequence of characters is a valid+-- Commonmark document.+--+-- At the moment no sanitizations are performed besides the ones defined+-- in the spec.+parse :: [ParserOption] -> Text -> Doc Text+parse (parserOptions -> opts) text =+ Doc $ processDocument+ $ second extendRefmap+ $ processLines text+ where+ extendRefmap refmap =+ opts { _poLinkReferences =+ \t -> lookupLinkReference refmap t <|> _poLinkReferences opts t+ }++-- General parsing strategy:+--+-- Step 1: processLines+--+-- We process the input line by line. Each line modifies the+-- container stack, by adding a leaf to the current open container,+-- sometimes after closing old containers and/or opening new ones.+--+-- To open a container is to add it to the top of the container stack,+-- so that new content will be added under this container.+-- To close a container is to remove it from the container stack and+-- make it a child of the container above it on the container stack.+--+-- When all the input has been processed, we close all open containers+-- except the root (Document) container. At this point we should also+-- have a ReferenceMap containing any defined link references.+--+-- Step 2: processDocument+--+-- We then convert this container structure into an AST. This principally+-- involves (a) gathering consecutive ListItem containers into lists, (b)+-- gathering TextLine nodes that don't belong to verbatim containers into+-- paragraphs, and (c) parsing the inline contents of non-verbatim TextLines.++--------++-- Container stack definitions:+data ContainerStack+ = ContainerStack+ { csTop :: Container+ , csRest :: [Container]+ }++type LineNumber = Int++data Elt = C Container+ | L LineNumber Leaf+ deriving (Show)++data Container =+ Container+ { containerType :: ContainerType+ , containerChildren :: Seq Elt+ }++data ContainerType+ = Document+ | BlockQuote+ | ListItem+ { liPadding :: Int+ , liType :: ListType+ }+ | FencedCode+ { codeStartColumn :: Int+ , codeFence :: Text+ , codeInfo :: Maybe Text+ }+ | IndentedCode+ | RawHtmlBlock Condition+ | Reference+ deriving (Show, Eq)++isIndentedCode :: Elt -> Bool+isIndentedCode (C (Container IndentedCode _)) = True+isIndentedCode _ = False++isBlankLine :: Elt -> Bool+isBlankLine (L _ BlankLine{}) = True+isBlankLine _ = False++isTextLine :: Elt -> Bool+isTextLine (L _ (TextLine _)) = True+isTextLine _ = False++isListItem :: ContainerType -> Bool+isListItem ListItem{} = True+isListItem _ = False++instance Show Container where+ show c = mconcat+ [ show (containerType c), "\n"+ , nest 2 (intercalate "\n" $ map pptElt $ toList $ containerChildren c)+ ]++nest :: Int -> String -> String+nest num = intercalate "\n" . map (replicate num ' ' <>) . lines++pptElt :: Elt -> String+pptElt (C c) = show c+pptElt (L _ (TextLine s)) = show s+pptElt (L _ lf) = show lf++-- | Scanners that must be satisfied if the current open container is to be+-- continued on a new line (ignoring lazy continuations).+containerContinue :: Container -> Scanner+containerContinue c = case containerType c of+ BlockQuote -> pNonIndentSpaces *> scanBlockquoteStart+ IndentedCode -> void pIndentSpaces+ FencedCode{..} -> void $ pSpacesUpToColumn codeStartColumn+ ListItem{..} -> void pBlankline <|> (tabCrusher *> replicateM_ liPadding (char ' '))+ -- TODO: This is likely to be incorrect behaviour. Check.+ Reference -> notFollowedBy+ (void pBlankline+ <|> (do _ <- pNonIndentSpaces+ scanReference <|> scanBlockquoteStart <|> scanTBreakLine)+ <|> void parseAtxHeadingStart)+ _ -> pure ()+{-# INLINE containerContinue #-}++-- | Defines parsers that open new containers.+containerStart :: Bool -> Bool -> Parser ContainerType+containerStart afterListItem lastLineIsText = asum+ [ pNonIndentSpaces+ *> scanBlockquoteStart+ *> pure BlockQuote+ , parseListMarker afterListItem lastLineIsText+ ]++-- | Defines parsers that open new verbatim containers (containers+-- that take only TextLine and BlankLine as children).+verbatimContainerStart :: Bool -> Parser ContainerType+verbatimContainerStart lastLineIsText = asum+ [ pNonIndentSpaces *> parseCodeFence+ , do guard (not lastLineIsText)+ void pIndentSpaces+ notFollowedBy pBlankline+ pure IndentedCode+ , RawHtmlBlock <$> pHtmlBlockStart lastLineIsText+ , guard (not lastLineIsText) *> pNonIndentSpaces *> (Reference <$ scanReference)+ ]++-- | Leaves of the container structure (they don't take children).+type Leaf = GenLeaf Text++data GenLeaf t+ = TextLine t+ | BlankLine t+ | ATXHeading HeadingLevel t+ | SetextHeading HeadingLevel t+ | SetextToken HeadingLevel t+ | Rule+ deriving (Show, Functor)++type ContainerM = RWS () ReferenceMap ContainerStack++-- | Close the whole container stack, leaving only the root Document container.+closeStack :: ContainerM Container+closeStack =+ get >>= \case+ ContainerStack top [] -> pure top+ ContainerStack _ _ -> closeContainer *> closeStack++-- Close the top container on the stack. If the container is a Reference+-- container, attempt to parse the reference and update the reference map.+-- If it is a list item container, move a final BlankLine outside the list+-- item.+closeContainer :: ContainerM ()+closeContainer =+ get >>= \case+ ContainerStack top@(Container Reference cs'') rest ->+ case runParser ((,) <$> pReference <*> untilTheEnd) input of+ Right ((lab, lnk, tit), unconsumed) -> do+ tell (Map.singleton (normalizeReference lab) (lnk, tit))+ case rest of+ (Container ct' cs' : rs)+ | Text.null unconsumed ->+ put $ ContainerStack (Container ct' (rest' <> cs' |> C top)) rs+ | otherwise ->+ let children = (L (-1) (TextLine unconsumed) <| rest') >< (cs' |> C top)+ in put $ ContainerStack (Container ct' children) rs+ [] -> pure ()+ Left _ ->+ case rest of+ (Container ct' cs' : rs) ->+ put $ ContainerStack (Container ct' (cs' <> cs'')) rs+ [] -> return ()+ where+ input = Text.strip $ Text.joinLines $ map extractText $ toList textlines+ (textlines, rest') = Seq.spanl isTextLine cs''++ ContainerStack top rest+ | Container li@ListItem{} (viewr -> zs :> b) <- top+ , Container ct' cs' : rs <- rest+ , isBlankLine b ->+ let els = if null zs+ then cs' |> C (Container li zs)+ else cs' |> C (Container li zs) |> b+ in put $ ContainerStack (Container ct' els) rs++ ContainerStack top (Container ct' cs' : rs) ->+ put $ ContainerStack (Container ct' (cs' |> C top)) rs++ ContainerStack _ [] -> pure ()++-- Add a leaf to the top container.+addLeaf :: LineNumber -> Leaf -> ContainerM ()+addLeaf lineNum lf = do+ ContainerStack top rest <- get+ case containerType top of+ ListItem{} -- two blanks break out of list item:+ | (firstLine :< _) <- viewl $ containerChildren top+ , BlankLine{} <- lf+ , isBlankLine firstLine -> do+ closeContainer+ addLeaf lineNum lf+ _ -> put $ ContainerStack+ (Container+ (containerType top)+ (containerChildren top |> L lineNum lf))+ rest++-- Add a container to the container stack.+addContainer :: ContainerType -> ContainerM ()+addContainer ct =+ modify $ \ContainerStack{..} ->+ ContainerStack (Container ct mempty) (csTop:csRest)++-- Step 2++-- Convert Document container and reference map into an ASText.+processDocument :: (Container, ParserOptions) -> Blocks Text+processDocument (Container Document cs, opts) = processElts opts (toList cs)+processDocument _ = error "top level container is not Document"++-- Turn the result of `processLines` into a proper ASText.+-- This requires grouping text lines into paragraphs+-- and list items into lists, handling blank lines,+-- parsing inline contents of texts and resolving referencess.+processElts :: ParserOptions -> [Elt] -> Blocks Text+processElts _ [] = mempty++processElts opts (L _lineNumber lf : rest) =+ case lf of+ -- Gobble text lines and make them into a Para:+ TextLine t ->+ singleton (Para $ parseInlines opts txt) <> processElts opts rest'+ where txt = Text.stripEnd $ Text.joinLines $ map Text.stripStart+ $ t : map extractText textlines+ (textlines, rest') = span isTextLine rest++ -- Blanks at outer level are ignored:+ BlankLine{} -> processElts opts rest++ -- Headings:+ ATXHeading lvl t -> Heading lvl (parseInlines opts t) <| processElts opts rest+ SetextHeading lvl t -> Heading lvl (parseInlines opts t) <| processElts opts rest+ SetextToken _ _ -> error "Setext token wasn't converted to setext header"++ -- Horizontal rule:+ Rule -> ThematicBreak <| processElts opts rest++processElts opts (C (Container ct cs) : rest) =+ case ct of+ Document -> error "Document container found inside Document"++ BlockQuote -> Quote (processElts opts (toList cs)) <| processElts opts rest++ -- List item? Gobble up following list items of the same type+ -- (skipping blank lines), determine whether the list is tight or+ -- loose, and generate a List.+ ListItem { liType = itemType } ->+ List itemType isTight (Seq.fromList items') <| processElts opts rest'+ where+ xs = takeListItems rest++ rest' = drop (length xs) rest++ -- take list items as long as list type matches and we+ -- don't hit two blank lines:+ takeListItems (c@(C (Container ListItem { liType = lt } _)) : zs)+ | listTypesMatch lt itemType = c : takeListItems zs+ takeListItems (lf@(L _ (BlankLine _)) : c@(C (Container ListItem { liType = lt } _)) : zs)+ | listTypesMatch lt itemType = lf : c : takeListItems zs+ takeListItems _ = []++ listTypesMatch (Bullet c1) (Bullet c2) = c1 == c2+ listTypesMatch (Ordered w1 _) (Ordered w2 _) = w1 == w2+ listTypesMatch _ _ = False++ items = mapMaybe getItem (Container ct cs : [c | C c <- xs])++ getItem (Container ListItem{} cs') = Just $ toList cs'+ getItem _ = Nothing++ items' = map (processElts opts) items++ isTight = not (any isBlankLine xs) && all tightListItem items++ tightListItem [] = True+ tightListItem [_] = True+ tightListItem (_:is) = not $ any isBlankLine $ init is++ FencedCode _ _ info -> CodeBlock (parseInfoString <$> info)+ (Text.unlines $ map extractText $ toList cs)+ <| processElts opts rest++ IndentedCode -> CodeBlock Nothing txt <| processElts opts rest'+ where txt = Text.unlines $ stripTrailingEmpties $ concatMap extractCode cbs+ stripTrailingEmpties = reverse . dropWhile (Text.all (== ' ')) . reverse++ -- explanation for next line: when we parsed+ -- the blank line, we dropped 0-3 spaces.+ -- but for this, code block context, we want+ -- to have dropped 4 spaces. we simply drop+ -- one more:+ extractCode (L _ (BlankLine t)) = [Text.drop 1 t]+ extractCode (C (Container IndentedCode cs')) =+ map extractText $ toList cs'+ extractCode _ = []++ (cbs, rest') = span (isIndentedCode <||> isBlankLine)+ (C (Container ct cs) : rest)++ RawHtmlBlock _ -> HtmlBlock txt <| processElts opts rest+ where txt = Text.unlines (map extractText (toList cs))++ -- References have already been taken into account in the reference map,+ -- so we just skip.+ Reference -> processElts opts rest++extractText :: Elt -> Text+extractText (L _ (TextLine t)) = t+extractText _ = mempty++-- Step 1++processLines :: Text -> (Container, ReferenceMap)+processLines t = evalRWS (mapM_ processLine lns >> closeStack) () initState+ where+ lns = zip [1..] $ Text.lines' $ Text.replace "\0" "\xFFFD" t+ initState = ContainerStack (Container Document mempty) []++-- The main block-parsing function.+-- We analyze a line of text and modify the container stack accordingly,+-- adding a new leaf, or closing or opening containers.+processLine :: (LineNumber, Text) -> ContainerM ()+processLine (lineNumber, txt) = do+ ContainerStack top@(Container ct cs) rest <- get+ -- Apply the line-start scanners appropriate for each nested container.+ -- Return the remainder of the string, and the number of unmatched+ -- containers.+ let (t', numUnmatched) = tryOpenContainers (reverse $ top:rest) txt++ -- Some new containers can be started only after a blank.+ let lastLineIsText = numUnmatched == 0 &&+ case viewr cs of+ (_ :> L _ (TextLine _)) -> True+ _ -> False++ -- Process the rest of the line in a way that makes sense given+ -- the container type at the top of the stack (ct):+ case ct of+ -- If it's a verbatim line container, add the line.+ RawHtmlBlock c+ | numUnmatched == 0 -> do+ addLeaf lineNumber (TextLine t')+ when (isRight $ runParser (blockEnd c) t')+ closeContainer+ IndentedCode+ | numUnmatched == 0 -> addLeaf lineNumber (TextLine t')+ FencedCode { codeFence = fence' }+ | numUnmatched == 0 -> if+ -- closing code fence+ | isRight $ runParser scanClosing t'+ -> closeContainer+ | otherwise+ -> addLeaf lineNumber (TextLine t')+ where+ scanClosing = satisfyUpTo 3 (== ' ')+ *> string fence' *> skipWhile (== Text.head fence')+ *> pSpaces+ *> endOfInput+++ -- otherwise, parse the remainder to see if we have new container starts:+ _ -> let (verbatimContainers, leaf) =+ tryNewContainers (isListItem ct) lastLineIsText (Text.length txt - Text.length t') t'+ in case (Seq.viewl verbatimContainers, leaf) of+ -- lazy continuation: text line, last line was text, no new containers,+ -- some unmatched containers:+ (Seq.EmptyL, TextLine t)+ | numUnmatched > 0+ , _ :> L _ TextLine{} <- viewr cs+ , ct /= IndentedCode+ -> addLeaf lineNumber (TextLine t)++ -- Special case: Lazy continuation of a list item looking like+ -- indented code e.g:+ -- " 1. Paragraph"+ -- " with two lines"+ (IndentedCode :< _, TextLine t)+ | numUnmatched > 0+ , _ :> L _ TextLine{} <- viewr cs+ , ListItem{} <- ct+ -> addLeaf lineNumber $ TextLine $ Text.strip t++ -- A special case: Lazy continuaation of a quote looking like+ -- indented code e.g:+ -- "> foo"+ -- " - bar"+ (IndentedCode :< _, TextLine t)+ | numUnmatched > 0+ , _ :> L _ TextLine{} <- viewr cs+ , BlockQuote{} <- ct+ -> addLeaf lineNumber $ TextLine $ Text.strip t++ -- if it's a setext header line and the top container has a textline+ -- as last child, add a setext header:+ (Seq.EmptyL, SetextToken lev _setextText) | numUnmatched == 0 ->+ case Seq.spanr isTextLine cs of+ (textlines, cs') -- gather all preceding textlines and put them in the header+ | not (Seq.null textlines)+ -> put $ ContainerStack+ (Container ct+ (cs' |> L lineNumber+ (SetextHeading+ lev+ (Text.strip $ Text.unlines+ $ fmap extractText+ $ toList textlines))))+ rest+ -- Note: the following case should not occur, since+ -- we don't add a SetextHeading leaf unless lastLineIsText.+ | otherwise -> error "setext header line without preceding text lines"++ -- The end tag can occur on the same line as the start tag.+ (RawHtmlBlock condition :< _, TextLine t)+ | Right () <- runParser (blockEnd condition) t+ -> do closeContainer+ addContainer (RawHtmlBlock condition)+ addLeaf lineNumber (TextLine t)+ closeContainer+ -- otherwise, close all the unmatched containers, add the new+ -- containers, and finally add the new leaf:+ (ns, lf) -> do -- close unmatched containers, add new ones+ _ <- replicateM numUnmatched closeContainer+ _ <- mapM_ addContainer ns+ case (Seq.viewr verbatimContainers, lf) of+ -- don't add extra blank at beginning of fenced code block+ (_ :>FencedCode{}, BlankLine{}) -> pure ()+ _ -> addLeaf lineNumber lf++tabCrusher :: Parser ()+tabCrusher = do+ p <- getPosition+ replacing (go (column p - 1) "")+ where+ go cnt acc = do+ c <- peekChar+ case c of+ Just ' ' -> char ' ' *> go (cnt + 1) (acc <> " ")+ Just '\t' -> char '\t' *> go (cnt + 4 - (cnt `mod` 4)) (acc <> Text.replicate (4 - (cnt `mod` 4)) " ")+ _ -> pure acc++-- Try to match the scanners corresponding to any currently open containers.+-- Return remaining text after matching scanners, plus the number of open+-- containers whose scanners did not match. (These will be closed unless+-- we have a lazy text line.)+tryOpenContainers :: [Container] -> Text -> (Text, Int)+tryOpenContainers cs t =+ case runParser (scanners $ map containerContinue cs) t of+ Right (t', n) -> (t', n)+ Left e -> error $ "error parsing scanners: " ++ show e+ where+ scanners [] = (,0) <$> untilTheEnd+ scanners (p:ps) = (p *> scanners ps) <|> ((,length (p:ps)) <$> untilTheEnd)++-- Try to match parsers for new containers. Return list of new+-- container types, and the leaf to add inside the new containers.+tryNewContainers :: Bool -> Bool -> Int -> Text -> (Seq ContainerType, Leaf)+tryNewContainers afterListItem lastLineIsText offset t =+ case runParser newContainers t of+ Right (cs,t') -> (cs, t')+ Left err -> error (show err)+ where+ newContainers = do+ getPosition >>= \pos -> setPosition pos{ column = offset + 1 }+ regContainers <- Seq.fromList <$> many (containerStart afterListItem lastLineIsText)+ mVerbatimContainer <- optional $ verbatimContainerStart lastLineIsText+ case mVerbatimContainer of+ Just verbatimContainer -- FIXME: Very inefficient append+ -> (regContainers |> verbatimContainer,) <$> textLineOrBlank+ Nothing -> (regContainers,) <$> parseLeaf lastLineIsText++textLineOrBlank :: Parser Leaf+textLineOrBlank = consolidate <$> untilTheEnd+ where consolidate ts | Text.all (==' ') ts = BlankLine ts+ | otherwise = TextLine ts++-- Parse a leaf node.+parseLeaf :: Bool -> Parser Leaf+parseLeaf lastLineIsText = pNonIndentSpaces *> asum+ [ ATXHeading <$> parseAtxHeadingStart <*> parseAtxHeadingContent+ , guard lastLineIsText *> parseSetextToken+ , Rule <$ scanTBreakLine+ , textLineOrBlank+ ]++-- Scanners++scanReference :: Scanner+scanReference = void $ lookAhead (char '[')++-- Scan the beginning of a blockquote: up to three spaces+-- indent (outside of this scanner), the `>` character, and an optional space.+scanBlockquoteStart :: Scanner+scanBlockquoteStart = char '>' *> tabCrusher *> discardOpt (char ' ')++-- Parse the sequence of `#` characters that begins an ATX+-- header, and return the number of characters. We require+-- a space after the initial string of `#`s, as not all markdown+-- implementations do. This is because (a) the ATX reference+-- implementation requires a space, and (b) since we're allowing+-- headers without preceding blank lines, requiring the space+-- avoids accidentally capturing a line like `#8 toggle bolt` as+-- a header.+parseAtxHeadingStart :: Parser HeadingLevel+parseAtxHeadingStart = do+ _ <- char '#'+ hashes <- satisfyUpTo 5 (== '#')+ -- hashes must be followed by space unless empty header:+ notFollowedBy (skip ((/= ' ') <&&> (/= '\t')))+ pure $ case (Text.length hashes + 1) of+ 1 -> Heading1+ 2 -> Heading2+ 3 -> Heading3+ 4 -> Heading4+ 5 -> Heading5+ 6 -> Heading6+ _ -> error $ "IMPOSSIBLE HAPPENED: parseAtxHeading parsed more than 6 characters "+parseAtxHeadingContent :: Parser Text+parseAtxHeadingContent = Text.strip . removeATXSuffix <$> untilTheEnd+ where+ removeATXSuffix t =+ case dropTrailingHashes of+ t' | Text.null t' -> t'+ -- an escaped \#+ | Text.last t' == '\\' -> t' <> Text.replicate trailingHashes "#"+ | Text.last t' /= ' ' -> t+ | otherwise -> t'+ where+ dropTrailingSpaces = Text.dropWhileEnd (== ' ') t+ dropTrailingHashes = Text.dropWhileEnd (== '#') dropTrailingSpaces+ trailingHashes = Text.length dropTrailingSpaces - Text.length dropTrailingHashes++parseSetextToken :: Parser Leaf+parseSetextToken = fmap (uncurry SetextToken) $ withConsumed $ do+ d <- satisfy (\c -> c == '-' || c == '=')+ skipWhile (== d)+ void pBlankline+ pure $ if d == '=' then Heading1 else Heading2++-- Scan a horizontal rule line: "...three or more hyphens, asterisks,+-- or underscores on a line by themselves. If you wish, you may use+-- spaces between the hyphens or asterisks."+scanTBreakLine :: Scanner+scanTBreakLine = do+ c <- satisfy ((== '*') <||> (== '_') <||> (== '-'))+ replicateM_ 2 $ skipWhile ((== ' ') <||> (== '\t')) *> skip (== c)+ skipWhile ((== ' ') <||> (== '\t') <||> (== c))+ endOfInput++-- Parse an initial code fence line, returning+-- the fence part and the rest (after any spaces).+parseCodeFence :: Parser ContainerType+parseCodeFence = do+ col <- column <$> getPosition+ cs <- takeWhile1 (=='`') <|> takeWhile1 (=='~')+ guard $ Text.length cs >= 3+ void pSpaces+ rawattr <- optional (takeWhile1 (\c -> c /= '`' && c /= '~'))+ endOfInput+ pure FencedCode+ { codeStartColumn = col+ , codeFence = cs+ , codeInfo = rawattr+ }++pHtmlBlockStart :: Bool -> Parser Condition+pHtmlBlockStart lastLineIsText = lookAhead $ do+ discardOpt pNonIndentSpaces+ asum starters+ where+ starters =+ [ condition1 <$ blockStart condition1+ , condition2 <$ blockStart condition2+ , condition3 <$ blockStart condition3+ , condition4 <$ blockStart condition4+ , condition5 <$ blockStart condition5+ , condition6 <$ blockStart condition6+ , condition7 <$ if lastLineIsText then mzero else blockStart condition7+ ]++data Condition =+ Condition+ { blockStart :: Parser ()+ , blockEnd :: Parser ()+ }++instance Show Condition where+ show _ = "Condition{}"++instance Eq Condition where+ _ == _ = False++lineContains :: Foldable t => t Text -> Parser ()+lineContains terms = do+ line <- Text.toCaseFold <$> takeTill isLineEnding+ guard $ any (`Text.isInfixOf` line) terms++condition1, condition2, condition3, condition4, condition5, condition6, condition7 :: Condition+condition1 = Condition+ { blockStart = do+ _ <- asum $ map stringCaseless ["<script", "<pre", "<style"]+ void pWhitespace <|> void ">" <|> void pLineEnding <|> endOfInput+ , blockEnd = lineContains ["</script>", "</pre>", "</style>"]+ }++condition2 = Condition+ { blockStart = void "<!--"+ , blockEnd = void $ lineContains ["-->"]+ }++condition3 = Condition+ { blockStart = void "<?"+ , blockEnd = void $ lineContains ["?>"]+ }++condition4 = Condition+ { blockStart = void $ "<!" *> satisfy isAsciiUpper+ , blockEnd = void $ lineContains [">"]+ }++condition5 = Condition+ { blockStart = void $ "<![CDATA["+ , blockEnd = void $ lineContains ["]]>"]+ }++condition6 = Condition+ { blockStart = do+ void $ "</" <|> "<"+ tag <- takeTill (isWhitespace <||> (== '/') <||> (== '>'))+ guard $ isBlockHtmlTag (Text.toLower tag)+ void pWhitespace <|> void pLineEnding <|> void ">" <|> void "/>"+ , blockEnd = void pBlankline+ }++condition7 = Condition+ { blockStart = (openTag <|> closeTag) *> (void pWhitespace <|> endOfInput)+ , blockEnd = void pBlankline+ }+ where+ tagName = do+ c <- satisfy (inClass "A-Za-z")+ cs <- takeWhile ((== '-') <||> inClass "A-Za-z0-9")+ guard (Text.cons c cs `notElem` ["script", "style", "pre"])+ attr = pWhitespace *> attrName *> optional attrValueSpec+ attrName = satisfy (inClass "_:A-Za-z") *> skipWhile (inClass "A-Za-z0-9_.:-")+ attrValueSpec = optional pWhitespace *> char '=' *>+ optional pWhitespace *> attrValue+ attrValue = void unquoted <|> void singleQuoted <|> void doubleQuoted+ unquoted = skipWhile1 (notInClass " \"'=<>`")+ singleQuoted = "'" *> skipWhile (/= '\'') *> "'"+ doubleQuoted = "\"" *> skipWhile (/= '"') *> "\""+ openTag = "<" *> tagName *> many attr *> optional pWhitespace+ *> optional "/" *> ">"+ closeTag = "</" *> tagName *> optional pWhitespace *> ">"++-- List of block level tags for HTML 5.+isBlockHtmlTag :: Text -> Bool+isBlockHtmlTag name = Text.toLower name `Set.member` Set.fromList+ [ "address", "article", "aside", "base", "basefont", "blockquote"+ , "body", "caption", "center", "col", "colgroup", "dd", "details"+ , "dialog", "dir", "div", "dl", "dt", "fieldset", "figcaption"+ , "figure", "footer", "form", "frame", "frameset"+ , "h1", "h2", "h3", "h4", "h5", "h6", "head", "header"+ , "hr", "html", "iframe", "legend", "li", "link", "main"+ , "menu", "menuitem", "meta", "nav", "noframes", "ol", "optgroup"+ , "option", "p", "param", "section", "source", "summary", "table"+ , "tbody", "td", "tfoot", "th", "thead", "title", "tr", "track", "ul"+ ]++-- Parse a list marker and return the list type.+--+-- " 1. Content"+-- ^^ ^^-- contentPadding+-- \\-- markerPadding+parseListMarker :: Bool -> Bool -> Parser ContainerType+parseListMarker afterListItem lastLineIsText = do+ tabCrusher+ markerPadding <- Text.length <$> if afterListItem then pSpaces else pNonIndentSpaces+ ty <- parseBullet <|> parseListNumber lastLineIsText+ -- padding is 1 if list marker followed by a blank line+ -- or indented code. otherwise it's the length of the+ -- whitespace between the list marker and the following text:+ tabCrusher+ contentPadding <- (1 <$ pBlankline)+ <|> (1 <$ (skip (==' ') *> lookAhead pIndentSpaces))+ <|> (Text.length <$> pSpaces)+ -- text can't immediately follow the list marker:+ guard $ contentPadding > 0+ -- an empty list item cannot interrupt a paragraph+ when lastLineIsText $ notFollowedBy endOfInput+ pure ListItem+ { liType = ty+ , liPadding = markerPadding + contentPadding + listMarkerWidth ty+ }++listMarkerWidth :: ListType -> Int+listMarkerWidth (Bullet _) = 1+listMarkerWidth (Ordered _ n)+ | n < 10 = 2+ | n < 100 = 3+ | n < 1000 = 4+ | otherwise = 5++-- Parse a bullet and return list type.+parseBullet :: Parser ListType+parseBullet = do+ (bulletType, bulletChar) <- ((Plus,) <$> char '+')+ <|> ((Minus,) <$> char '-')+ <|> ((Asterisk,) <$> char '*')+ unless (bulletType == Plus) $+ notFollowedBy $ do+ -- hrule+ replicateM_ 2 $ do+ skipWhile ((== ' ') <||> (== '\t'))+ skip (== bulletChar)+ skipWhile (\x -> x == '\t' || x == ' ' || x == bulletChar)+ endOfInput+ return $ Bullet bulletType++-- Parse a list number marker and return list type.+parseListNumber :: Bool -> Parser ListType+parseListNumber lastLineIsText = do+ num :: Integer <- decimal+ when lastLineIsText $+ guard $ num == 1+ guard $ num < (10 ^ (9 :: Integer))+ wrap <- asum [Period <$ char '.', Paren <$ char ')']+ return $ Ordered wrap (fromInteger num)
+ src/Comark/Parser/Inline.hs view
@@ -0,0 +1,475 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Comark.Parser.Inline+ ( parseInlines+ , pReference+ , parseInfoString+ ) where++import Prelude hiding (takeWhile)++import Control.Applicative+import Control.Bool+import Control.Monad hiding (mapM_)+import Data.Char.Extended+import Data.Foldable (asum)+import Data.List (foldl')+import Data.Maybe+import Data.Monoid+import Data.Sequence+ (ViewL(..), singleton, viewl, (<|), (|>))+import qualified Data.Sequence.Extended as Seq+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as Text.Lazy+import qualified Data.Text.Lazy.Builder as Text.Lazy.Builder++import Comark.Parser.Inline.EmphLink+import Comark.Parser.Options (ParserOptions(..))+import Comark.Parser.Util+import Comark.ParserCombinators+import Comark.Syntax+import Comark.Syntax.Builder+import Text.Html.Email.Validate+import Text.Html.Entity++parseInlines :: ParserOptions -> Text -> Inlines Text+parseInlines opts input =+ case runParser (pInlines opts <* endOfInput) input of+ Left e ->+ error $ "[INTERNAL ERROR]: parseInlines: " <> show e+ Right r+ | _poNormalize opts -> normalizeInlines r+ | otherwise -> r++normalizeInlines :: Inlines Text -> Inlines Text+normalizeInlines =+ fmap (fmap (Text.Lazy.toStrict . Text.Lazy.Builder.toLazyText))+ . normalize+ . fmap (fmap Text.Lazy.Builder.fromText)++pInlines :: ParserOptions -> Parser (Inlines Text)+pInlines = fmap msum . many . pInline++pInline :: ParserOptions -> Parser (Inlines Text)+pInline opts =+ asum+ [ pText+ , pHardbreak+ , pSoftbreak+ , guard (_poParseEmphasis opts) *> pEmphLink opts+ , pBackslashed+ , pAutolink+ , pHtml+ , pCode+ , pEntity+ , pFallback+ ]++parseInfoString :: Text -> Text+parseInfoString t =+ case runParser (msum <$> many parser <* endOfInput) t of+ Left _ -> t+ Right is -> foldMap asText is+ where+ parser = pText <|> pBackslashed <|> pEntity++pText :: Parser (Inlines Text)+pText = str <$> takeWhile1 (not . isSpecial)++pFallback :: Parser (Inlines Text)+pFallback = str <$> (Text.singleton <$> satisfy isSpecial)++isSpecial :: Char -> Bool+isSpecial = inClass "\\`*_[]!&<\t\n\r "++-- | Either backslash-escaped punctuation or an actual backslash+pBackslashedChar :: Parser Text+pBackslashedChar =+ Text.singleton <$> (char '\\' *> option '\\' (satisfy isAsciiPunctuation))++-- Parses a (possibly escaped) character satisfying the predicate.+pSatisfy :: (Char -> Bool) -> Parser Char+pSatisfy p = asum+ [ satisfy ((/= '\\') <&&> p)+ , char '\\' *> satisfy (isAsciiPunctuation <&&> p)+ , guard (p '\\') *> char '\\'+ ]++pBackslashed :: Parser (Inlines Text)+pBackslashed = str <$> pBackslashedChar++pHardbreak :: Parser (Inlines Text)+pHardbreak =+ singleton HardBreak+ <$ asum [ void (char '\\'), spaceScape ] <* pLineEnding+ <* skipWhile (== ' ') -- ignore next line's leading spaces+ where+ spaceScape = do+ replicateM 2 (char ' ') -- two spaces+ skipWhile (== ' ') -- and more spaces (optionally)++pSoftbreak :: Parser (Inlines Text)+pSoftbreak =+ discardOpt (char ' ')+ *> pLineEnding+ *> pure (singleton SoftBreak)+ <* skipWhile (== ' ')++-- [ Code ] --------------------------------------------------------------------++pCode :: Parser (Inlines Text)+pCode = singleton <$> do+ startTicks <- backtickChunk+ let pEndTicks = string startTicks <* notFollowedBy (char '`')+ pContent = code <$> (codechunk `manyTill` pEndTicks)+ fallback = Str startTicks+ pContent <|> pure fallback+ where+ code = Code . Text.strip . Text.concat+ codechunk = backtickChunk <|> nonBacktickChunk <|> spaceChunk++ backtickChunk = takeWhile1 (== '`')+ nonBacktickChunk = takeWhile1 ((/= '`') <&&> (not . isCollapsableSpace))+ spaceChunk = " " <$ takeWhile1 isCollapsableSpace+ isCollapsableSpace = (== ' ') <||> isLineEnding++-- [ Raw Html ] ----------------------------------------------------------------+pHtml :: Parser (Inlines Text)+pHtml = singleton . RawHtml <$> consumedBy (asum scanners)+ where+ scanners =+ [ void tag, void comment, void instruction, void declaration, void cdata ]+ instruction = "<?" *> manyTill anyChar "?>"+ cdata = "<![CDATA[" *> manyTill anyChar "]]>"+ declaration = do+ "<!" *> skipWhile1 isAsciiUpper+ pWhitespace+ skipWhile (/= '>') <* char '>'+ comment = do+ "<!--" *> notFollowedBy (">" <|> "->")+ comm <- Text.pack <$> manyTill anyChar "-->"+ guard $ not $ or+ [ Text.head comm == '>'+ , "->" `Text.isPrefixOf` comm+ , Text.last comm == '-'+ , "--" `Text.isInfixOf` comm+ ]+ tag = openTag <|> closeTag+ where+ openTag = do+ "<" *> tagName+ many attr <* optional pWhitespace+ optional "/" *> ">"+ where+ attr = do+ pWhitespace *> attrName+ optional attrValueSpec+ where+ attrName = do+ satisfy ((isAscii <&&> isLetter) <||> inClass "_:")+ skipWhile ((isAscii <&&> (isLetter <||> isDigit)) <||> inClass "_:.-")+ attrValueSpec = do+ optional pWhitespace *> char '='+ optional pWhitespace *> attrValue+ attrValue =+ unquoted <|> singleQuoted <|> doubleQuoted+ where+ unquoted = skipWhile1 (notInClass " \"'=<>`")+ singleQuoted = char '\'' *> skipWhile (/= '\'') <* char '\''+ doubleQuoted = char '"' *> skipWhile (/= '"') <* char '"'+ closeTag =+ "</" *> tagName *> optional pWhitespace *> ">"+ tagName = do+ satisfy (isAscii <&&> isLetter)+ skipWhile ((== '-') <||> (isAscii <&&> (isLetter <||> isDigit)))++-- [ Entities ] ----------------------------------------------------------------++pEntity :: Parser (Inlines Text)+pEntity = str <$> pEntityText++pEntityText :: Parser Text+pEntityText = char '&' *> entityBody <* char ';'+ where+ entityBody =+ codepointEntity <|> namedEntity+ codepointEntity = do+ char '#'+ decEntity <|> hexEntity+ namedEntity = do+ name <- takeWhile1 (/= ';')+ -- asum works over Maybe. Nothing turns into mzero.+ asum (pure <$> entityNameChars name)+ <?> "not a named entity"+ decEntity =+ Text.singleton . chrSafe <$> decimal+ hexEntity = do+ char 'x' <|> char 'X'+ Text.singleton . chrSafe <$> hexadecimal++-- [ Autolinks ] ---------------------------------------------------------------+pAutolink :: Parser (Inlines Text)+pAutolink = char '<' *> (pUrl <|> pEmail) <* char '>'+ where pUrl = do+ scheme <- pScheme+ _ <- char ':'+ chars <- takeTill ((isAscii <&&> (isWhitespace <||> isControl))+ <||> (== '>') <||> (== '<'))+ let uri = scheme <> ":" <> chars+ pure $ singleton $ Link (str uri) uri Nothing+ pEmail = do+ email <- isValidEmail `mfilter` takeWhile1 (/= '>')+ pure $ singleton $+ Link (str email) ("mailto:" <> email) Nothing++pScheme :: Parser Text+pScheme = do+ a <- satisfy (isAscii <&&> isLetter)+ as <- takeWhile1 ((isAscii <&&> (isLetter <||> isDigit)) <||> (== '+') <||> (== '.') <||> (== '-'))+ mfilter ((<= 32) . Text.length) $ pure $ Text.cons a as++-- [ Emphasis, Links, and Images ] ---------------------------------------------++pEmphDelimToken :: EmphIndicator -> Parser Token+pEmphDelimToken indicator@(indicatorChar -> c) = do+ preceded <- peekLastChar+ delim <- takeWhile1 (== c)+ followed <- peekChar+ let isLeft = check followed preceded+ isRight = check preceded followed+ precededByPunctuation = fromMaybe False (isPunctuation <$> preceded)+ followedByPunctuation = fromMaybe False (isPunctuation <$> followed)+ canOpen =+ isLeft && (isAsterisk indicator || not isRight || precededByPunctuation)+ canClose =+ isRight && (isAsterisk indicator || not isLeft || followedByPunctuation)++ pure $ EmphDelimToken $ EmphDelim indicator (Text.length delim) canOpen canClose+ where+ check :: Maybe Char -> Maybe Char -> Bool+ check a b =+ and+ [ fromMaybe False (not . isUnicodeWhitespace <$> a)+ , or $ map (fromMaybe True)+ [ not . isPunctuation <$> a+ , (isUnicodeWhitespace <||> isPunctuation) <$> b+ ]+ ]++pLinkOpener :: Parser Token+pLinkOpener = do+ openerType <- option LinkOpener (ImageOpener <$ char '!')+ lbl <- optional (lookAhead pLinkLabel)+ _ <- char '['+ pure $ LinkOpenToken $ LinkOpen openerType True lbl mempty++pEmphLinkDelim :: Parser Token+pEmphLinkDelim = asum+ [ pEmphDelimToken AsteriskIndicator+ , pEmphDelimToken UnderscoreIndicator+ , pLinkOpener+ ]++pEmphTokens :: ParserOptions -> Parser DelimStack+pEmphTokens opts = do+ delim <- pEmphLinkDelim+ foldP+ (\ds -> (Just <$> step ds) <|> (Nothing <$ endOfInput))+ (Seq.singleton delim)+ where+ step ds = asum+ [ char ']' *> lookForLinkOrImage ds+ , (ds |>) <$> pEmphLinkDelim+ , addInlines ds+ <$> pInline opts { _poParseEmphasis = False }+ ]++ lookForLinkOrImage :: DelimStack -> Parser DelimStack+ lookForLinkOrImage ds =+ case Seq.findr isLinkOpener ds of+ Nothing -> pure (addInline ds closer)+ Just (suffix, LinkOpenToken opener, prefix) ->+ option fallback $ do+ guard (linkActive opener)+ addInlines (deactivating prefix) <$> pLink+ where+ fallback =+ addInlines prefix (unLinkOpen opener) <> addInline suffix closer+ constr =+ case linkOpenerType opener of+ LinkOpener -> Link+ ImageOpener -> Image+ deactivating =+ case linkOpenerType opener of+ LinkOpener -> fmap deactivate+ ImageOpener -> id+ content =+ foldMap unToken+ $ processEmphTokens+ $ InlineToken (linkContent opener) <| suffix+ pLink =+ pInlineLink constr content+ <|> pReferenceLink constr content (linkLabel opener)+ Just (_, _, _) ->+ error "lookForLinkOrImage: impossible happened. expected LinkOpenToken"+ where+ closer = Str "]"++ pInlineLink constr content = do+ char '(' *> optional pWhitespace+ dest <- option "" pLinkDest+ title <- optional (pWhitespace *> pLinkTitle <* optional pWhitespace)+ char ')'+ pure $ singleton $ constr content dest title++ pReferenceLink constr content lbl = do+ ref <- (Just <$> pLinkLabel) <|> (lbl <$ optional "[]")+ maybe mzero (pure . singleton . uncurry (constr content))+ (_poLinkReferences opts =<< ref)++pEmphLink :: ParserOptions -> Parser (Inlines Text)+pEmphLink opts =+ foldMap unToken . processEmphTokens <$> pEmphTokens opts++processEmphTokens :: DelimStack -> DelimStack+processEmphTokens = foldl' processEmphToken Seq.empty++processEmphToken :: DelimStack -> Token -> DelimStack+processEmphToken stack token =+ case token of+ InlineToken{} ->+ stack |> token+ LinkOpenToken{} ->+ processEmphToken stack (InlineToken $ unToken token)+ EmphDelimToken closing+ | emphCanOpen closing && not (emphCanClose closing) ->+ stack |> EmphDelimToken closing+ | emphCanClose closing ->+ case Seq.findr (matchOpening (emphIndicator closing)) stack of+ Nothing+ | emphCanClose closing ->+ stack |> EmphDelimToken closing+ | otherwise ->+ stack |> InlineToken (unEmphDelim closing)+ Just (viewl -> EmptyL, _, _) -> stack+ Just (content, EmphDelimToken opening, rest)+ | emphCanOpen closing && ((emphLength opening + emphLength closing) `mod` 3) == 0 ->+ stack |> EmphDelimToken closing+ | otherwise ->+ matchEmphStrings rest opening closing+ (foldMap unToken content)+ Just (_, _, _) ->+ error "processEmphToken: Impossible happened. Expected EmphDelimToken"+ | otherwise ->+ stack |> InlineToken (unEmphDelim closing)+ where+ matchOpening ch (EmphDelimToken d) = emphIndicator d == ch && emphCanOpen d+ matchOpening _ _ = False++matchEmphStrings :: DelimStack -> EmphDelim -> EmphDelim -> Inlines Text -> DelimStack+matchEmphStrings stack opening closing content+ | emphIndicator opening == emphIndicator closing = if+ | emphLength closing == emphLength opening ->+ stack+ |> InlineToken (emph (emphLength closing) content)+ | emphLength closing < emphLength opening ->+ stack+ |> EmphDelimToken opening+ { emphLength = emphLength opening - emphLength closing }++ |> InlineToken (emph (emphLength closing) content)+ | emphLength closing > emphLength opening ->+ processEmphToken+ (stack |> InlineToken (emph (emphLength opening) content))+ (EmphDelimToken closing+ { emphLength = emphLength closing - emphLength opening})+ | otherwise -> stack+ | otherwise = stack++emph :: Int -> Inlines Text -> Inlines Text+emph n content+ | n <= 0 = content+ | even n = single Strong $ emph (n - 2) content+ | otherwise = single Emph $ emph (n - 1) content+ where+ single f is =+ f is <$ guard (not $ Seq.null is)++pLinkLabel :: Parser Text+pLinkLabel = char '[' *> (Text.concat <$> someTill chunk (char ']'))+ where+ chunk = regChunk <|> bracketChunk <|> backslashChunk+ regChunk = takeWhile1 (`notElem` ("[]\\" :: [Char]))+ bracketChunk = char '\\' *> ("[" <|> "]")+ backslashChunk = "\\\\"++pLinkDest :: Parser Text+pLinkDest = pointy <|> nonPointy+ where+ pointy = char '<' *> (Text.concat <$> many chunk) <* char '>'+ where+ chunk = asum+ [ takeWhile1 (`notElem` [' ', '\r', '\n', '>', '<', '\\'])+ , Text.singleton <$> pSatisfy (`notElem` [' ', '\r', '\n', '>', '<'])+ ]+ nonPointy = Text.concat <$> some chunk+ where+ chunk = asum+ [ takeWhile1 (notInClass " ()\\&" <&&> not . isControl)+ , pEntityText+ , pBackslashedChar+ , parenthesize . Text.concat <$> do+ char '('+ manyTill chunk (char ')')+ ]++pLinkTitle :: Parser Text+pLinkTitle = surroundedWith ("('\"'" :: [Char])+ where+ surroundedWith openers = do+ opener <- satisfy (`elem` openers)+ let ender = if opener == '(' then ')' else opener+ pEnder = char ender <* notFollowedBy (skip isAlphaNum)+ regChunk = asum+ [ takeWhile1 ((/= ender) <&&> (/= '\\') <&&> (/= '&'))+ , pEntityText+ , "&"+ , pBackslashedChar+ ]+ nestedChunk = parenthesize <$> surroundedWith "("+ Text.concat <$> manyTill (regChunk <|> nestedChunk) pEnder++pReference :: Parser (Text, Text, Maybe Text)+pReference = do+ lab <- pLinkLabel <* char ':'+ guard $ isJust $ Text.find (not . isWhitespace) lab+ scanWhitespaceNL+ url <- pLinkDest <* skipWhile whitespaceNoNL+ titleOnNewLine <- isJust <$> optional pLineEnding+ skipWhile whitespaceNoNL+ title <-+ if titleOnNewLine+ then optional $+ pLinkTitle <* do+ skipWhile whitespaceNoNL+ endOfInput <|> void pLineEnding+ else optional pLinkTitle <* do+ skipWhile whitespaceNoNL+ endOfInput <|> void pLineEnding+ pure (lab, url, title)+ where+ -- | optional scanWhitespace (including up to one line ending)+ scanWhitespaceNL = do+ skipWhile whitespaceNoNL+ optional pLineEnding+ skipWhile whitespaceNoNL+ whitespaceNoNL =+ isWhitespace <&&> not . isLineEnding+
+ src/Comark/Parser/Inline/EmphLink.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+-- | Code and data types for parsing emphasis and links+module Comark.Parser.Inline.EmphLink where++import Data.Text (Text)+import qualified Data.Text as Text++import Comark.Syntax++import Data.Sequence (Seq, ViewR(..), singleton, viewr, (<|), (><), (|>))++type DelimStack = Seq Token++data EmphDelim+ = EmphDelim+ { emphIndicator :: EmphIndicator+ , emphLength :: Int+ , emphCanOpen :: Bool+ , emphCanClose :: Bool+ }+ deriving (Show, Eq)++unEmphDelim :: EmphDelim -> Inlines Text+unEmphDelim EmphDelim{..} =+ singleton . Str+ . Text.replicate emphLength+ . Text.singleton . indicatorChar+ $ emphIndicator++data LinkOpen+ = LinkOpen+ { linkOpenerType :: OpenerType+ , linkActive :: Bool+ , linkLabel :: Maybe Text+ , linkContent :: Inlines Text+ }+ deriving (Show, Eq)++unLinkOpen :: LinkOpen -> Inlines Text+unLinkOpen l =+ case linkOpenerType l of+ LinkOpener -> Str "["+ ImageOpener -> Str "!["+ <| linkContent l++data Token+ = InlineToken (Inlines Text)+ | EmphDelimToken EmphDelim+ | LinkOpenToken LinkOpen+ deriving (Show, Eq)++unToken :: Token -> Inlines Text+unToken (InlineToken is) = is+unToken (EmphDelimToken e) = unEmphDelim e+unToken (LinkOpenToken l) = unLinkOpen l++isLinkOpener :: Token -> Bool+isLinkOpener LinkOpenToken{} = True+isLinkOpener _ = False++isEmphDelim :: Token -> Bool+isEmphDelim EmphDelimToken{} = True+isEmphDelim _ = False++data EmphIndicator+ = AsteriskIndicator+ | UnderscoreIndicator+ deriving (Show, Eq)++isAsterisk :: EmphIndicator -> Bool+isAsterisk AsteriskIndicator = True+isAsterisk UnderscoreIndicator = False++indicatorChar :: EmphIndicator -> Char+indicatorChar AsteriskIndicator = '*'+indicatorChar UnderscoreIndicator = '_'++data OpenerType+ = LinkOpener+ | ImageOpener+ deriving (Show, Eq)++deactivate :: Token -> Token+deactivate (LinkOpenToken l) =+ LinkOpenToken l+ { linkActive = linkOpenerType l == ImageOpener }+deactivate t = t++addInline :: DelimStack -> Inline Text -> DelimStack+addInline (viewr -> ts :> LinkOpenToken l) i =+ ts |> LinkOpenToken l+ { linkContent = linkContent l |> i }+addInline (viewr -> ts :> InlineToken is) i =+ ts |> InlineToken (is |> i)+addInline ts i =+ ts |> InlineToken (singleton i)++addInlines :: DelimStack -> Inlines Text -> DelimStack+addInlines (viewr -> ts :> InlineToken is) i =+ ts |> InlineToken (is >< i)+addInlines (viewr -> ts :> LinkOpenToken l) i =+ ts |> LinkOpenToken l { linkContent = linkContent l >< i }+addInlines ts i = ts |> InlineToken i
+ src/Comark/Parser/Options.hs view
@@ -0,0 +1,58 @@+module Comark.Parser.Options+ ( ParserOption(..)+ , ParserOptions()+ , parserOptions+ , _poNormalize+ , _poLinkReferences+ , _poParseEmphasis+ ) where++import Control.Applicative ((<|>))+import Data.Monoid (Endo(Endo, appEndo))+import Data.Text (Text)++data ParserOption+ = -- | Consolidate adjacent text nodes.+ Normalize+ -- | Predefine+ -- <http://spec.commonmark.org/0.20/#link-reference-definition link reference defenitions>.+ --+ -- References are represented with a mapping from a+ -- <http://spec.commonmark.org/0.20/#link-text link text> to a pair of a+ -- <http://spec.commonmark.org/0.20/#link-destination link destination>+ -- and an optional+ -- <http://spec.commonmark.org/0.20/#link-title link title>.+ --+ -- During parsing the link references defined in a document would be+ -- collected into additional mapping. When link references are being+ -- mapping defined in options takes precedence over mapping found in+ -- the document.+ --+ -- TODO: Examples+ | LinkReferences (Text -> Maybe (Text, Maybe Text))++data ParserOptions = ParserOptions+ { _poNormalize :: Bool+ , _poLinkReferences :: Text -> Maybe (Text, Maybe Text)+ , _poParseEmphasis :: Bool+ }++instance Monoid ParserOptions where+ mempty = ParserOptions+ { _poNormalize = False+ , _poLinkReferences = const Nothing+ , _poParseEmphasis = True+ }+ mappend a b =+ b { _poLinkReferences =+ \t -> _poLinkReferences b t <|> _poLinkReferences a t+ }++parserOptions :: [ParserOption] -> ParserOptions+parserOptions = ($ mempty) . appEndo . foldMap (Endo . optFn)+ where+ optFn :: ParserOption -> ParserOptions -> ParserOptions+ optFn Normalize o = o+ { _poNormalize = True }+ optFn (LinkReferences f) o = o+ { _poLinkReferences = \t -> f t <|> _poLinkReferences o t }
+ src/Comark/Parser/Util.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+module Comark.Parser.Util+ ( Scanner ()+ , isLineEnding+ , pLineEnding+ , isWhitespace+ , pWhitespace+ , pSpaces+ , pSpacesUpToColumn+ , pIndentSpaces+ , pNonIndentSpaces+ , pBlankline+ , isUnicodeWhitespace+ , isAsciiPunctuation+ , satisfyUpTo+ , lookupLinkReference+ , ReferenceMap+ , normalizeReference+ , parenthesize+ ) where++import Control.Applicative+import Control.Bool+import Control.Monad+import Data.Char+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text.Extended as Text+import Prelude hiding (takeWhile)++import Comark.ParserCombinators++type Scanner = Parser ()++type ReferenceMap = Map Text (Text,Maybe Text)++-- | Predicate for line ending character (newline or carriage return).+-- NB: something like `satisfy isLineEnding` won't properly parse a+-- line ending, when given '\r\n' as input it would just consume '\r'+-- leaving '\n' unconsumed. In such cases one should use 'pLineEnding'+-- instead+isLineEnding :: Char -> Bool+isLineEnding = (== '\r') <||> (== '\n')++-- | A newline (U+000A), carriage return (U+000D), or carriage return followed by newline.+pLineEnding :: Parser Text+pLineEnding = "\n" <|> "\r\n" <|> "\r"++-- | A [whitespace character] as in spec+isWhitespace :: Char -> Bool+isWhitespace = (`elem` (" \t\n\r\f\v" :: [Char]))++-- | [whitespace] as in spec+pWhitespace :: Parser Text+pWhitespace = takeWhile1 isWhitespace++pSpaces :: Parser Text+pSpaces = takeWhile (== ' ')++pSpacesUpToColumn :: Int -> Parser Text+pSpacesUpToColumn col = do+ currentCol <- column <$> getPosition+ let distance = col - currentCol+ if distance >= 1+ then satisfyUpTo distance (== ' ')+ else pure ""++pIndentSpaces :: Parser Text+pIndentSpaces = do+ nonIndentSpaces <- pNonIndentSpaces+ let count0 = Text.length nonIndentSpaces+ (count1, moreSpace) <- ((4,) <$> char '\t')+ <|> ((1,) <$> char ' ')+ if count0 + count1 < 4+ then mzero+ else pure $ Text.snoc nonIndentSpaces moreSpace++-- Scan 0-3 spaces.+pNonIndentSpaces :: Parser Text+pNonIndentSpaces = satisfyUpTo 3 (== ' ')++pBlankline :: Parser Text+pBlankline = pSpaces <* endOfInput++-- | [unicode whitespace] as in spec+isUnicodeWhitespace :: Char -> Bool+isUnicodeWhitespace = isSpace++isAsciiPunctuation :: Char -> Bool+isAsciiPunctuation = inClass "!\"#$%&'()*+,./:;<=>?@[\\]^_`{|}~-"++satisfyUpTo :: Int -> (Char -> Bool) -> Parser Text+satisfyUpTo cnt f =+ scan 0 $ \n c ->+ n + 1 <$ guard (n < cnt && f c)++lookupLinkReference+ :: ReferenceMap+ -> Text -- reference label+ -> Maybe (Text, Maybe Text) -- (url, title)+lookupLinkReference refmap key =+ Map.lookup (normalizeReference key) refmap++normalizeReference :: Text -> Text+normalizeReference = Text.toCaseFold . Text.concat . Text.split isSpace++parenthesize :: Text -> Text+parenthesize x = "(" <> x <> ")"
+ src/Comark/ParserCombinators.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+module Comark.ParserCombinators (+ Position(..)+ , Parser+ , ParseError(..)+ , runParser+ , runParserWithUnconsumed+ , (<?>)+ , satisfy+ , withConsumed+ , consumedBy+ , peekChar+ , peekLastChar+ , notAfter+ , inClass+ , notInClass+ , endOfInput+ , char+ , anyChar+ , getPosition+ , setPosition+ , takeWhile+ , takeTill+ , takeWhile1+ , untilTheEnd+ , skip+ , skipWhile+ , skipWhile1+ , replacing+ , string+ , stringCaseless+ , scan+ , lookAhead+ , notFollowedBy+ , option+ , foldP+ , manyTill+ , someTill+ , sepBy1+ , sepEndBy1+ , sepStartEndBy1+ , skipMany+ , skipMany1+ , discardOpt+ , decimal+ , hexadecimal+ ) where+import Control.Applicative+import Control.Monad+import Data.Bits (Bits, shiftL, (.|.))+import qualified Data.Char as Char+import qualified Data.Set as Set+import Data.String+import Data.Text (Text)+import qualified Data.Text as Text++import Prelude hiding (takeWhile)++import Comark.ParserCombinators.Prim++notAfter :: (Char -> Bool) -> Parser ()+notAfter f = do+ mbc <- peekLastChar+ case mbc of+ Nothing -> return ()+ Just c -> if f c then mzero else return ()++-- low-grade version of attoparsec's:+charClass :: String -> Set.Set Char+charClass = Set.fromList . go+ where go (a:'-':b:xs) = [a..b] ++ go xs+ go (x:xs) = x : go xs+ go _ = ""+{-# INLINE charClass #-}++inClass :: String -> Char -> Bool+inClass s c = c `Set.member` s'+ where s' = charClass s+{-# INLINE inClass #-}++notInClass :: String -> Char -> Bool+notInClass s = not . inClass s+{-# INLINE notInClass #-}++char :: Char -> Parser Char+char c = satisfy (== c)+{-# INLINE char #-}++anyChar :: Parser Char+anyChar = satisfy (const True)+{-# INLINE anyChar #-}++takeTill :: (Char -> Bool) -> Parser Text+takeTill f = takeWhile (not . f)+{-# INLINE takeTill #-}++foldP :: (b -> Parser (Maybe b)) -> b -> Parser b+foldP f = foldP' (\s _ -> f s) (pure ())++-- | A folding parser with input supplying funciton+foldP' :: (b -> a -> Parser (Maybe b))+ -> Parser a -- ^ A parser that supplies more input+ -> b -- ^ Initial value+ -> Parser b+foldP' f p b0 = p >>= go b0+ where go b1 a = f b1 a >>= \case Nothing -> pure b1+ Just b2 -> p >>= go b2++{-# INLINE foldP' #-}++-- combinators (most definitions borrowed from attoparsec)++option :: Alternative f => a -> f a -> f a+option x p = p <|> pure x+{-# INLINE option #-}++discardOpt :: Alternative f => f a -> f ()+discardOpt p = option () (void p)++someTill :: Alternative f => f a -> f b -> f [a]+someTill p end = liftA2 (:) p go+ where go = (end *> pure []) <|> liftA2 (:) p go+{-# INLINE someTill #-}++manyTill :: Alternative f => f a -> f b -> f [a]+manyTill p end = go+ where go = (end *> pure []) <|> liftA2 (:) p go+{-# INLINE manyTill #-}++sepBy1 :: Alternative f => f a -> f s -> f [a]+sepBy1 p s = go+ where go = liftA2 (:) p ((s *> go) <|> pure [])++sepEndBy1 :: Alternative f => f a -> f s -> f [a]+sepEndBy1 p s = sepBy1 p s <* s++sepStartEndBy1 :: Alternative f => f a -> f s -> f [a]+sepStartEndBy1 p s = s *> sepBy1 p s <* s++skipMany :: Alternative f => f a -> f ()+skipMany p = go+ where go = (p *> go) <|> pure ()+{-# INLINE skipMany #-}++skipMany1 :: Alternative f => f a -> f ()+skipMany1 p = p *> skipMany p+{-# INLINE skipMany1 #-}++-- | Parse and decode an unsigned decimal number.+decimal :: Integral a => Parser a+decimal = Text.foldl' step 0 `fmap` takeWhile1 Char.isDigit+ where step a c = a * 10 + fromIntegral (Char.ord c - 48)++hexadecimal :: (Integral a, Bits a) => Parser a+hexadecimal = Text.foldl' step 0 `fmap` takeWhile1 isHexDigit+ where+ isHexDigit c = (c >= '0' && c <= '9') ||+ (c >= 'a' && c <= 'f') ||+ (c >= 'A' && c <= 'F')+ step a c | w >= 48 && w <= 57 = (a `shiftL` 4) .|. fromIntegral (w - 48)+ | w >= 97 = (a `shiftL` 4) .|. fromIntegral (w - 87)+ | otherwise = (a `shiftL` 4) .|. fromIntegral (w - 55)+ where w = Char.ord c
+ src/Comark/ParserCombinators/Prim.hs view
@@ -0,0 +1,328 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+module Comark.ParserCombinators.Prim+ ( Position(..)+ , Parser()+ , runParser+ , ParserState()+ , ParseError(..)+ , withConsumed+ , consumedBy+ , string+ , (<?>)+ , runParserWithUnconsumed+ , getPosition+ , setPosition+ , satisfy+ , peekChar+ , peekLastChar+ , replacing+ , endOfInput+ , takeWhile+ , takeWhile1+ , untilTheEnd+ , skip+ , skipWhile+ , skipWhile1+ , stringCaseless+ , scan+ , lookAhead+ , notFollowedBy+ ) where++import Control.Applicative+import Control.Monad+import Data.String+import Data.Text (Text)+import qualified Data.Text as Text+import Prelude hiding (takeWhile)++data Position+ = Position+ { line :: Int+ , column :: Int+ , point :: Int+ } deriving (Ord, Eq)++instance Show Position where+ show (Position ln cn pn) =+ concat ["line ", show ln, " column ", show cn, " point ", show pn]++data ParseError+ = ParseError+ { parseErrorPosition :: Position+ , parseErrorReason :: String+ } deriving (Show)++data ParserState+ = ParserState+ { subject :: Text+ , position :: Position+ , lastChar :: Maybe Char+ }++advance :: ParserState -> Text -> ParserState+advance = Text.foldl' go+ where+ go :: ParserState -> Char -> ParserState+ go st c =+ ParserState+ { subject = Text.drop 1 (subject st)+ , position =+ case c of+ '\n' -> Position+ { line = line (position st) + 1+ , column = 1+ , point = point (position st) + 1+ }+ _ -> Position+ { line = line (position st)+ , column = column (position st) + 1+ , point = point (position st) + 1+ }+ , lastChar = Just c+ }++newtype Parser a+ = Parser+ { evalParser :: ParserState -> Either ParseError (ParserState, a) }++-- | Returns the text that was consumed by a parser alongside with its result+withConsumed :: Parser a -> Parser (a,Text)+withConsumed p = Parser $ \st ->+ case (evalParser p) st of+ Left err -> Left err+ Right (st', res) ->+ let consumedLength = point (position st') - point (position st)+ in Right (st', (res, Text.take consumedLength (subject st)))++consumedBy :: Parser a -> Parser Text+consumedBy = fmap snd . withConsumed++instance Functor Parser where+ fmap f (Parser g) = Parser $ \st ->+ case g st of+ Right (st', x) -> Right (st', f x)+ Left e -> Left e+ {-# INLINE fmap #-}++instance Applicative Parser where+ pure x = Parser $ \st -> Right (st, x)+ (Parser f) <*> (Parser g) = Parser $ \st ->+ case f st of+ Left e -> Left e+ Right (st', h) -> case g st' of+ Right (st'', x) -> Right (st'', h x)+ Left e -> Left e+ {-# INLINE pure #-}+ {-# INLINE (<*>) #-}++instance Alternative Parser where+ empty = Parser $ \st -> Left $ ParseError (position st) "(empty)"+ (Parser f) <|> (Parser g) = Parser $ \st ->+ case f st of+ Right res -> Right res+ Left (ParseError pos msg) ->+ case g st of+ Right res -> Right res+ Left (ParseError pos' msg') -> Left $+ case () of+ -- return error for farthest match+ _ | pos' > pos -> ParseError pos' msg'+ | pos' < pos -> ParseError pos msg+ | otherwise {- pos' == pos -}+ -> ParseError pos (msg ++ " or " ++ msg')+ {-# INLINE empty #-}+ {-# INLINE (<|>) #-}++instance Monad Parser where+ return x = Parser $ \st -> Right (st, x)+ fail e = Parser $ \st -> Left $ ParseError (position st) e+ p >>= g = Parser $ \st ->+ case evalParser p st of+ Left e -> Left e+ Right (st',x) -> evalParser (g x) st'+ {-# INLINE return #-}+ {-# INLINE (>>=) #-}++instance MonadPlus Parser where+ mzero = Parser $ \st -> Left $ ParseError (position st) "(mzero)"+ mplus p1 p2 = Parser $ \st ->+ case evalParser p1 st of+ Right res -> Right res+ Left _ -> evalParser p2 st+ {-# INLINE mzero #-}+ {-# INLINE mplus #-}++instance (a ~ Text) => IsString (Parser a) where+ fromString = string . Text.pack++string :: Text -> Parser Text+string s = Parser $ \st ->+ if s `Text.isPrefixOf` (subject st)+ then success (advance st s) s+ else failure st "string"+{-# INLINE string #-}++failure :: ParserState -> String -> Either ParseError (ParserState, a)+failure st msg = Left $ ParseError (position st) msg+{-# INLINE failure #-}++success :: ParserState -> a -> Either ParseError (ParserState, a)+success st x = Right (st, x)+{-# INLINE success #-}++(<?>) :: Parser a -> String -> Parser a+p <?> msg = Parser $ \st ->+ let startpos = position st in+ case evalParser p st of+ Left (ParseError _ _) ->+ Left $ ParseError startpos msg+ Right r -> Right r+{-# INLINE (<?>) #-}+infixl 5 <?>++runParser :: Parser a -> Text -> Either ParseError a+runParser p t =+ fmap snd $ evalParser p ParserState { subject = t+ , position = Position 1 1 1+ , lastChar = Nothing+ }++runParserWithUnconsumed :: Parser a -> Text -> Either ParseError (a,Text)+runParserWithUnconsumed p t =+ fmap (\(st,res) -> (res, subject st))+ $ evalParser p ParserState { subject = t+ , position = Position 1 1 1+ , lastChar = Nothing+ }++getState :: Parser ParserState+getState = Parser (\st -> success st st)++getPosition :: Parser Position+getPosition = position <$> getState+{-# INLINE getPosition #-}++satisfy :: (Char -> Bool) -> Parser Char+satisfy f = Parser g+ where g st = case Text.uncons (subject st) of+ Just (c, _) | f c ->+ success (advance st (Text.singleton c)) c+ _ -> failure st "character meeting condition"+{-# INLINE satisfy #-}++-- | Get the next character without consuming it.+peekChar :: Parser (Maybe Char)+peekChar = maybeHead . subject <$> getState+ where maybeHead = fmap fst . Text.uncons+{-# INLINE peekChar #-}++-- | Get the last consumed character.+peekLastChar :: Parser (Maybe Char)+peekLastChar = lastChar <$> getState+{-# INLINE peekLastChar #-}++-- | Takes a parser that returns a 'Text', runs that+-- parser consuming some input and then prepends the+-- result to the rest of subject.+replacing :: Parser Text -> Parser ()+replacing p = do+ s0 <- getState+ t <- p+ s1Subject <- subject <$> getState+ Parser $ \_ -> success s0 { subject = Text.append t s1Subject } ()++endOfInput :: Parser ()+endOfInput = Parser $ \st ->+ if Text.null (subject st)+ then success st ()+ else failure st "end of input"+{-# INLINE endOfInput #-}++-- note: this does not actually change the position in the subject;+-- it only changes what column counts as column N. It is intended+-- to be used in cases where we're parsing a partial line but need to+-- have accurate column information.+setPosition :: Position -> Parser ()+setPosition pos = Parser $ \st -> success st{ position = pos } ()+{-# INLINE setPosition #-}++takeWhile :: (Char -> Bool) -> Parser Text+takeWhile f = Parser $ \st ->+ let t = Text.takeWhile f (subject st) in+ success (advance st t) t+{-# INLINE takeWhile #-}++takeWhile1 :: (Char -> Bool) -> Parser Text+takeWhile1 f = Parser $ \st ->+ case Text.takeWhile f (subject st) of+ t | Text.null t -> failure st "characters satisfying condition"+ | otherwise -> success (advance st t) t+{-# INLINE takeWhile1 #-}++-- | Consumes all the available input (until endOfInput) and returns it.+untilTheEnd :: Parser Text+untilTheEnd = Parser $ \st ->+ success (advance st (subject st)) (subject st)+{-# INLINE untilTheEnd #-}++skip :: (Char -> Bool) -> Parser ()+skip f = Parser $ \st ->+ case Text.uncons (subject st) of+ Just (c,_) | f c -> success (advance st (Text.singleton c)) ()+ _ -> failure st "character satisfying condition"+{-# INLINE skip #-}+++skipWhile :: (Char -> Bool) -> Parser ()+skipWhile f = Parser $ \st ->+ let t' = Text.takeWhile f (subject st) in+ success (advance st t') ()+{-# INLINE skipWhile #-}++skipWhile1 :: (Char -> Bool) -> Parser ()+skipWhile1 f = Parser $ \st ->+ case Text.takeWhile f (subject st) of+ t' | Text.null t' -> failure st "characters satisfying condition"+ | otherwise -> success (advance st t') ()+{-# INLINE skipWhile1 #-}++stringCaseless :: Text -> Parser Text+stringCaseless (Text.toCaseFold -> s) = Parser $ \st ->+ if Text.toCaseFold s `Text.isPrefixOf` Text.toCaseFold (subject st)+ then success (advance st s) s+ else failure st "stringCaseless"++{-# INLINE stringCaseless #-}++scan :: s -> (s -> Char -> Maybe s) -> Parser Text+scan s0 f = Parser $ go s0 []+ where go s cs st =+ case Text.uncons (subject st) of+ Nothing -> finish st cs+ Just (c, _) -> case f s c of+ Just s' -> go s' (c:cs)+ (advance st (Text.singleton c))+ Nothing -> finish st cs+ finish st cs =+ success st (Text.pack (reverse cs))+{-# INLINE scan #-}++lookAhead :: Parser a -> Parser a+lookAhead p = Parser $ \st ->+ either+ (const (failure st "lookAhead"))+ (success st . snd)+ (evalParser p st)+{-# INLINE lookAhead #-}++notFollowedBy :: Parser a -> Parser ()+notFollowedBy p = Parser $ \st ->+ either+ (const (success st ()))+ (const (failure st "notFollowedBy"))+ (evalParser p st)+{-# INLINE notFollowedBy #-}+
+ src/Text/Html/Email/Validate.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+module Text.Html.Email.Validate+ ( isValidEmail+ ) where++import Comark.ParserCombinators+import Control.Monad+import Data.Either (isRight)+import Data.Text (Text)+import qualified Data.Text as Text++isValidEmail :: Text -> Bool+isValidEmail = isRight . runParser (scanEmail *> endOfInput)++scanEmail :: Parser ()+scanEmail = local *> char '@' *> domain++local :: Parser ()+local = skipWhile1 (inClass "A-Za-z0-9!#$%&'*+/=?^_`{|}~.-")++domain :: Parser ()+domain = () <$ label `sepBy1` char '.'++label :: Parser ()+label = do+ lbl <- Text.intercalate "-" <$> labelChars `sepBy1` char '-'+ guard (Text.length lbl <= 63) <?> "Label is too long"+ where+ labelChars = takeWhile1 (inClass "A-Za-z0-9")
+ tests/Blocks.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Blocks where++import Test.Hspec++import Comark.Parser+import Comark.Syntax+import Comark.TestUtils.CMark+import Comark.TestUtils.Spec++import Control.Monad+import Data.Generics+import Unsafe.Coerce++import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as Text++testBlock :: Spec+testBlock = do+ describe "Block tests from specification" $ do+ forM_ blockTests $ \SpecTest{..} -> do+ it (show testNumber ++ ": " ++ show testSection) $+ normalizeDoc (parse [Normalize] testIn)+ `shouldBe` normalizeDoc testOut++-- As CMark's AST doesn't preserve the character which was used to indicate+-- bullet lists, we need to change all Bullets to the same character+normalizeDoc :: Data a => Doc a -> Doc a+normalizeDoc = everywhere (mkT stripHtmlBlock) . everywhere (mkT changeBullet)+ where+ changeBullet (Bullet _) = Bullet Minus+ changeBullet a = a+ stripHtmlBlock (HtmlBlock t) = HtmlBlock $ Text.strip t+ stripHtmlBlock a = a++blockTests :: [SpecTest Text (Doc Text)]+blockTests =+ unsafeCoerce $ filter (isNothing . docInline . testOut) $+ [ t { testOut = nodeToDoc $ commonmarkToNode [optNormalize] $ testIn t }+ | t <- spec+ ]
+ tests/Inline.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE RecordWildCards #-}+module Inline where++import Data.Text (Text)+import qualified Data.Text as Text+import Test.Hspec++import Data.Maybe+import qualified Data.Sequence as Seq++import Comark.Parser as Comark+import Comark.Syntax+import Comark.TestUtils.CMark+import Comark.TestUtils.Spec++import Control.Monad+import Data.Foldable (toList)+import Unsafe.Coerce++testInline :: Spec+testInline = do+ describe "Inline tests from specification" $ do+ forM_ inlineTests $ \SpecTest{..} -> do+ it (show testNumber ++ ": " ++ show testSection) $ do+ let actual = Comark.parse [Normalize] testIn+ expected = normalizeDoc $ nodeToDoc $ commonmarkToNode [optNormalize]+ testIn+ case docInline (unsafeCoerce actual) of+ Just is -> toList is `shouldBe`+ toList (fromJust (docInline expected))+ Nothing -> unDoc actual `shouldBe` unDoc (unsafeCoerce expected)++inlineTests :: [SpecTest Text Text]+inlineTests =+ filter (isJust . docInline . nodeToDoc . commonmarkToNode [] . testIn) spec++normalizeDoc :: Doc Text -> Doc Text+normalizeDoc (Doc blocks) = Doc $ fmap m blocks+ where+ m (Heading a b) = Heading a $ (dropEmptyStrs . normalize) b+ m (Para a) = Para $ (dropEmptyStrs . normalize) a+ m (Quote a) = Quote $ fmap m a+ m (List a b c) = List a b $ fmap (fmap m) c+ m a = a++ dropEmptyStrs = Seq.filter (not . isEmptyStr)++ isEmptyStr (Str a) = Text.null a+ isEmptyStr _ = False++unDoc :: Doc Text -> [Block Text]+unDoc (Doc bs) = toList bs
+ tests/Main.hs view
@@ -0,0 +1,24 @@+module Main where++import Blocks+import Inline+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck++import Control.DeepSeq+import Data.Text (pack)++import Comark.Parser+import Comark.Parser.Options+import Comark.Syntax++main :: IO ()+main = do+ hspec $ do+ testInline+ testBlock++ describe "Properties" $ do+ prop "Any sequence of characters is a valid input"+ (\t -> parse [] (pack t) `deepseq` True)