hxt 9.1.4 → 9.1.5
raw patch · 9 files changed
+187/−109 lines, 9 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Text.XML.HXT.DOM.XmlNode: concText :: XmlTree -> XmlTree -> XmlTrees
+ Text.XML.HXT.DOM.XmlNode: mergeText :: XmlTree -> XmlTree -> XmlTrees
+ Text.XML.HXT.DOM.XmlNode: toText :: XmlTree -> XmlTree
+ Text.XML.HXT.Parser.XmlTokenParser: mergeTextNodes :: XmlTrees -> XmlTrees
Files
- hxt.cabal +1/−1
- src/Data/Tree/NTree/Zipper/TypeDefs.hs +1/−0
- src/Data/Tree/NavigatableTree/Class.hs +2/−0
- src/Text/XML/HXT/Arrow/Edit.hs +1/−1
- src/Text/XML/HXT/Arrow/ReadDocument.hs +19/−8
- src/Text/XML/HXT/DOM/XmlNode.hs +35/−1
- src/Text/XML/HXT/Parser/HtmlParsec.hs +37/−30
- src/Text/XML/HXT/Parser/XmlParsec.hs +62/−57
- src/Text/XML/HXT/Parser/XmlTokenParser.hs +29/−11
hxt.cabal view
@@ -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.
src/Data/Tree/NTree/Zipper/TypeDefs.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} {-# OPTIONS -fno-warn-orphans #-} -- ------------------------------------------------------------
@@ -1,3 +1,5 @@+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}+ -- ------------------------------------------------------------ {- |
src/Text/XML/HXT/Arrow/Edit.hs view
@@ -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
src/Text/XML/HXT/Arrow/ReadDocument.hs view
@@ -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+-} -- ------------------------------------------------------------
src/Text/XML/HXT/DOM/XmlNode.hs view
@@ -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 -- ------------------------------------------------------------
src/Text/XML/HXT/Parser/HtmlParsec.hs view
@@ -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"] )) ] {-
src/Text/XML/HXT/Parser/XmlParsec.hs view
@@ -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'
src/Text/XML/HXT/Parser/XmlTokenParser.hs view
@@ -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 -- ------------------------------------------------------------