diff --git a/hxt.cabal b/hxt.cabal --- a/hxt.cabal +++ b/hxt.cabal @@ -1,6 +1,6 @@ -- arch-tag: Haskell XML Toolbox main description file Name: hxt -Version: 9.1.4 +Version: 9.1.5 Synopsis: A collection of tools for processing XML with Haskell. Description: The Haskell XML Toolbox bases on the ideas of HaXml and HXML, but introduces a more general approach for processing XML with Haskell. diff --git a/src/Data/Tree/NTree/Zipper/TypeDefs.hs b/src/Data/Tree/NTree/Zipper/TypeDefs.hs --- a/src/Data/Tree/NTree/Zipper/TypeDefs.hs +++ b/src/Data/Tree/NTree/Zipper/TypeDefs.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} {-# OPTIONS -fno-warn-orphans #-} -- ------------------------------------------------------------ diff --git a/src/Data/Tree/NavigatableTree/Class.hs b/src/Data/Tree/NavigatableTree/Class.hs --- a/src/Data/Tree/NavigatableTree/Class.hs +++ b/src/Data/Tree/NavigatableTree/Class.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} + -- ------------------------------------------------------------ {- | diff --git a/src/Text/XML/HXT/Arrow/Edit.hs b/src/Text/XML/HXT/Arrow/Edit.hs --- a/src/Text/XML/HXT/Arrow/Edit.hs +++ b/src/Text/XML/HXT/Arrow/Edit.hs @@ -90,7 +90,7 @@ -- | -- Applies some "Canonical XML" rules to a document tree. -- --- The rule differ slightly for canonical XML and XPath in handling of comments +-- The rules differ slightly for canonical XML and XPath in handling of comments -- -- Note: This is not the whole canonicalization as it is specified by the W3C -- Recommendation. Adding attribute defaults or sorting attributes in lexicographic diff --git a/src/Text/XML/HXT/Arrow/ReadDocument.hs b/src/Text/XML/HXT/Arrow/ReadDocument.hs --- a/src/Text/XML/HXT/Arrow/ReadDocument.hs +++ b/src/Text/XML/HXT/Arrow/ReadDocument.hs @@ -32,7 +32,6 @@ import Text.XML.HXT.Arrow.XmlArrow import Text.XML.HXT.Arrow.Edit ( canonicalizeAllNodes , canonicalizeForXPath - , canonicalizeContents , rememberDTDAttrl , removeDocWhiteSpace ) @@ -403,28 +402,40 @@ -- ------------------------------------------------------------ -- | --- parse a string as HTML content, substitute all HTML entity refs and canonicalize tree +-- parse a string as HTML content, substitute all HTML entity refs and canonicalize tree. -- (substitute char refs, ...). Errors are ignored. -- --- A simpler version of 'readFromString' but with less functionality. --- Does not run in the IO monad +-- This arrow delegates all work to the parseHtmlContent parser in module HtmlParser. +-- +-- This is a simpler version of 'readFromString' without any options, +-- but it does not run in the IO monad. hread :: ArrowXml a => a String XmlTree hread = fromLA $ parseHtmlContent -- substHtmlEntityRefs is done in parser - >>> - editNTreeA [isError :-> none] -- ignore all errors + >>> -- as well as subst HTML char refs + editNTreeA [isError :-> none] -- ignores all errors + +{- no longer neccesary, text nodes are merged in parser >>> canonicalizeContents +-} +-- ------------------------------------------------------------ + -- | -- parse a string as XML content, substitute all predefined XML entity refs and canonicalize tree --- (substitute char refs, ...) +-- This xread arrow delegates all work to the xread parser function in module XmlParsec xread :: ArrowXml a => a String XmlTree -xread = parseXmlContent -- substXmlEntityRefs is done in parser +xread = parseXmlContent +{- -- the old version, where the parser does not subst char refs and cdata +xread = root [] [parseXmlContent] -- substXmlEntityRefs is done in parser >>> canonicalizeContents + >>> + getChildren +-} -- ------------------------------------------------------------ diff --git a/src/Text/XML/HXT/DOM/XmlNode.hs b/src/Text/XML/HXT/DOM/XmlNode.hs --- a/src/Text/XML/HXT/DOM/XmlNode.hs +++ b/src/Text/XML/HXT/DOM/XmlNode.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies #-} + -- ------------------------------------------------------------ {- | @@ -33,7 +35,10 @@ import Control.Monad import Control.FlatSeq -import Data.Maybe +import Data.Function ( on ) +import Data.Maybe ( fromMaybe + , fromJust + ) import Data.Tree.Class import Data.Tree.NTree.TypeDefs @@ -496,5 +501,34 @@ mkDTDElem' :: DTDElem -> Attributes -> XmlTrees -> XmlTree mkDTDElem' e al cl = id $!! mkDTDElem e al cl {-# INLINE mkDTDElem' #-} + +-- ------------------------------------------------------------ + +toText :: XmlTree -> XmlTree +toText t + | isCharRef t + = mkText + . (:[]) . toEnum + . fromJust + . getCharRef + $ t + | isCdata t + = mkText + . fromJust + . getCdata + $ t + | otherwise + = t + +concText :: XmlTree -> XmlTree -> XmlTrees +concText t1 t2 + | isText t1 && isText t2 + = (:[]) . mkText $ fromJust (getText t1) ++ fromJust (getText t2) + | otherwise + = [t1, t2] + +mergeText :: XmlTree -> XmlTree -> XmlTrees +mergeText + = concText `on` toText -- ------------------------------------------------------------ diff --git a/src/Text/XML/HXT/Parser/HtmlParsec.hs b/src/Text/XML/HXT/Parser/HtmlParsec.hs --- a/src/Text/XML/HXT/Parser/HtmlParsec.hs +++ b/src/Text/XML/HXT/Parser/HtmlParsec.hs @@ -33,6 +33,8 @@ where +import Control.Applicative ( (<$>) ) + import Data.Char ( toLower , toUpper ) @@ -89,6 +91,7 @@ , checkString , singleCharsT , referenceT + , mergeTextNodes ) import Text.XML.HXT.Parser.XmlParsec ( misc , parseXmlText @@ -188,6 +191,10 @@ htmlContent :: SimpleXParser XmlTrees htmlContent + = mergeTextNodes <$> htmlContent' + +htmlContent' :: SimpleXParser XmlTrees +htmlContent' = option [] ( do context <- hContent (id, []) @@ -401,7 +408,7 @@ -- ------------------------------------------------------------ -hpI :: SimpleXParser XmlTree +hpI :: SimpleXParser XmlTree hpI = checkString "> ( try ( do @@ -578,42 +585,42 @@ -- a bit more efficient implementation of closes -closesHtmlTag :: String -> String -> Bool +closesHtmlTag :: String -> String -> Bool closesHtmlTag t t2 = fromMaybe False . fmap ($ t) . M.lookup t2 $ closedByTable {-# INLINE closesHtmlTag #-} -closedByTable :: M.Map String (String -> Bool) +closedByTable :: M.Map String (String -> Bool) closedByTable = M.fromList $ - [ ("a", (== "a")) - , ("li", (== "li" )) - , ("th", (`elem` ["th", "td", "tr"] )) - , ("td", (`elem` ["th", "td", "tr"] )) - , ("tr", (== "tr")) - , ("dt", (`elem` ["dt", "dd"] )) - , ("dd", (`elem` ["dt", "dd"] )) - , ("p", (`elem` ["hr" + [ ("a", (== "a")) + , ("li", (== "li" )) + , ("th", (`elem` ["th", "td", "tr"] )) + , ("td", (`elem` ["th", "td", "tr"] )) + , ("tr", (== "tr")) + , ("dt", (`elem` ["dt", "dd"] )) + , ("dd", (`elem` ["dt", "dd"] )) + , ("p", (`elem` ["hr" , "h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] )) - , ("colgroup", (`elem` ["colgroup", "thead", "tfoot", "tbody"] )) - , ("form", (`elem` ["form"] )) - , ("label", (`elem` ["label"] )) - , ("map", (`elem` ["map"] )) - , ("option", const True) - , ("script", const True) - , ("style", const True) - , ("textarea", const True) - , ("title", const True) - , ("select", ( /= "option")) - , ("thead", (`elem` ["tfoot","tbody"] )) - , ("tbody", (== "tbody" )) - , ("tfoot", (== "tbody" )) - , ("h1", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] )) - , ("h2", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] )) - , ("h3", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] )) - , ("h4", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] )) - , ("h5", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] )) - , ("h6", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] )) + , ("colgroup", (`elem` ["colgroup", "thead", "tfoot", "tbody"] )) + , ("form", (`elem` ["form"] )) + , ("label", (`elem` ["label"] )) + , ("map", (`elem` ["map"] )) + , ("option", const True) + , ("script", const True) + , ("style", const True) + , ("textarea", const True) + , ("title", const True) + , ("select", ( /= "option")) + , ("thead", (`elem` ["tfoot","tbody"] )) + , ("tbody", (== "tbody" )) + , ("tfoot", (== "tbody" )) + , ("h1", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] )) + , ("h2", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] )) + , ("h3", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] )) + , ("h4", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] )) + , ("h5", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] )) + , ("h6", (`elem` ["h1", "h2", "h3", "h4", "h5", "h6", "dl", "ol", "ul", "table", "div", "p"] )) ] {- diff --git a/src/Text/XML/HXT/Parser/XmlParsec.hs b/src/Text/XML/HXT/Parser/XmlParsec.hs --- a/src/Text/XML/HXT/Parser/XmlParsec.hs +++ b/src/Text/XML/HXT/Parser/XmlParsec.hs @@ -57,51 +57,53 @@ ) where -import Text.ParserCombinators.Parsec ( runParser - , (), (<|>) - , char - , string - , eof - , between - , many - , many1 - , notFollowedBy - , option - , try - , unexpected - , getPosition - , getInput - , sourceName - ) +import Control.Applicative ( (<$>) ) -import Text.XML.HXT.DOM.ShowXml ( xshow - ) +import Text.ParserCombinators.Parsec ( runParser + , (), (<|>) + , char + , string + , eof + , between + , many + , many1 + , notFollowedBy + , option + , try + , unexpected + , getPosition + , getInput + , sourceName + ) + +import Text.XML.HXT.DOM.ShowXml ( xshow + ) import Text.XML.HXT.DOM.Interface -import Text.XML.HXT.DOM.XmlNode ( mkElement' - , mkAttr' - , mkRoot' - , mkDTDElem' - , mkText' - , mkCmt' - , mkCdata' - , mkError' - , mkPi' - , isText - , isRoot - , getText - , getChildren - , getAttrl - , getAttrName - , changeAttrl - , mergeAttrl - ) -import Text.XML.HXT.Parser.XmlCharParser ( xmlChar - , XParser - , SimpleXParser - , XPState - , withNormNewline - , withoutNormNewline - ) +import Text.XML.HXT.DOM.XmlNode ( mkElement' + , mkAttr' + , mkRoot' + , mkDTDElem' + , mkText' + , mkCmt' + , mkCdata' + , mkError' + , mkPi' + , isText + , isRoot + , getText + , getChildren + , getAttrl + , getAttrName + , changeAttrl + , mergeAttrl + ) +import Text.XML.HXT.Parser.XmlCharParser ( xmlChar + , XParser + , SimpleXParser + , XPState + , withNormNewline + , withoutNormNewline + ) import qualified Text.XML.HXT.Parser.XmlTokenParser as XT import qualified Text.XML.HXT.Parser.XmlDTDTokenParser as XD @@ -462,20 +464,22 @@ content :: XParser s XmlTrees content - = many $ - ( do -- parse markup but no closing tags - try ( XT.lt - >> - notFollowedBy (char '/') - >> - return () - ) - markup + = XT.mergeTextNodes <$> + many + ( ( do -- parse markup but no closing tags + try ( XT.lt + >> + notFollowedBy (char '/') + >> + return () + ) + markup + ) + <|> + charData' + <|> + XT.referenceT ) - <|> - charData' - <|> - XT.referenceT where markup = element' @@ -608,7 +612,8 @@ -- -- the string parameter is parsed with the XML content parser. -- result is the list of trees or in case of an error a single element list with the --- error message as node. No entity or character subtitution is done. +-- error message as node. No entity or character subtitution is done here, +-- but the XML parser can do this for the predefined XML or the char references for performance reasons -- -- see also: 'parseXmlContent' diff --git a/src/Text/XML/HXT/Parser/XmlTokenParser.hs b/src/Text/XML/HXT/Parser/XmlTokenParser.hs --- a/src/Text/XML/HXT/Parser/XmlTokenParser.hs +++ b/src/Text/XML/HXT/Parser/XmlTokenParser.hs @@ -78,15 +78,20 @@ , peReferenceT , singleCharsT + + , mergeTextNodes ) where +import Control.Applicative ( (<$>) ) + import Data.Char.Properties.XMLCharProps ( isXmlChar , isXmlCharCR ) import Data.String.Unicode ( intToCharRef , intToCharRefHex ) + import Text.ParserCombinators.Parsec import Text.XML.HXT.DOM.Interface @@ -94,6 +99,7 @@ , mkText' , mkCharRef' , mkEntityRef' + , mergeText ) import Text.XML.HXT.Parser.XmlCharParser ( xmlNameChar , xmlNameStartChar @@ -196,24 +202,24 @@ singleChars notAllowed = many1 (singleChar notAllowed) -entityValue :: XParser s String +entityValue :: XParser s String entityValue = ( do - v <- entityValueDQ - return ("\"" ++ v ++ "\"") + v <- entityValueDQ + return ("\"" ++ v ++ "\"") ) <|> ( do - v <- entityValueSQ - return ("'" ++ v ++ "'") + v <- entityValueSQ + return ("'" ++ v ++ "'") ) "entity value (in quotes)" -entityValueDQ :: XParser s String +entityValueDQ :: XParser s String entityValueDQ = between dq dq (concRes $ many $ attrChar "&\"") -entityValueSQ :: XParser s String +entityValueSQ :: XParser s String entityValueSQ = between sq sq (concRes $ many $ attrChar "&\'") @@ -413,13 +419,13 @@ {-# INLINE comma #-} {-# INLINE eq #-} -lpar = char '(' >> skipS0 +lpar = char '(' >> skipS0 {-# INLINE lpar #-} -rpar = skipS0 >> char ')' >> return () +rpar = skipS0 >> char ')' >> return () {-# INLINE rpar #-} -checkString :: String -> XParser s () +checkString :: String -> XParser s () checkString s = try $ string s >> return () {-# INLINE checkString #-} @@ -523,7 +529,7 @@ attrValueT' :: String -> XParser s XmlTrees attrValueT' notAllowed - = many ( referenceT <|> singleCharsT notAllowed) + = mergeTextNodes <$> many ( referenceT <|> singleCharsT notAllowed) singleCharsT :: String -> XParser s XmlTree singleCharsT notAllowed @@ -579,6 +585,18 @@ = do r <- peReference return $! (mkDTDElem' PEREF [(a_peref, r)] []) + +-- ------------------------------------------------------------ + +mergeTextNodes :: XmlTrees -> XmlTrees +mergeTextNodes + = foldr addText [] + where + addText :: XmlTree -> XmlTrees -> XmlTrees + addText t [] + = [t] + addText t (t1 : ts) + = mergeText t t1 ++ ts -- ------------------------------------------------------------