diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -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 diff --git a/comark-parser.cabal b/comark-parser.cabal new file mode 100644 --- /dev/null +++ b/comark-parser.cabal @@ -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 +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 diff --git a/extended/Data/Char/Extended.hs b/extended/Data/Char/Extended.hs new file mode 100644 --- /dev/null +++ b/extended/Data/Char/Extended.hs @@ -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' diff --git a/extended/Data/Sequence/Extended.hs b/extended/Data/Sequence/Extended.hs new file mode 100644 --- /dev/null +++ b/extended/Data/Sequence/Extended.hs @@ -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) diff --git a/extended/Data/Text/Extended.hs b/extended/Data/Text/Extended.hs new file mode 100644 --- /dev/null +++ b/extended/Data/Text/Extended.hs @@ -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' diff --git a/src/Comark/Parser.hs b/src/Comark/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Comark/Parser.hs @@ -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 [" void ">" <|> void pLineEnding <|> endOfInput + , blockEnd = lineContains ["", "", ""] + } + +condition2 = Condition + { blockStart = void ""] + } + +condition3 = Condition + { blockStart = void ""] + } + +condition4 = Condition + { blockStart = void $ " satisfy isAsciiUpper + , blockEnd = void $ lineContains [">"] + } + +condition5 = Condition + { blockStart = void $ ""] + } + +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) diff --git a/src/Comark/Parser/Inline.hs b/src/Comark/Parser/Inline.hs new file mode 100644 --- /dev/null +++ b/src/Comark/Parser/Inline.hs @@ -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 = " manyTill anyChar "]]>" + declaration = do + " skipWhile1 isAsciiUpper + pWhitespace + skipWhile (/= '>') <* char '>' + comment = do + "" + 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 + diff --git a/src/Comark/Parser/Inline/EmphLink.hs b/src/Comark/Parser/Inline/EmphLink.hs new file mode 100644 --- /dev/null +++ b/src/Comark/Parser/Inline/EmphLink.hs @@ -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 diff --git a/src/Comark/Parser/Options.hs b/src/Comark/Parser/Options.hs new file mode 100644 --- /dev/null +++ b/src/Comark/Parser/Options.hs @@ -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 + -- . + -- + -- References are represented with a mapping from a + -- to a pair of a + -- + -- and an optional + -- . + -- + -- 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 } diff --git a/src/Comark/Parser/Util.hs b/src/Comark/Parser/Util.hs new file mode 100644 --- /dev/null +++ b/src/Comark/Parser/Util.hs @@ -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 <> ")" diff --git a/src/Comark/ParserCombinators.hs b/src/Comark/ParserCombinators.hs new file mode 100644 --- /dev/null +++ b/src/Comark/ParserCombinators.hs @@ -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 diff --git a/src/Comark/ParserCombinators/Prim.hs b/src/Comark/ParserCombinators/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Comark/ParserCombinators/Prim.hs @@ -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 #-} + diff --git a/src/Text/Html/Email/Validate.hs b/src/Text/Html/Email/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Text/Html/Email/Validate.hs @@ -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") diff --git a/tests/Blocks.hs b/tests/Blocks.hs new file mode 100644 --- /dev/null +++ b/tests/Blocks.hs @@ -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 + ] diff --git a/tests/Inline.hs b/tests/Inline.hs new file mode 100644 --- /dev/null +++ b/tests/Inline.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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)