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.2
+Version: 9.1.3
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/Function/Selector.hs b/src/Data/Function/Selector.hs
--- a/src/Data/Function/Selector.hs
+++ b/src/Data/Function/Selector.hs
@@ -58,54 +58,6 @@
}
-- ------------------------------------------------------------
--- TODO: delete theses
-{-
-subS :: Selector b c -> Selector a b -> Selector a c
-subS = (.)
-
-pairS :: Selector s a -> Selector s b -> Selector s (a, b)
-pairS = (.&&&.)
-
-chgS :: Selector s a -> (a -> a) -> (s -> s)
-chgS = update
-
-putS :: Selector s a -> a -> (s -> s)
-putS = setS
-
--}
--- ------------------------------------------------------------
-{-
-type Selector s a = (s -> a, a -> s -> s)
-
-subS :: Selector b c -> Selector a b -> Selector a c
-subS (g2, s2) (g1, s1) = ( g2 . g1
- , s1s2
- )
- where
- s1s2 x s = s'
- where
- x1 = g1 s
- x1' = s2 x x1
- s' = s1 x1' s
-
-pairS :: Selector s a -> Selector s b -> Selector s (a, b)
-pairS (g1, s1) (g2, s2) = ( g1 &&& g2
- , \ (x, y) -> s2 y . s1 x
- )
-
-chgS :: Selector s a -> (a -> a) -> (s -> s)
-chgS (g, s) f x = s (f (g x)) x
-
-getS :: Selector s a -> s -> a
-getS = fst -- getS (g, _s) x = g x
-
-putS :: Selector s a -> a -> (s -> s)
-putS s v = chgS s (const v)
-
-idS :: Selector s s
-idS = (id, const)
--}
--- ------------------------------------------------------------
-- | Selectors for pairs and 3-tuples: comp1, comp2, comp3,
-- this can be extended to n-tuples
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
@@ -46,6 +46,9 @@
, transfCharRef
, transfAllCharRef
+ , substAllXHTMLEntityRefs
+ , substXHTMLEntityRef
+
, rememberDTDAttrl
, addDefaultDTDecl
@@ -112,32 +115,7 @@
)
>>>
canonicalizeNodes toBeRemoved
-{-
-canonicalize1Node :: LA XmlTree XmlTree -> LA XmlTree XmlTree
-canonicalize1Node toBeRemoved
- = choiceA
- [ toBeRemoved :-> none
- , isElem :-> ( processAttrl
- ( processChildren transfCharRef
- >>>
- collapseXText' -- combine text in attribute values
- )
- >>>
- collapseXText' -- combine text in content
- )
- , isCharRef :-> ( getCharRef
- >>>
- arr (\ i -> [toEnum i])
- >>>
- mkText
- )
- , isCdata :-> ( getCdata
- >>>
- mkText
- )
- , this :-> this
- ]
--}
+
canonicalizeNodes :: LA XmlTree XmlTree -> LA XmlTree XmlTree
canonicalizeNodes toBeRemoved
= editNTreeA $
@@ -263,8 +241,10 @@
-- | apply an arrow to the input and convert the resulting XML trees into an XML escaped string
--
--- This is a save variant for converting a tree into an XML string representation that is parsable with 'Text.XML.HXT.Arrow.ReadDocument'.
--- It is implemented with 'Text.XML.HXT.Arrow.XmlArrow.xshow', but xshow does no XML escaping. The XML escaping is done with
+-- This is a save variant for converting a tree into an XML string representation
+-- that is parsable with 'Text.XML.HXT.Arrow.ReadDocument'.
+-- It is implemented with 'Text.XML.HXT.Arrow.XmlArrow.xshow',
+-- but xshow does no XML escaping. The XML escaping is done with
-- 'Text.XML.HXT.Arrow.Edit.escapeXmlDoc' before xshow is applied.
--
-- So the following law holds
@@ -290,6 +270,31 @@
buildEntityRefTable :: [(String, Int)] -> EntityRefTable
buildEntityRefTable = M.fromList . map (\ (x,y) -> (y,x) )
+
+type EntitySubstTable = M.Map String String
+
+xhtmlEntitySubstTable :: EntitySubstTable
+xhtmlEntitySubstTable = M.fromList . map (second $ (:[]) . toEnum) $ xhtmlEntities
+
+-- ------------------------------------------------------------
+
+substXHTMLEntityRef :: LA XmlTree XmlTree
+substXHTMLEntityRef
+ = ( getEntityRef
+ >>>
+ arrL subst
+ >>>
+ mkText
+ )
+ `orElse` this
+ where
+ subst name
+ = maybe [] (:[]) $ M.lookup name xhtmlEntitySubstTable
+
+substAllXHTMLEntityRefs :: ArrowXml a => a XmlTree XmlTree
+substAllXHTMLEntityRefs
+ = fromLA $
+ processBottomUp substXHTMLEntityRef
-- ------------------------------------------------------------
diff --git a/src/Text/XML/HXT/Arrow/ProcessDocument.hs b/src/Text/XML/HXT/Arrow/ProcessDocument.hs
--- a/src/Text/XML/HXT/Arrow/ProcessDocument.hs
+++ b/src/Text/XML/HXT/Arrow/ProcessDocument.hs
@@ -45,6 +45,7 @@
)
import Text.XML.HXT.Arrow.Edit ( transfAllCharRef
+ , substAllXHTMLEntityRefs
)
import Text.XML.HXT.Arrow.GeneralEntitySubstitution
@@ -87,8 +88,8 @@
This parser is useful for applications processing correct XML documents.
-}
-parseXmlDocument :: Bool -> IOStateArrow s XmlTree XmlTree
-parseXmlDocument validate'
+parseXmlDocument :: Bool -> Bool -> Bool -> Bool -> IOStateArrow s XmlTree XmlTree
+parseXmlDocument validateD substDTD substHTML validateRX
= ( replaceChildren ( ( getAttrValue a_source
&&&
xshow getChildren
@@ -102,22 +103,17 @@
setDocumentStatusFromSystemState "parse XML document"
>>>
( ifA (fromLA getDTDSubset)
- ( processDTD
- >>>
- ( processGeneralEntities -- DTD contains general entity definitions
- `when`
- fromLA generalEntitiesDefined
- )
- >>>
- transfAllCharRef
+ ( processDTDandEntities
>>>
( if validate' -- validation only possible if DTD there
then validateDocument
else this
)
)
- ( if validate' -- validation only consists of checking for undefined entity refs
- -- predefined XML entity refs are substituted in the XML parser into char refs
+ ( if validate' -- validation only consists of checking
+ -- for undefined entity refs
+ -- predefined XML entity refs are substituted
+ -- in the XML parser into char refs
-- so there is no need for an entity substitution
then traceMsg 2 "checkUndefinedEntityRefs: looking for undefined entity refs"
>>>
@@ -131,7 +127,28 @@
)
)
`when` documentStatusOk
+ where
+ validate'
+ = validateD && not validateRX
+ processDTDandEntities
+ = ( if validateD || substDTD
+ then processDTD
+ else this
+ )
+ >>>
+ ( if substDTD
+ then ( processGeneralEntities -- DTD contains general entity definitions
+ `when`
+ fromLA generalEntitiesDefined
+ )
+ else if substHTML
+ then substAllXHTMLEntityRefs
+ else this
+ )
+ >>>
+ transfAllCharRef
+
checkUndefinedEntityRefs :: IOStateArrow s XmlTree XmlTree
checkUndefinedEntityRefs
= deep isEntityRef
@@ -170,7 +187,10 @@
parseHtmlDocument :: IOStateArrow s XmlTree XmlTree
parseHtmlDocument
- = ( perform ( getAttrValue a_source >>> traceValue 1 (("parseHtmlDoc: parse HTML document " ++) . show) )
+ = ( perform ( getAttrValue a_source
+ >>>
+ traceValue 1 (("parseHtmlDoc: parse HTML document " ++) . show)
+ )
>>>
( parseHtml $< getSysVar (theTagSoup .&&&. theExpat) )
>>>
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
@@ -59,6 +59,20 @@
- @withValidate yes\/no@ :
switch on\/off DTD validation. Only for XML parsed documents, not for HTML parsing.
+- @withSubstDTDEntities yes\/no@ :
+ switch on\/off entity substitution for general entities defined in DTD validation.
+ Default is @yes@.
+ Switching this option and the validation off can lead to faster parsing, in that case
+ reading the DTD documents is not longer necessary.
+ Only used with XML parsed documents, not with HTML parsing.
+
+- @withSubstHTMLEntities yes\/no@ :
+ switch on\/off entity substitution for general entities defined in HTML validation.
+ Default is @no@.
+ Switching this option on and the validation and substDTDEntities off can lead to faster parsing, in that case
+ reading the DTD documents is not longer necessary, HTML general entities are still substituted.
+ Only used with XML parsed documents, not with HTML parsing.
+
- @withParseHTML yes\/no@ :
switch on HTML parsing.
@@ -151,10 +165,28 @@
> , withHTTP []
> ] "http://www.w3c.org/"
-read w3c home page (xhtml), validate and check namespaces, remove whitespace between tags, trace activities with level 2.
+read w3c home page (xhtml), validate and check namespaces, remove whitespace between tags,
+trace activities with level 2.
HTTP access is done with Haskell HTTP package
-for minimal complete examples see 'Text.XML.HXT.Arrow.WriteDocument.writeDocument' and 'runX', the main starting point for running an XML arrow.
+> readDocument [ withValidate no
+> , withSubstDTDEntities no
+> ...
+> ] "http://www.w3c.org/"
+
+read w3c home page (xhtml), but without accessing the DTD given in that document.
+Only the predefined XML general entity refs are substituted.
+
+> readDocument [ withValidate no
+> , withSubstDTDEntities no
+> , withSubstHTMLEntities yes
+> ...
+> ] "http://www.w3c.org/"
+
+same as above, but with substituion of all general entity refs defined in XHTML.
+
+for minimal complete examples see 'Text.XML.HXT.Arrow.WriteDocument.writeDocument'
+and 'runX', the main starting point for running an XML arrow.
-}
readDocument :: SysConfigList -> String -> IOStateArrow s b XmlTree
@@ -205,8 +237,10 @@
>>>
( if isAcceptedMimeType acceptedMimeTypes mimeType
then ( ifA (fromLA hasEmptyBody)
- ( replaceChildren none ) -- empty response, e.g. in if-modified-since request
+ ( replaceChildren none ) -- empty response, e.g. in if-modified-since request
( ( parse $< getSysVar (theValidate .&&&.
+ theSubstDTDEntities .&&&.
+ theSubstHTMLEntities .&&&.
theIgnoreNoneXmlContents .&&&.
theTagSoup .&&&.
theExpat
@@ -272,7 +306,7 @@
(mi == mis || mis == "*")
)
|| r
- parse (validate, (removeNoneXml, (withTagSoup', withExpat')))
+ parse (validate, (substDTD, (substHTML, (removeNoneXml, (withTagSoup', withExpat')))))
| not isXmlOrHtml = if removeNoneXml
then replaceChildren none -- don't parse, if mime type is not XML nor HTML
else this -- but remove contents when option is set
@@ -285,7 +319,7 @@
| isXml = if withExpat'
then parseXmlDocumentWithExpat
- else parseXmlDocument (not validateWithRelax && validate)
+ else parseXmlDocument validate substDTD substHTML validateWithRelax
-- parse as XML
| otherwise = this -- suppress warning
diff --git a/src/Text/XML/HXT/Arrow/XmlOptions.hs b/src/Text/XML/HXT/Arrow/XmlOptions.hs
--- a/src/Text/XML/HXT/Arrow/XmlOptions.hs
+++ b/src/Text/XML/HXT/Arrow/XmlOptions.hs
@@ -63,6 +63,10 @@
, Option "Q" [a_do_not_issue_warnings] (NoArg (withWarnings False)) "ignore warnings, when parsing HTML"
, Option "" [a_validate] (NoArg (withValidate True)) "document validation when parsing XML (default)"
, Option "w" [a_do_not_validate] (NoArg (withValidate False)) "only wellformed check, no validation"
+ , Option "" [a_subst_dtd_entities] (NoArg (withSubstDTDEntities True)) "entities defined in DTD are substituted when parsing XML (default)"
+ , Option "" [a_do_not_subst_dtd_entities] (NoArg (withSubstDTDEntities False)) "entities defined in DTD are NOT substituted when parsing XML"
+ , Option "" [a_subst_html_entities] (NoArg (withSubstHTMLEntities True)) "entities defined in XHTML are substituted when parsing XML, only in effect when prev. option is switched off"
+ , Option "" [a_do_not_subst_html_entities] (NoArg (withSubstHTMLEntities False)) "only entities predefined in XML are substituted when parsing XML (default)"
, Option "" [a_canonicalize] (NoArg (withCanonicalize True)) "canonicalize document, remove DTD, comment, transform CDATA, CharRef's, ... (default)"
, Option "c" [a_do_not_canonicalize] (NoArg (withCanonicalize False)) "do not canonicalize document, don't remove DTD, comment, don't transform CDATA, CharRef's, ..."
, Option "C" [a_preserve_comment] (NoArg (withPreserveComment True)) "don't remove comments during canonicalisation"
@@ -142,6 +146,8 @@
a_do_not_issue_warnings,
a_do_not_preserve_comment,
a_do_not_remove_whitespace,
+ a_do_not_subst_dtd_entities,
+ a_do_not_subst_html_entities,
a_do_not_validate,
a_error,
a_error_log,
@@ -173,6 +179,8 @@
a_show_haskell,
a_show_tree,
a_strict_input,
+ a_subst_dtd_entities,
+ a_subst_html_entities,
a_text_mode,
a_trace,
a_validate,
@@ -190,6 +198,8 @@
a_do_not_issue_warnings = "do-not-issue-warnings"
a_do_not_preserve_comment = "do-not-preserve-comment"
a_do_not_remove_whitespace = "do-not-remove-whitespace"
+a_do_not_subst_dtd_entities = "do-not-subst-dtd-entities"
+a_do_not_subst_html_entities = "do-not-subst-html-entities"
a_do_not_validate = "do-not-validate"
a_error = "error"
a_error_log = "errorLog"
@@ -221,6 +231,8 @@
a_show_haskell = "show-haskell"
a_show_tree = "show-tree"
a_strict_input = "strict-input"
+a_subst_dtd_entities = "subst-dtd-entities"
+a_subst_html_entities = "subst-html-entities"
a_text_mode = "text-mode"
a_trace = "trace"
a_validate = "validate"
diff --git a/src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs b/src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs
--- a/src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs
+++ b/src/Text/XML/HXT/Arrow/XmlState/RunIOStateArrow.hs
@@ -122,6 +122,8 @@
, xioTagSoup = False
, xioPreserveComment = False
, xioValidate = True
+ , xioSubstDTDEntities = True
+ , xioSubstHTMLEntities = False
, xioCheckNamespaces = False
, xioCanonicalize = True
, xioIgnoreNoneXmlContents = False
diff --git a/src/Text/XML/HXT/Arrow/XmlState/SystemConfig.hs b/src/Text/XML/HXT/Arrow/XmlState/SystemConfig.hs
--- a/src/Text/XML/HXT/Arrow/XmlState/SystemConfig.hs
+++ b/src/Text/XML/HXT/Arrow/XmlState/SystemConfig.hs
@@ -99,10 +99,24 @@
withParseHTML :: Bool -> SysConfig
withParseHTML = setS theParseHTML
--- | @withValidate yes/no@: read option, validate document againsd DTD, default is 'yes'
+-- | @withValidate yes/no@: read option, validate document against DTD, default is 'yes'
withValidate :: Bool -> SysConfig
withValidate = setS theValidate
+
+-- | @withSubstDTDEntities yes/no@: read option, substitute general entities defined in DTD, default is 'yes'.
+-- switching this option and the validate option off can lead to faster parsing, because then
+-- there is no need to access the DTD
+
+withSubstDTDEntities :: Bool -> SysConfig
+withSubstDTDEntities = setS theSubstDTDEntities
+
+-- | @withSubstHTMLEntities yes/no@: read option, substitute general entities defined in HTML DTD, default is 'no'.
+-- switching this option on and the substDTDEntities and validate options off can lead to faster parsing
+-- because there is no need to access a DTD, but still the HTML general entities are substituted
+
+withSubstHTMLEntities :: Bool -> SysConfig
+withSubstHTMLEntities = setS theSubstHTMLEntities
-- | @withCheckNamespaces yes/no@: read option, check namespaces, default is 'no'
diff --git a/src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs b/src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs
--- a/src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs
+++ b/src/Text/XML/HXT/Arrow/XmlState/TypeDefs.hs
@@ -202,6 +202,8 @@
, xioLowerCaseNames :: ! Bool
, xioPreserveComment :: ! Bool
, xioValidate :: ! Bool
+ , xioSubstDTDEntities :: ! Bool
+ , xioSubstHTMLEntities :: ! Bool
, xioCheckNamespaces :: ! Bool
, xioCanonicalize :: ! Bool
, xioIgnoreNoneXmlContents :: ! Bool
@@ -632,6 +634,20 @@
>>>
S { getS = xioValidate
, setS = \ x s -> s { xioValidate = x }
+ }
+
+theSubstDTDEntities :: Selector XIOSysState Bool
+theSubstDTDEntities = theParseConfig
+ >>>
+ S { getS = xioSubstDTDEntities
+ , setS = \ x s -> s { xioSubstDTDEntities = x }
+ }
+
+theSubstHTMLEntities :: Selector XIOSysState Bool
+theSubstHTMLEntities = theParseConfig
+ >>>
+ S { getS = xioSubstHTMLEntities
+ , setS = \ x s -> s { xioSubstHTMLEntities = x }
}
theCheckNamespaces :: Selector XIOSysState Bool
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
@@ -304,7 +304,7 @@
{-# INLINE changeAttrName #-}
changePiName cf (XPi n al) = XPi (cf n) al
- changePiName _ _ = error "changeAttrName undefined"
+ changePiName _ _ = error "changePiName undefined"
{-# INLINE changePiName #-}
changeDTDAttrl cf (XDTD p al) = XDTD p (cf al)