diff --git a/Benchmark.hs b/Benchmark.hs index 67c790526..0f3520fde 100644 --- a/Benchmark.hs +++ b/Benchmark.hs @@ -13,8 +13,11 @@ readerBench doc (name, reader) = inp = writer defaultWriterOptions{ writerWrapText = True , writerLiterateHaskell = "+lhs" `isSuffixOf` name } doc - in bench (name ++ " reader") $ whnf - (reader defaultParserState{stateSmart = True + -- we compute the length to force full evaluation + getLength (Pandoc (Meta a b c) d) = + length a + length b + length c + length d + in bench (name ++ " reader") $ whnf (getLength . + reader defaultParserState{ stateSmart = True , stateStandalone = True , stateLiterateHaskell = "+lhs" `isSuffixOf` name }) inp diff --git a/pandoc.cabal b/pandoc.cabal index 02e80845f..765fde59f 100644 --- a/pandoc.cabal +++ b/pandoc.cabal @@ -176,7 +176,8 @@ Library citeproc-hs >= 0.3 && < 0.4, pandoc-types == 1.7.*, json >= 0.4 && < 0.5, - dlist >= 0.4 && < 0.6 + dlist >= 0.4 && < 0.6, + tagsoup >= 0.12 && < 0.13 if impl(ghc >= 6.10) Build-depends: base >= 4 && < 5, syb else @@ -249,7 +250,8 @@ Executable pandoc citeproc-hs >= 0.3 && < 0.4, pandoc-types == 1.7.*, json >= 0.4 && < 0.5, - dlist >= 0.4 && < 0.6 + dlist >= 0.4 && < 0.6, + tagsoup >= 0.12 && < 0.13 if impl(ghc >= 6.10) Build-depends: base >= 4 && < 5, syb else diff --git a/src/Text/Pandoc/Parsing.hs b/src/Text/Pandoc/Parsing.hs index d8cd7cd7c..3035a2319 100644 --- a/src/Text/Pandoc/Parsing.hs +++ b/src/Text/Pandoc/Parsing.hs @@ -287,7 +287,7 @@ nullBlock :: GenParser Char st Block nullBlock = anyChar >> return Null -- | Fail if reader is in strict markdown syntax mode. -failIfStrict :: GenParser Char ParserState () +failIfStrict :: GenParser a ParserState () failIfStrict = do state <- getState if stateStrict state then fail "strict mode" else return () @@ -567,9 +567,9 @@ gridTableFooter = blanklines --- -- | Parse a string with a given parser and state. -readWith :: GenParser Char ParserState a -- ^ parser +readWith :: GenParser t ParserState a -- ^ parser -> ParserState -- ^ initial state - -> String -- ^ input string + -> [t] -- ^ input -> a readWith parser state input = case runParser parser state "source" input of diff --git a/src/Text/Pandoc/Readers/HTML.hs b/src/Text/Pandoc/Readers/HTML.hs index c25a73418..16379a82c 100644 --- a/src/Text/Pandoc/Readers/HTML.hs +++ b/src/Text/Pandoc/Readers/HTML.hs @@ -27,36 +27,355 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Conversion of HTML to 'Pandoc' document. -} -module Text.Pandoc.Readers.HTML ( - readHtml, - rawHtmlInline, - rawHtmlBlock, - htmlTag, - anyHtmlBlockTag, - anyHtmlInlineTag, - anyHtmlTag, - anyHtmlEndTag, - htmlEndTag, - extractTagType, - htmlBlockElement, - htmlComment, +module Text.Pandoc.Readers.HTML ( readHtml + , htmlTag + , htmlInBalanced + , isInlineTag + , isBlockTag + , isTextTag + , isCommentTag ) where import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Pos +import Text.HTML.TagSoup +import Text.HTML.TagSoup.Match import Text.Pandoc.Definition +import Text.Pandoc.Builder (text, toList) import Text.Pandoc.Shared import Text.Pandoc.Parsing -import Text.Pandoc.CharacterReferences ( decodeCharacterReferences ) -import Data.Maybe ( fromMaybe ) -import Data.List ( isPrefixOf, isSuffixOf, intercalate ) -import Data.Char ( toLower, isAlphaNum ) -import Control.Monad ( liftM, when ) +import Data.Maybe ( fromMaybe, isJust ) +import Data.List ( intercalate ) +import Data.Char ( isSpace, isDigit ) +import Control.Monad ( liftM, guard ) -- | Convert HTML-formatted string to 'Pandoc' document. readHtml :: ParserState -- ^ Parser state -> String -- ^ String to parse (assumes @'\n'@ line endings) -> Pandoc -readHtml = readWith parseHtml +readHtml st inp = Pandoc meta blocks + where blocks = readWith parseBody st body + tags = canonicalizeTags $ + parseTagsOptions parseOptions{ optTagPosition = True } inp + hasHeader = any (~== TagOpen "head" []) tags + (meta, rest) = if hasHeader + then parseHeader tags + else (Meta [] [] [], tags) + body = filter (\t -> not $ + tagOpen (`elem` ["html","head","body"]) (const True) t || + tagClose (`elem` ["html","head","body"]) t) rest + +type TagParser = GenParser (Tag String) ParserState + +parseHeader :: [Tag String] -> (Meta, [Tag String]) +parseHeader tags = (Meta{docTitle = tit'', docAuthors = [], docDate = []}, rest) + where (tit,r) = break (~== TagClose "title") $ drop 1 $ + dropWhile (\t -> not $ t ~== TagOpen "title" []) tags + tit' = concatMap fromTagText $ filter isTagText tit + tit'' = normalizeSpaces $ toList $ text tit' + rest = drop 1 $ dropWhile (\t -> not $ t ~== TagClose "head") r + +parseBody :: TagParser [Block] +parseBody = liftM concat $ manyTill block eof + +block :: TagParser [Block] +block = optional pLocation >> + choice [ + pPara + , pHeader + , pBlockQuote + , pCodeBlock + , pList + , pHrule + , pPlain + , pRawHtmlBlock + ] + +renderTags' :: [Tag String] -> String +renderTags' = renderTagsOptions + renderOptions{ optMinimize = (`elem` ["hr","br","img"]) } + +pList :: TagParser [Block] +pList = pBulletList <|> pOrderedList <|> pDefinitionList + +pBulletList :: TagParser [Block] +pBulletList = try $ do + pSatisfy (~== TagOpen "ul" []) + let nonItem = pSatisfy (\t -> + not (tagOpen (`elem` ["li","ol","ul","dl"]) (const True) t) && + not (t ~== TagClose "ul")) + -- note: if they have an
    or