general usefull state monad for a local state and IO
+
This module is used for threading a state and io actions
+ through a computation.
+ Here the monad is constructed by hand.
+ It could easily be refactored with the use of the monad transformer library.
+
Applies some Canonical XML rules to the nodes of a tree.
+
The rule 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
+ order is done by the transform function of module Text.XML.HXT.Validator.Validation.
+ Replacing entities or line feed normalization is done by the parser.
+
Not implemented yet:
+
Whitespace within start and end tags is normalized
+
Special characters in attribute values and character content are replaced by character references
+
filter for indenting a document tree for pretty printing.
+
the tree is traversed for inserting whitespace for tag indentation.
+
whitespace is only inserted or changed at places, where it isn't significant,
+ is's not inserted between tags and text containing non whitespace chars.
+
whitespace is only inserted or changed at places, where it's not significant.
+ preserving whitespace may be controlled in a document tree
+ by a tag attribute xml:space
+
allowed values for this attribute are default | preserve.
+
input is a complete document tree.
+ result the semantically equivalent formatted tree.
+
filter for removing all not significant whitespace.
+
the tree traversed for removing whitespace between tags,
+ that was inserted for indentation and readability.
+ whitespace is only removed at places, where it's not significat
+ preserving whitespace may be controlled in a document tree
+ by a tag attribute xml:space
+
allowed values for this attribute are default | preserve
+
input is root node of the document to be cleaned up
+ output the semantically equivalent simplified tree
+
convert a document tree into an output string representation
+ with respect to the output encoding.
+
The children of the document root are stubstituted by
+ a single text node for the text representation of the document.
+
Encoding of the document is performed with respect
+ to the output-encoding attribute in the root node, or if not present,
+ of the encoding attribute for the original input encoding.
+ If the encoding is not specified or not supported, UTF-8 is taken.
+
propagate all namespace declarations, check namespace constraints and issue errors.
+ If no error was found, result is the unchanged input tree, else the root node "/" with an empty document is returned.
+
propagateNamespaces takes a XML tree and
+ attaches extra namespace info at every tag name and attribute name.
+ So after processing a tree with propagateNamespaces, the access functions
+ namespaceOf and universalNameOf deliver the associated namespace (or "")
+ for tag names and attribute names.
+
validateNamespaces checks whether names are wellformed related to the XML namespace definition.
+ whether a legal namespace is declared for all prefixes, and whether attribute names are unique
+ related to universal names.
+
This module provides a Monad for an internal state and IO commands.
+ The state consists of two parts, the user state and the system state
+ user state ist a type parameter, the system state is a list
+ name-value pair. If the user state is not needed, the type parameter
+ can be instantiated with ().
+
Furthermore there are types for Xml filter working on this monad
+ and functions for manipulating the state components
+ and for lifting i/o commands and XmlFilter to monad filters.
+
Error reporting functions are also located in this module.
+
The internal system state consists of a list of name-value pairs
+ of type (String, XmlTrees), so arbitrary lists of trees can be stored.
+ For options, often only strings are used as values, so a set of access
+ functions with string values is available
+ The error handling method can be controlled by an error handler filter,
+ the default filter issues the errors on stderr
+
run a command in a new user state.
+ chain the system state part,
+ init new system state with the current one, run the command and
+ update the old system state with the resulting new system state
+
1.parameter initialUserState : the initial user state
+
2.parameter cmd : the command
+
returns : the result of executing cmd and the final state
+
chain :: state1 -> XState state1 res -> XState state0 res
returns : if the input tree n represents an error, res = []
+ and the error is processed by the errror handler filter (default: error is issued on stderr)
+ else res = [n]
+
error message handler for collecting all error messages
+ all messages are stored under attribute a_error_log
+ they can be read with getSysParamTree a_error_log or by
+ applying the filter getErrorMsg to the root node
+
checks the value of the attribute a_status in a document root.
+ if it contains a value greater or equal to c_err, an error with error message
+ stored in attribute a_module is issued and the filter acts as the noneM filter
+ else its the thisM filter
+
add the error level and the module where the error occured
+ to the attributes of a document root node and remove the children when level is greater or equal to c_err
+
check whether the error level attribute in the system state
+ is set to error, in this case the children of the document root are
+ removed and error info is added as attributes with setStatus
+ else nothing is changed
+
namespace aware test whether the root of a tree contains a tag node. Parameters are the local part and namespace.
+ Only usable after namespace propagation.
+
test whether the given node is a XTag node or a XPI node with an attribute with a value with a specific property.
+ In case of a match, the attribute value represented by a text node is returned as single element list,
+ else the empty list is the result.
+
namespace aware test whether the tree contains an attribute node. Parameters are the local part of the atribute name and the namespace.
+ Only usable after namespace propagation.
+
constructor filter for a tag node.
+ a new tree is constructed.
+ the attributes and the children are computed by applying the aproprate filter to the input tree
+
1.parameter n : the tag name
+
2.parameter af : the filter for the attribute list
+
constructor filter for a tag node.
+ a new tree is constructed.
+ the attributes and the children are computed by applying the aproprate filter to the input tree
+
1.parameter n : the tag name in form of prefix:localpart
+
2.parameter ns: the namespace uri
+
3.parameter af : the filter for the attribute list
+
filter for selecting the name of a tag node, an attribute node or a pi node.
+ Result of the filter is a single element list with a text node or the empty list
+
filter for selecting the value of an attribute with namespace in a tag node.
+ Result of the filter is a single element list with a text node or the empty list
+
edit filter for changing the name of a tag node, an attribute or a pi.
+ result of the filter is a single element list with a tag node or the empty list
+
edit filter for changing the value of an attribute in a tag node.
+ result of the filter is a single element list with the tag node or the empty list.
+
1.parameter n : the name of the attribute
+
2.parameter f : the edit function for the attribute value
+
convenient function for tag node tree construction
+
infixl 7
+
filter combinator for tag tree constrcution
+ take a 1. filter for computing a tag node tree (or a whole list of tag node trees)
+ then add all trees computed by the 2. filter to the attribute list when they represent attributes
+ else append them to the list of children.
+
if the 1. filter computes a list of tag nodes, the results of the 2. filter are added to all trees
+
example: etag "a" += sattr "href" "#42" += txt "the answer"
+ gives the tree <a href="#42">the answer</a>
+
example: ( etag "a" +++ etag "b" ) += sattr "x" "42"
+ gives the tree <a x="42"/><b x="42"/>
+
variant of mkXTag with a list of filters for the attributes and a list of filters for the children.
+ this variant leads to a more readable source for a complicated construction filter
+ than the simple solution with a combination of mkXTag and cat.
+
reads the value of an attribute, usually applied to a document root node,
+ and checks if the value represents True. The following strings are interpreted
+ as true: "1", "True", "true", "yes", "Yes".
+
1.parameter al : the attribute list for the root. This list must contain at
+ least an attribute "source" that contains the URI of the document to be processed
+
2.parameter cs : the list for the document content
+
returns : the processing instruction tree with a single attribute "value"
+ with the str parameter as attribute value, with valueOf a_value applied to the result tree
+ the content of the PI can be selected
+
select the universal name (namespace uri ++ localPart) of a tag or an attribute tree, else the empty string is returned
+ see also : nameOf, namespaceOf
+
monadic filter for reading, parsing and checking a wellformed document.
+ the input tree must consist of a root node with a source attribute
+ in its attribute list.
+
All attributes from the document root are copied into the system state,
+ and may be queried by the monadic filters, e.g. trace options.
+
Result is the single element list containing the well-formed document tree
+ or, in case of errors, the document root with an empty list as children
+ and attributes a_status and a_module for error level and the module,
+ where the error occured.
+
This parser tries to interprete everything as HTML
+ no errors are emitted during parsing. If something looks
+ weired, warning messages are inserted in the document tree.
+
Module contains state filter for easy parsing and error handling
+ real work is done in HtmlParsec
+
read a document and parse it with parseHtmlDoc. The main entry point of this module
+
The input tree must be a root tree like in ' Text.XML.HXT.Parser.MainFunctions.getXmlDoc'. The content is read with getXmlContents,
+ is parsed with parseHtmlDoc and canonicalized (char refs are substituted in content and attributes,
+ but comment is preserved)
+
The input is parsed with runHtmlParser, everything is interpreted as HTML,
+ if errors ocuur, the parser will try to do some meaningfull action and continues
+ parsing. Afterwards the entitiy references for defined for XHTML are resovled,
+ any unresolved reference is transformed into plain text.
+
Error messages
+ during parsing and entity resolving are added as warning nodes into the resulting tree.
+
The warnings are issued, if the 1. parameter noWarnings is set to True,
+ afterwards all are removed from the resulting tree.
+
the main building blocks for an application.
+ this module exports complex filters and functions for
+ common tasks for input and parsing, output and option handling.
+
writes a complete document tree to a file, writing can be
+ controlled by options, the real work is done with filter writeDocument.
+ useful options are the options of writeDocument.
+
result is a pair: 1.part is a list of error messages, 2. part is the return code,
+ the status info of the write filter
+
this filter is useful, when processing XML in an arbitray context in the IO monad
+
an example main program for such an application is:
+
main :: IO ()
+ main
+ = do
+ (input, readErrs, rc) <- getXmlDocument [...] "test.xml"
+ if rc >= c_err
+ then issueErrors readErrs
+ else processTree input
+
+ processTree :: XmlTree -> IO ()
+ processTree t
+ = let res = computeNewTree input
+ in do
+ (writeErrs, rc2) <- putXmlDocument [...] "out.xml" res
+ if rc2 >= c_err
+ then issueErrors writeErrs
+ else return ()
+
+ issueErrors :: XmlTrees -> IO ()
+
+ computeNewTree :: XmlTree -> XmlTree
+
this filter can be configured by an option list, a list of
+ option name, option value pairs.
+ the input tree must be a possibly empty document root tree.
+ all the options are stored as attributes in this root node to control processing.
+
available options:
+
a_parse_html: use HTML parser, else use XML parser (default)
+
a_remove_whitespace : remove all whitespace, used for document indentation, else skip this step (default)
+
a_indent : indent document by inserting whitespace, else skip this step (default)
+
a_issue_warnings : issue warnings, when parsing HTML (default), else ignore HTML parser warnings
+
a_issue_errors : issue all error messages on stderr (default), or ignore all error messages
+
a_collect_errors : all error messages are collected during processing and appended to the result document
+ for further processing within the calling modules
+
reads file "test.xml", validates it, checks namespaces, does not issue any erros
+ but collects errors and appends the list of errors to the single element list for the document.
+ this enables the calling application to define own error handlers.
+
a_output_xml : (default) issue XML: quote special XML chars >,<,",',&
+ add XML processing instruction
+ and encode document with respect to a_output_encoding,
+ if explizitly switched of, the plain text is issued, this is useful
+ for non XML output, e.g. generated Haskell code, LaTex, Java, ...
+
a_show_tree : show tree representation of document (for debugging)
+
a_show_haskell : show Haskell representaion of document (for debugging)
+
filter for reading the content of a XML document
+
input is a root node with the source as an attibute
+ the text is read, the encoding scheme is parsed and selected
+ and the input is translated into the internal UTF-8 string representation
+
compute the length of the data for a document read previously
+ by a call of 'getUrlContents. The result is stored as an attribute
+ value in the document root node. the attribute name is a_contentLength
+
The monadic parser for a whole document.
+ input must be a root node with a single text child.
+ Error messages are issued and global error state is set.
+
the main building blocks for an application.
+ this module exports all important functions for parsing, validating and transforming XML.
+ it also exports all basic datatypes and functions of the toolbox.
+
Checks if the attribute value meets the lexical constraints of its type.
+
1.parameter dtdPart : the children of the DOCTYPE node
+
2.parameter attrDecl : the declaration of the attribute from the DTD
+
returns : a function which takes an element (XTag or XDTD ATTLIST),
+ checks if the attribute value meets the lexical constraints
+ of its type and returns a list of errors
+
the input tree must consist of a root node with a complete document and DTD.
+ Result is the single element list containing same tree but tranformed with respect to the DTD,
+ or, in case of errors, the root with an empty list of children
+
filter for transforming a document with respect to the given DTD.
+
Validating parsers
+ are expected to normalize attribute values and add default values.
+ This function should be called after a successful validation.
+
returns : a function which expects a complete XML document tree
+ and returns the transformed XmlTree
+
hxt-filter-8.0.0: A collection of tools for processing XML with Haskell (Filter variant).
The Haskell XML Toolbox bases on the ideas of HaXml and HXML. This package is a compatibitlity package for old software working with the filter approach like in HaXml. For new projects it's recomended to use the arrow based library (hxt).
+
diff --git a/doc/hxt-filter/minus.gif b/doc/hxt-filter/minus.gif
new file mode 100644
Binary files /dev/null and b/doc/hxt-filter/minus.gif differ
diff --git a/doc/hxt-filter/plus.gif b/doc/hxt-filter/plus.gif
new file mode 100644
Binary files /dev/null and b/doc/hxt-filter/plus.gif differ
diff --git a/doc/hxt-filter/src/Control-Monad-MonadStateIO.html b/doc/hxt-filter/src/Control-Monad-MonadStateIO.html
new file mode 100644
--- /dev/null
+++ b/doc/hxt-filter/src/Control-Monad-MonadStateIO.html
@@ -0,0 +1,107 @@
+
+
+
+
+Haskell Code by HsColour
+
+
+
+
-- |
+-- general usefull state monad for a local state and IO
+--
+-- This module is used for threading a state and io actions
+-- through a computation.
+-- Here the monad is constructed by hand.
+-- It could easily be refactored with the use of the monad transformer library.
+
+
+moduleControl.Monad.MonadStateIO
+(moduleControl.Monad.MonadStateIO
+)
+where
+
+importSystem.IO
+
+-- ------------------------------------------------------------
+
+newtypeStateIOstateres=STIO{trans::state->IO(res,state)}
+
+instanceMonad(StateIOstate)where
+returnv
+=STIO(\s->return(v,s))
+
+STIOcmd>>=f
+=STIO(\s->
+cmds>>=\(rl,s')->
+(trans.f)rls'
+)
+
+-- ------------------------------------------------------------
+-- |
+-- lift IO command to 'StateIO'
+
+io::IOa->StateIOstatea
+ioiocmd
+=STIO(\s->
+do
+a<-iocmd
+return(a,s)
+)
+
+-- ------------------------------------------------------------
+
+-- |
+-- state inspection command: a \"show\"-like function is applied to the state
+-- and the result is written to stderr.
+
+trcState::(state->String)->StateIOstate()
+trcStatefct
+=STIO(\s->
+do
+hPutStrstderr$fcts
+return((),s)
+)
+
+-- ------------------------------------------------------------
+--
+-- state access commands
+
+-- |
+-- change the state with a given function and return the new state
+
+changeState::(state->state)->StateIOstatestate
+changeStatef
+=STIO(\s->
+lets'=fs
+in
+return(s',s')
+)
+
+-- |
+-- set the state
+
+setState::state->StateIOstatestate
+setStates
+=changeState(\_->s)
+
+-- |
+-- read the state
+
+getState::StateIOstatestate
+getState
+=changeStateid
+
+-- ------------------------------------------------------------
+-- |
+-- run a 'StateIO' command with an initial state
+
+run::state->StateIOstateres->IOres
+runinitialState(STIOcmd)
+=do
+(res,_finalState)<-cmdinitialState
+returnres
+
+
+-- ------------------------------------------------------------
+
-- |
+-- XML editing filters
+
+moduleText.XML.HXT.DOM.EditFilters
+(canonicalizeTree
+,canonicalizeAllNodes
+,canonicalizeForXPath
+
+,collapseXText
+,collapseAllXText
+
+,indentDoc
+
+,removeWhiteSpace
+,removeAllWhiteSpace
+,removeDocWhiteSpace
+
+,removeComment
+,removeAllComment
+
+,transfCdata,transfAllCdata-- CDATA to text
+,transfCdataEscaped,transfAllCdataEscaped-- CDATA to text
+,transfCharRef,transfAllCharRef-- &#nnn; to text
+
+,escapeXmlDoc
+,escapeXmlText
+,escapeXmlAttrValue
+
+,unparseXmlDoc
+,numberLinesInXmlDoc,numberLines
+,treeRepOfXmlDoc
+,haskellRepOfXmlDoc
+,addHeadlineToXmlDoc
+,addXmlPiToDoc
+)
+where
+
+importText.XML.HXT.DOM.XmlTree
+
+importText.XML.HXT.DOM.Unicode
+(getOutputEncodingFct)
+
+importText.XML.HXT.DOM.FormatXmlTree
+(formatXmlContents)
+
+importData.Maybe
+
+-- ------------------------------------------------------------
+
+-- |
+-- remove Comments
+
+removeComment::XmlFilter
+removeComment=none`when`isXCmt
+
+-- |
+-- remove all Comments recursively
+
+removeAllComment::XmlFilter
+removeAllComment=processBottomUpremoveComment
+
+-- ------------------------------------------------------------
+
+-- |
+-- simple filter for removing whitespace.
+--
+-- no check on sigificant whitespace is done.
+--
+--
+-- see also : 'removeAllWhiteSpace', 'removeDocWhiteSpace'
+
+removeWhiteSpace::XmlFilter
+removeWhiteSpace=none`when`isWhiteSpace
+
+-- |
+-- simple recursive filter for removing all whitespace.
+--
+-- removes all text nodes in a tree that consist only of whitespace.
+--
+--
+-- see also : 'removeWhiteSpace', 'removeDocWhiteSpace'
+
+removeAllWhiteSpace::XmlFilter
+removeAllWhiteSpace=processBottomUpremoveWhiteSpace
+
+-- ------------------------------------------------------------
+-- |
+-- converts CDATA sections in whole document tree into normal text nodes
+
+transfAllCdataEscaped::XmlFilter
+transfAllCdataEscaped=processBottomUptransfCdataEscaped
+
+-- |
+-- converts CDATA section in normal text nodes
+
+transfCdataEscaped::XmlFilter
+transfCdataEscaped(NTree(XCdatastr)_)
+=xtextstr
+
+transfCdataEscapedn
+=[n]
+
+
+-- ------------------------------------------------------------
+-- |
+-- converts CDATA sections in whole document tree
+
+transfAllCdata::XmlFilter
+transfAllCdata=processBottomUptransfCdata
+
+-- |
+-- converts CDATA section in normal text sections
+
+transfCdata::XmlFilter
+transfCdata(NTree(XCdatastr)_)
+=xtextstr
+
+transfCdatan
+=[n]
+
+
+-- ------------------------------------------------------------
+-- |
+-- converts character references to normal text
+
+transfCharRef::XmlFilter
+transfCharRef(NTree(XCharRefi)_)
+=xtext$[toEnumi]
+
+transfCharRefn
+=[n]
+
+-- ------------------------------------------------------------
+-- |
+-- recursively converts all character references to normal text
+
+transfAllCharRef::XmlFilter
+transfAllCharRef=processBottomUptransfCharRef
+
+-- ------------------------------------------------------------
+
+-- |
+-- Applies some "Canonical XML" rules to the nodes of a tree.
+--
+-- The rule 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
+-- order is done by the @transform@ function of module @Text.XML.HXT.Validator.Validation@.
+-- Replacing entities or line feed normalization is done by the parser.
+--
+--
+-- Not implemented yet:
+--
+-- - Whitespace within start and end tags is normalized
+--
+-- - Special characters in attribute values and character content are replaced by character references
+--
+-- see 'canonicalizeAllNodes' and 'canonicalizeForXPath'
+
+canonicalizeTree::XmlFilter->XmlFilter
+canonicalizeTreetoBeRemoved
+=processChildren(none`when`isXText)
+.>
+processBottomUpcanonicalize1Node
+where
+canonicalize1Node::XmlFilter
+canonicalize1Node
+=(deepisXPi`when`isXDTD)-- remove DTD parts, except PIs
+.>
+(none`when`toBeRemoved)-- remove unintersting nodes
+.>
+(processAttr(processChildrentransfCharRef
+.>
+collapseXText
+)`when`isXTag)
+.>
+transfCdata-- CDATA -> text
+.>
+transfCharRef-- Char refs -> text
+.>
+collapseXText-- combine text
+
+
+-- |
+-- canonicalize tree and remove comments and \<?xml ... ?> declarations
+--
+-- see 'canonicalizeTree'
+
+canonicalizeAllNodes::XmlFilter
+canonicalizeAllNodes
+=canonicalizeTree(isXCmt-- remove comment
++++
+isPit_xml-- remove xml declaration
+)
+
+-- |
+-- Canonicalize a tree for XPath
+-- Comment nodes are not removed
+--
+-- see 'canonicalizeTree'
+
+canonicalizeForXPath::XmlFilter
+canonicalizeForXPath
+=canonicalizeTree(isPit_xml)
+
+-- ------------------------------------------------------------
+
+-- |
+-- Collects sequences of child XText nodes into one XText node.
+
+collapseXText::XmlFilter
+collapseXTextn
+=replaceChildren(collapseXText'$getChildrenn)n
+where
+collapseXText'::XmlSFilter
+collapseXText'((NTreen1_):(NTreen2_):zs)
+|isXTextNoden1&&isXTextNoden2
+=collapseXText'$(xtext(t1++t2))++zs
+where
+t1=textOfXNoden1
+t2=textOfXNoden2
+
+collapseXText'(x:xs)
+=x:(collapseXText'xs)
+
+collapseXText'[]
+=[]
+
+
+-- |
+-- Applies collapseXText recursively.
+--
+--
+-- see also : 'collapseXText'
+
+collapseAllXText::XmlFilter
+collapseAllXText=processBottomUpcollapseXText
+
+
+-- ------------------------------------------------------------
+--
+
+-- |
+-- filter for indenting a document tree for pretty printing.
+--
+-- the tree is traversed for inserting whitespace for tag indentation.
+--
+-- whitespace is only inserted or changed at places, where it isn't significant,
+-- is's not inserted between tags and text containing non whitespace chars.
+--
+-- whitespace is only inserted or changed at places, where it's not significant.
+-- preserving whitespace may be controlled in a document tree
+-- by a tag attribute @xml:space@
+--
+-- allowed values for this attribute are @default | preserve@.
+--
+-- input is a complete document tree.
+-- result the semantically equivalent formatted tree.
+--
+--
+-- see also : 'removeDocWhiteSpace'
+
+indentDoc::XmlFilter
+indentDoc
+=modifyChildren(indentRootChildren$$)
+`when`
+isRoot
+where
+indentRootChildren::XmlFilter
+indentRootChildren
+=insertNL`o`indentChild`o`removeText
+where
+removeText
+=none`when`isXText
+insertNL
+=this+++txt"\n"
+indentChild
+=modifyChildren(indentTrees(insertIndentation2)False1)
+`whenNot`
+isXDTD-- DTD elements are not indented
+
+-- |
+-- filter for removing all not significant whitespace.
+--
+-- the tree traversed for removing whitespace between tags,
+-- that was inserted for indentation and readability.
+-- whitespace is only removed at places, where it's not significat
+-- preserving whitespace may be controlled in a document tree
+-- by a tag attribute @xml:space@
+--
+-- allowed values for this attribute are @default | preserve@
+--
+-- input is root node of the document to be cleaned up
+-- output the semantically equivalent simplified tree
+--
+--
+-- see also : 'indentDoc', 'removeAllWhiteSpace'
+
+removeDocWhiteSpace::XmlFilter
+removeDocWhiteSpace
+=processChildrenprocessRootElement
+`when`
+isRoot
+where
+processRootElement::XmlFilter
+processRootElement
+=removeText.>processChild
+where
+removeText
+=none`when`isWhiteSpace
+processChild
+=choice[isXDTD
+:->removeAllWhiteSpace-- whitespace in DTD is redundant
+,this
+:->modifyChildren-- same strategie as for indentation
+(indentTreesinsertNothingFalse1)
+]
+
+indentTrees::(Int->XmlFilter)->Bool->Int->XmlTrees->XmlTrees
+indentTrees___[]
+=[]
+indentTreesindentFilterpreserveSpacelevelts
+=(lsf$$ls)++indentRestrs
+where
+(ls,rs)
+=break(satisfiesisXTag)ts
+
+isSignificant::Bool
+isSignificant
+=preserveSpace
+||
+any(satisfiesisSignificantPart)ls
+
+isSignificantPart::XmlFilter
+isSignificantPart
+=cat[isXText`guards`negisWhiteSpace
+,isXCdata
+,isXCharRef
+,isXEntityRef
+]
+
+lsf::XmlFilter
+lsf
+|isSignificant
+=this
+|otherwise
+=(none`when`isWhiteSpace)
+.>
+(indentFilterlevel+++this)
+
+indentRest::XmlSFilter
+
+indentRest[]
+|isSignificant
+=[]
+|otherwise
+=indentFilter(level-1)(mkXTextTree"")
+
+indentRest(t':ts')
+=((modifyChildrenindentChildren.>lsf)
+`when`
+isXTag
+$t'
+)
+++
+(ifnullts'
+thenindentRestts'
+elseindentTreesindentFilterpreserveSpacelevelts'
+)
+where
+xmlSpaceAttrName="xml:space"
+xmlSpaceAttrValue=valueOfxmlSpaceAttrNamet'
+preserveSpace'
+=fromMaybepreserveSpace
+.
+lookupxmlSpaceAttrValue
+$[("preserve",True)
+,("default",False)
+]
+indentChildren
+|all(satisfiesisWhiteSpace)$getChildrent'
+=(none$$)
+|otherwise
+=indentTreesindentFilterpreserveSpace'(level+1)
+
+-- filter for indenting tags
+
+insertIndentation::Int->Int->XmlFilter
+insertIndentationindentWidthlevel
+=txt('\n':replicate(level*indentWidth)' ')
+
+-- filter for removing all whitespace
+
+insertNothing::Int->XmlFilter
+insertNothing_=none
+
+-- ------------------------------------------------------------
+
+-- |
+-- escape XmlText,
+-- transform all special XML chars into CharRefs
+
+escapeString::(Char->Bool)->String->XmlTrees
+escapeString_isEsc[]
+=[]
+escapeStringisEsc(c:s1)
+|isEscc
+=mkXCharRefTree(fromEnumc):escapeStringisEscs1
+escapeStringisEscs
+=mkXTextTrees1:escapeStringisEscs2
+where
+(s1,s2)=breakisEscs
+
+escapeText::(Char->Bool)->XmlFilter
+escapeTextisEsc(NTreen_)
+|isXTextNoden
+=escapeStringisEsc(textOfXNoden)
+
+escapeTextisEsc(NTree(XCmtc)_)
+=xcmt(xshow.escapeStringisEsc$c)
+
+escapeText_t
+=[t]
+
+-- |
+-- convert the special XML chars in a text or comment node
+-- into character references
+--
+-- see also 'escapeXmlDoc'
+
+escapeXmlText::XmlFilter
+escapeXmlText=escapeText(`elem`"<&")-- no escape for ", ' and > required: XML standard 2.4
+
+-- |
+-- convert the special XML chars in an attribute value into
+-- charachter references. Not only the XML specials but also \\n, \\r and \\t are converted
+--
+-- see also: 'escapeXmlDoc', 'escapeXmlText'
+
+escapeXmlAttrValue::XmlFilter
+escapeXmlAttrValue=escapeText(`elem`"<>\"\'&\n\r\t")
+
+-- |
+-- convert the special XML chars \", \<, \>, & and \' in a document to char references,
+-- attribute values are converted with 'escapeXmlAttrValue'
+--
+-- see also: 'escapeXmlText', 'escapeXmlAttrValue'
+
+escapeXmlDoc::XmlFilter
+escapeXmlDoc
+=choice[isXTag:->(processChildren(escapeXmlDoc)
+.>
+processAttrescVal
+)
+,isXText:->escapeXmlText
+-- , isXCmt :-> escapeXmlText -- no escape in comments reqired: XML standard 2.4
+,isXDTD:->processTopDownescDTD
+,this:->this
+]
+where
+escVal=processChildrenescapeXmlAttrValue
+escDTD=escVal`when`(isEntity+++isParameterEntity)
+
+-- ------------------------------------------------------------
+
+-- |
+-- convert a document tree into an output string representation
+-- with respect to the output encoding.
+--
+-- The children of the document root are stubstituted by
+-- a single text node for the text representation of the document.
+--
+-- Encoding of the document is performed with respect
+-- to the @output-encoding@ attribute in the root node, or if not present,
+-- of the @encoding@ attribute for the original input encoding.
+-- If the encoding is not specified or not supported, UTF-8 is taken.
+
+unparseXmlDoc::XmlFilter
+unparseXmlDocn
+=modifyChildren((modifyTextencFct$$).xmlTreesToText)n
+where
+encFct=fromMaybeid(getOutputEncodingFct(encSpecn))
+
+encSpec::XmlTree->String
+encSpecn
+=head.filter(not.null)
+$[valueOfa_output_encodingn
+,valueOfa_encodingn
+,utf8
+]
+
+-- ------------------------------------------------------------
+--
+-- add or modify a XML directive for a document
+-- for specifying the encoding scheme
+
+addXmlPiToDoc::XmlFilter
+addXmlPiToDocn
+=(modifyChildrenaddX-- add <?xml ...>, if neccessary
+`whenNot`
+(getChildren.>isPit_xml)
+)
+.>
+processChildren(addAttra_encodingenc-- set or replace encoding="..."
+`when`
+isPit_xml
+)
+$n
+where
+enc=encSpecn
+addXcs=mkXmlDeclTree(xattra_version"1.0"):xtext"\n"++cs
+
+-- ------------------------------------------------------------
+
+-- |
+-- convert a document into a text and add line numbers to the text representation.
+--
+-- Result is a root node with a single text node as child.
+-- Useful for debugging and trace output.
+-- see also : 'haskellRepOfXmlDoc', 'treeRepOfXmlDoc'
+
+numberLinesInXmlDoc::XmlFilter
+numberLinesInXmlDoc
+=modifyChildren((modifyTextnumberLines$$).xmlTreesToText)
+
+numberLines::String->String
+numberLinesstr
+=concat$
+zipWith(\nl->lineNrn++l++"\n")[1..](linesstr)
+where
+lineNr::Int->String
+lineNrn=(reverse(take6(reverse(shown)++replicate6' ')))++" "
+
+-- ------------------------------------------------------------
+
+-- |
+-- convert a document into a text representation in tree form.
+--
+-- Useful for debugging and trace output.
+-- see also : 'haskellRepOfXmlDoc', 'numberLinesInXmlDoc'
+
+treeRepOfXmlDoc::XmlFilter
+treeRepOfXmlDoc
+=rootTag[getAttrl][formatXmlContents]
+
+-- |
+-- convert a document into a Haskell representation (with show).
+--
+-- Useful for debugging and trace output.
+-- see also : 'treeRepOfXmlDoc', 'numberLinesInXmlDoc'
+
+haskellRepOfXmlDoc::XmlFilter
+haskellRepOfXmlDocn
+=rootTag[getAttrl][txt$shown]n
+
+-- ------------------------------------------------------------
+
+addHeadlineToXmlDoc::XmlFilter
+addHeadlineToXmlDocn
+=replaceChildren(xtexttitle++getChildrenn++xtext"\n")n
+where
+headline="content of: "++valueOfa_sourcen
+underline=map(\_->'=')headline
+title="\n"++headline++"\n"++underline++"\n\n"
+
+-- ------------------------------------------------------------
+
-- |
+-- Namespace filter
+--
+-- Namespaces are processed with two main filter, 'propagateNamespaces'
+-- and 'validateNamespaces'.
+--
+-- 'propagateNamespaces' takes a XML tree and
+-- attaches extra namespace info at every tag name and attribute name.
+-- So after processing a tree with 'propagateNamespaces', the access functions
+-- "namespaceOf" and "universalNameOf" deliver the associated namespace (or \"\")
+-- for tag names and attribute names.
+--
+-- 'validateNamespaces' checks whether names are wellformed related to the XML namespace definition.
+-- whether a legal namespace is declared for all prefixes, and whether attribute names are unique
+-- related to universal names.
+
+moduleText.XML.HXT.DOM.NamespaceFilter
+(moduleText.XML.HXT.DOM.NamespaceFilter
+,moduleText.XML.HXT.DOM.NamespacePredicates
+)
+where
+
+importText.XML.HXT.DOM.XmlTree
+
+importText.XML.HXT.DOM.NamespacePredicates
+
+importText.XML.HXT.DOM.Util
+(doubles)
+
+-- -----------------------------------------------------------------------------
+--
+
+-- |
+-- Type for the namespace association list, used when propagating namespaces by
+-- modifying the 'QName' values in a tree
+
+typeNamespaceTable=NsEnv
+
+-- -----------------------------------------------------------------------------
+
+-- |
+-- propagate all namespace declarations \"xmlns:ns=...\" to all
+-- tag and attribute nodes of a document.
+--
+-- This filter does not check for illegal use of namespaces.
+-- The real work is done by 'propagateNamespaceEnv'.
+--
+-- The filter may be applied repeatedly if neccessary.
+
+propagateNamespaces::XmlFilter
+propagateNamespaces=propagateNamespaceEnv[(a_xml,xmlNamespace),(a_xmlns,xmlnsNamespace)]
+
+-- |
+-- attaches the namespace info given by the namespace table
+-- to a tag node and its attributes and children.
+
+propagateNamespaceEnv::NamespaceTable->XmlFilter
+propagateNamespaceEnvenvn
+=((processAttr(attachNamespaceUrisToAttrnewEnv)
+.>
+processChildren(propagateNamespaceEnvnewEnv)
+.>
+modifyQName(setNamespacenewEnv)
+)
+`when`
+isXTag
+)
+$n
+where
+nsAttrs=getAttrl-- scan all attributes
+.>
+isOfAttr((\(px,lp)
+->(px==a_xmlns-- check for prefix or whole name is "xmlns"
+&&
+lp/=":"-- check for none empty local part, "xmlns:" is not a legal name
+)
+)
+.span(/=':')-- break the name into a pair ("prefix", ":localPart")
+.qualifiedName-- select attribute name
+)
+$n
+nsDecl=zip(map(drop1-- drop the ":", empty local part represents default name space
+.snd-- take the local part with leading ":"
+.span(/=':')-- break it like above
+.nameOf-- select attribute name
+)nsAttrs)
+(map(xshow
+.
+getChildren
+)nsAttrs)
+newEnv=addEntriesnsDeclenv
+
+attachNamespaceUrisToAttr::NamespaceTable->XmlFilter
+attachNamespaceUrisToAttrattrEnv
+=(isOfAttr((\(px,lp)
+->((not.null.drop1)lp-- prefix and local part must not be empty
+&&
+(not.null)px
+)
+)
+.span(/=':')-- break the name into a pair ("prefix", ":localPart")
+.qualifiedName-- select attribute name
+)
+`guards`
+modifyQName(setNamespaceattrEnv)
+)
+`orElse`
+(modifyQName(constxmlnsQN)-- "xmlns" ist the only attr name without prefix but with an associated namespace URI
+`when`
+isAttra_xmlns
+)
+
+-- -----------------------------------------------------------------------------
+
+-- |
+-- validate the namespace constraints in a whole tree.
+-- result is the list of errors concerning namespaces.
+-- Work is done by applying 'validate1Namespaces' to all nodes.
+-- Predicates 'isWellformedQName', 'isWellformedQualifiedName', 'isDeclaredNamespace'
+-- and 'isWellformedNSDecl' are applied to the appropriate tags and attributes.
+
+validateNamespaces::XmlFilter
+validateNamespaces
+=choice[isRoot
+:->getChildren.>validateNamespaces-- root is correct by definition
+,this
+:->multivalidate1Namespaces
+]
+
+-- |
+-- a single node for namespace constrains.
+
+validate1Namespaces::XmlFilter
+validate1Namespaces
+=choice[isXTag
+:->
+cat[isOfTag(not.isWellformedQName)
+`guards`
+(\n->err("tag name "++show(nameOfn)++" is not a wellformed qualified name")n)
+
+,isOfTag(not.isDeclaredNamespace)
+`guards`
+(\n->err("namespace for prefix in tag name "++show(nameOfn)++" is undefined")n)
+
+,(\n->(let
+dbls=doubles((mapuniversalNameOf.getAttrl)n)
+in
+ifnulldbls
+thennone
+elseerr("multiple occurences of universal names for attributes of tag "
+++show(nameOfn)
+++" : "++foldr1(\xy->x++", "++y)(mapshowdbls)
+)
+)$n
+)
+
+,getAttrl.>validate1Namespaces
+]
+
+,isXAttr
+:->
+cat[isOfAttr(not.isWellformedQName)
+`guards`
+(\n->err("attribute name "++show(nameOfn)++" is not a wellformed qualified name")n)
+
+,isOfAttr(not.isDeclaredNamespace)
+`guards`
+(\n->err("namespace for prefix in attribute name "++show(nameOfn)++" is undefined")n)
+
+,(hasPrefixa_xmlns.>neg(xmlTreesToText.getChildren))
+`guards`
+(\n->err("namespace value of namespace declaration for "++show(nameOfn)++" has no value")n)
+
+,isOfAttr(not.isWellformedNSDecl)
+`guards`
+(\n->err("illegal namespace declaration with reserved prefix "++show(localPartOfn)++" starting with \"xml\"")n)
+]
+
+,isXDTD
+:->
+cat[((isDoctype+++isAttlist+++isElement+++isDTDName)
+.>
+isOf(not.isWellformedQualifiedName.valueOfDTDa_name)
+)
+`guards`
+(\n->err("a DTD part contains a not wellformed qualified Name: "++show(valueOfDTDa_namen))n)
+
+,(isAttlist
+.>
+isOf(not.isWellformedQualifiedName.valueOfDTDa_value)
+)
+`guards`
+(\n->err("an ATTLIST declaration contains as attribute name a not wellformed qualified Name: "++show(valueOfDTDa_valuen))n)
+
+,((isEntity+++isParameterEntity+++isNotation)
+.>
+isOf(not.isNCName.valueOfDTDa_name)
+)
+`guards`
+(\n->err("an entity or notation declaration contains a not wellformed NCName: "++show(valueOfDTDa_namen))n)
+]
+,isXPi
+:->
+(isOf(not.isNCName.nameOf)
+`guards`
+(\n->err("a PI contains a not wellformed NCName: "++show(nameOfn))n)
+)
+]
+
+-- -----------------------------------------------------------------------------
+
+isNamespaceDecl::XmlFilter
+isNamespaceDecl
+=isOfAttrxmlnsName
+where
+xmlnsName::AttrName->Bool
+xmlnsNamea
+=px==a_xmlns
+&&
+(nullln||headln==':')
+where
+(px,ln)=splitAt5.qualifiedName$a
+
+-- -----------------------------------------------------------------------------
+
-- |
+-- This module provides a Monad for an internal state and IO commands.
+-- The state consists of two parts, the user state and the system state
+-- user state ist a type parameter, the system state is a list
+-- name-value pair. If the user state is not needed, the type parameter
+-- can be instantiated with @()@.
+--
+-- Furthermore there are types for Xml filter working on this monad
+-- and functions for manipulating the state components
+-- and for lifting i\/o commands and XmlFilter to monad filters.
+--
+-- Error reporting functions are also located in this module.
+
+moduleText.XML.HXT.DOM.XmlState
+(moduleText.XML.HXT.DOM.XmlState
+)
+where
+
+importText.XML.HXT.DOM.XmlTree
+
+importqualifiedControl.Monad.MonadStateIOasMonadStateIO
+
+importSystem.IO
+importData.Maybe
+
+-- ------------------------------------------------------------
+
+-- |
+-- The internal system state consists of a list of name-value pairs
+-- of type @(String, XmlTrees)@, so arbitrary lists of trees can be stored.
+-- For options, often only strings are used as values, so a set of access
+-- functions with string values is available
+-- The error handling method can be controlled by an error handler filter,
+-- the default filter issues the errors on stderr
+
+dataSysState=SysState{sysStateAttrs::!SysStateAttrs
+,sysStateErrorHandler::!(XmlStateFilter())
+}
+
+typeSysStateAttrs=AssocListStringXmlTrees
+
+-- |
+-- The State has a system and a user part
+-- the user state is a type parameter
+
+dataXmlStatestate=XmlState{sysState::!SysState
+,userState::!state
+}
+
+-- |
+-- The monad type for commands. It is an instance of "StateIO" from the
+-- general module "Control.Monad.MonadStateIO".
+
+typeXStatestateres=MonadStateIO.StateIO(XmlStatestate)res
+
+-- |
+-- The "XmlFilter" type for filters working on a state
+
+typeXmlStateFilterstate=XmlTree->XStatestateXmlTrees
+
+-- ------------------------------------------------------------
+--
+-- user defined state
+-- access functions
+
+-- |
+-- change the user state
+--
+-- * 1.parameter fct : the user state change function
+--
+-- - returns : the new state
+
+changeState::(state->state)->XStatestatestate
+changeStatef
+=do
+ns<-MonadStateIO.changeStatef'
+return(userStatens)
+where
+f's=s{userState=f(userStates)}
+
+-- |
+-- set the user state.
+--
+-- * 1.parameter s : the new state
+--
+-- - returns : the new state
+
+setState::state->XStatestatestate
+setStates
+=changeState(\_->s)
+
+-- |
+-- read the user state
+--
+-- - returns : the current state
+
+getState::XStatestatestate
+getState
+=changeStateid
+
+-- ------------------------------------------------------------
+
+-- |
+-- change the system part of the state.
+--
+-- see also : 'changeState'
+
+changeSysState::(SysState->SysState)->XStatestateSysState
+changeSysStatef
+=do
+ns<-MonadStateIO.changeStatef'
+return(sysStatens)
+where
+f's=s{sysState=f(sysStates)}
+
+-- |
+-- set the system part of the state.
+--
+-- see also : 'setState'
+
+setSysState::SysState->XStatestateSysState
+setSysStates
+=changeSysState(\_->s)
+
+-- |
+-- read the system part of the state.
+--
+-- see also : 'getState'
+
+getSysState::XStatestateSysState
+getSysState
+=changeSysStateid
+
+-- |
+-- the initial system state
+--
+-- an empty list of attribute value pairs
+
+initialSysState::SysState
+initialSysState
+=SysState{sysStateAttrs=[]
+,sysStateErrorHandler=errorMsgToStderr
+}
+
+-- |
+-- change the attributes in the system state
+
+changeSysStateAttrs::(SysStateAttrs->SysStateAttrs)->(SysState->SysState)
+changeSysStateAttrscfsstate
+=sstate{sysStateAttrs=cf(sysStateAttrssstate)}
+
+
+-- |
+-- set the error message handler
+
+setSysErrorHandler::XmlStateFilter()->XStatestate()
+setSysErrorHandlerehf
+=do
+changeSysState(\s->s{sysStateErrorHandler=ehf})
+return()
+
+-- |
+-- get the error handler
+
+getSysErrorHandler::XStatestate(XmlStateFilter())
+getSysErrorHandler
+=do
+s<-getSysState
+return(sysStateErrorHandlers)
+
+-- ------------------------------------------------------------
+
+-- |
+-- set or change a single system parameter.
+--
+-- * 1.parameter name : the name of the parameter
+--
+-- - 2.parameter value : the list of associated trees
+--
+-- - returns : nothing
+--
+-- see also : 'setSysParam', 'setSysParamInt'
+
+setSysParamTree::String->XmlTrees->XStatestate()
+setSysParamTreenameval
+=do
+changeSysState(changeSysStateAttrs(addEntrynameval))
+return()
+
+-- |
+-- set or change a single system parameter of type string.
+--
+-- * 1.parameter name : the name of the parameter
+--
+-- - 2.parameter value : the (new) string value
+--
+-- - returns : nothing
+--
+-- see also : 'setSysParamTree', setSysParamInt
+
+setSysParam::String->String->XStatestate()
+setSysParamnameval
+=setSysParamTreename(xtextval)
+
+-- |
+-- set or change a single integer type system parameter
+--
+-- see also : 'setSysParam'
+
+setSysParamInt::String->Int->XStatestate()
+setSysParamIntnameval=setSysParamname(showval)
+
+-- |
+-- add (or change) all attributes of the document root to the system state
+-- - returns : this
+
+setSystemParams::XmlStateFilterstate
+setSystemParamst
+=do
+changeSysState(changeSysStateAttrs(addEntries(toTreel.getAttrl$t)))
+thisMt
+
+-- ------------------------------------------------------------
+
+-- |
+-- read a system parameter
+--
+-- * 1.parameter name : the name of the parameter
+--
+-- - returns : the list of tres associated with the key, or the empty list for unknown parameters
+
+getSysParamTree::String->XStatestateXmlTrees
+getSysParamTreename
+=do
+s<-getSysState
+return(lookup1name(sysStateAttrss))
+
+-- |
+-- read a system string parameter
+--
+-- * 1.parameter name : the name of the parameter
+--
+-- - returns : the value, or the empty string for unknown parameters
+
+getSysParam::String->XStatestateString
+getSysParamname
+=do
+ts<-getSysParamTreename
+return(xshowts)
+
+-- |
+-- read a system parameter or return a default value
+--
+-- * 1.parameter name : the name of the parameter
+--
+-- - 2.parameter default : the default value
+--
+-- - returns : the value if found, else the default
+
+getSysParamWithDefault::String->String->XStatestateString
+getSysParamWithDefaultnamedef
+=do
+val<-getSysParamname
+return(ifnullval
+thendef
+elseval
+)
+
+-- |
+-- read an integer system parameter
+--
+-- * 1.parameter name :
+--
+-- - 2.parameter default :
+--
+-- see also : 'getSysParamWithDefault'
+
+getSysParamInt::String->Int->XStatestateInt
+getSysParamIntvardef
+=do
+val<-getSysParamWithDefaultvar(showdef)
+return(readval)
+
+-- ------------------------------------------------------------
+
+-- |
+-- exec a XState command with initial state.
+--
+-- * 1.parameter initalState : the inital user state
+--
+-- - 2.parameter cmd : the command
+--
+-- - returns : the i\/o command with result and user state
+
+run0::XmlStatestate->XStatestateres->IO(res,XmlStatestate)
+run0initialState(MonadStateIO.STIOcmd)
+=do
+(res,finalState)<-cmdinitialState
+return(res,finalState)
+
+-- |
+-- exec a XState command with initial user state.
+-- ignore final user state.
+-- like run0, but ignore the resulting user state
+
+run::state->XStatestateres->IOres
+runinitialUserStatecmd
+=do
+(res,_finalState)<-run0(XmlStateinitialSysStateinitialUserState)cmd
+returnres
+
+-- |
+-- exec a XState command in th IO monad.
+-- like run with the empty state ().
+
+run'::XState()res->IOres
+run'=run()
+
+-- ------------------------------------------------------------
+
+-- |
+-- run a command in a new user state.
+-- chain the system state part,
+-- init new system state with the current one, run the command and
+-- update the old system state with the resulting new system state
+--
+-- * 1.parameter initialUserState : the initial user state
+--
+-- - 2.parameter cmd : the command
+--
+-- - returns : the result of executing cmd and the final state
+
+chain'::state1->XStatestate1res->XStatestate0(res,state1)
+chain'initialUserState1cmd1
+=do
+sysState0<-getSysState
+(res,finalState1)<-io$run0(XmlStatesysState0initialUserState1)cmd1
+setSysState(sysStatefinalState1)
+return(res,(userStatefinalState1))
+
+-- |
+-- like chain' but forget the final user state
+--
+-- * 1.parameter initialUserState : the initial user state
+--
+-- - 2.parameter cmd : the command
+--
+-- - returns : only the result of executing cmd
+
+chain::state1->XStatestate1res->XStatestate0res
+chaininitialUserState1cmd1
+=do
+(res,_)<-chain'initialUserState1cmd1
+returnres
+
+-- ------------------------------------------------------------
+--
+-- lift functions
+
+-- |
+-- lift a XmlFilter to a XmlStateFilter filter
+-- issue all error nodes as error messages
+-- and remove the error nodes from the result
+--
+-- * 1.parameter f : the filter
+--
+-- - returns : the filter running in the state monad
+--
+-- all errors are filtered from the result and issued on stderr
+
+liftF::XmlFilter->XmlStateFilterstate
+liftFf=liftMff.>>issueError
+
+-- |
+-- lift an I\/O command
+--
+-- * 1.parameter cmd : the i\/o command
+--
+-- - returns : the i\/o command lifted to the XML state monad
+
+io::IOa->XStatestatea
+io=MonadStateIO.io
+
+-- ------------------------------------------------------------
+--
+
+-- |
+-- set the trace level.
+--
+-- convention:
+--
+-- 0: no trace output (default)
+--
+-- 1: trace important computation steps, e.g. accessing a document
+--
+-- 2: trace small computation steps
+--
+-- 3: output an intermediate result XmlTree in XML source format
+--
+-- 4: output an intermediate result XmlTree in tree representation
+--
+-- * 1.parameter level : the trace level
+--
+-- - returns : nothing
+
+setTraceLevel::Int->XStatestate()
+setTraceLevell=setSysParamInta_tracel
+
+-- |
+-- get the current trace level.
+--
+-- - returns : the current trace level
+
+getTraceLevel::XStatestateInt
+getTraceLevel=getSysParamInta_trace0
+
+-- |
+-- trace output for arbitray commands.
+--
+-- * 1.parameter level : the trace level,
+-- for which the command will be execuded
+-- if level \<= current trace level
+--
+-- - 2.parameter cmd : the command to be executed
+--
+-- - returns : nothing
+
+traceCmd::Int->XStatestatea->XStatestate()
+traceCmdlevelcmd
+=do
+trcLevel<-getTraceLevel
+iflevel<=trcLevel
+thendo
+_<-cmd
+return()
+elsereturn()
+
+-- |
+-- trace output function for simple text.
+--
+-- * 1.parameter level : like in traceCmd
+--
+-- - 2.parameter str : the test
+--
+-- - returns : nothing
+
+trace::Int->String->XStatestate()
+tracelevelstr
+=traceCmdlevel
+$do
+io$hPutStrLnstderr("-- ("++showlevel++") "++str)
+
+-- |
+-- trace output of the user part of the program state.
+--
+-- * 1.parameter level : like in traceCmd
+--
+-- - 2.parameter showFct : the toString function
+--
+-- - returns : nothing
+
+traceState::Int->(state->String)->XStatestate()
+traceStatelevelfct
+=traceCmdlevel
+$do
+s<-getState
+io$hPutStrLnstderr(fcts)
+
+-- ------------------------------------------------------------
+--
+-- error functions
+
+-- |
+-- filter to reset the state attribute 'a_status'
+-- - returns : this
+
+clearStatus::XmlStateFilterstate
+clearStatust
+=do
+setSysParamInta_statusc_ok
+thisMt
+
+-- |
+-- report an error message.
+--
+-- - returns : if the input tree n represents an error, @res = []@
+-- and the error is processed by the errror handler filter (default: error is issued on stderr)
+-- else @res = [n]@
+--
+-- see also : 'issueErr'
+
+issueError::XmlStateFilterstate
+issueError
+=(setErrorMsgLevel.>>errorMsgHandler.>>noneM)
+`whenM`
+isXError
+
+errorMsgHandler::XmlStateFilterstate
+errorMsgHandler
+=performAction
+(\t->chain'()(do
+ehf<-getSysErrorHandler
+ehft
+return()
+)
+)
+
+-- |
+-- set the error level in system state
+
+setErrorMsgLevel::XmlStateFilterstate
+setErrorMsgLevel
+=performAction
+(\(NTree(XErrorlevel_str)_cs)->
+do
+errLevel<-getSysParamInta_status0
+setSysParamInta_status(maxerrLevellevel)
+)
+
+-- |
+-- default error handler for writing errors to stderr
+
+errorMsgToStderr::XmlStateFilterstate
+errorMsgToStderr
+=performAction
+(\(NTree(XErrorlevelstr)_cs)->
+io$hPutStrLnstderr("\n"++errClasslevel++": "++str)
+)
+
+-- |
+-- error message handler for collecting all error messages
+-- all messages are stored under attribute 'a_error_log'
+-- they can be read with @getSysParamTree a_error_log@ or by
+-- applying the filter 'getErrorMsg' to the root node
+
+errorMsgLogging::XmlStateFilterstate
+errorMsgLogging
+=performAction
+(\t->
+do
+errLog<-getSysParamTreea_error_log
+setSysParamTreea_error_log(t:errLog)
+)
+
+errorMsgLoggingAndToStderr::XmlStateFilterstate
+errorMsgLoggingAndToStderr=errorMsgLogging.>>errorMsgToStderr
+
+-- |
+-- the filter for reading all collected error mesages
+--
+-- result is the list of error messages, the input tree is ignored
+
+getErrorMsg::XmlStateFilterstate
+getErrorMsg_t
+=do
+el<-getSysParamTreea_error_log
+setSysParamTreea_error_log[]
+return(reverseel)
+
+-- |
+-- error level translation
+-- 'c_warn' (1) : warning,
+-- 'c_err' (2): error (e.g. parse error, validation error, ...),
+-- 'c_fatal' (3) : fatal error (document access error, internal error, ...)
+
+errClass::Int->String
+errClassl
+=fromMaybe"fatal error".lookupl$msgList
+where
+msgList=[(c_ok,"no error")
+,(c_warn,"warning")
+,(c_err,"error")
+,(c_fatal,"fatal error")
+]
+
+-- |
+-- short cut for issuing a warning
+--
+-- see also : 'issueError', 'issueErr'
+
+issueWarn::String->XmlStateFilterstate
+issueWarnmsg=liftMf(warnmsg).>>issueError
+
+-- |
+-- short cut for issuing an error
+--
+-- see also : 'issueError'
+
+issueErr::String->XmlStateFilterstate
+issueErrmsg=liftMf(errmsg).>>issueError
+
+-- |
+-- short cut for issuing a fatal error
+--
+-- see also : 'issueError', 'issueErr'
+
+issueFatal::String->XmlStateFilterstate
+issueFatalmsg=liftMf(fatalmsg).>>issueError
+
+
+-- ------------------------------------------------------------
+--
+-- issue an error, add the error to the document root tree
+-- and return the tree
+
+addFatal::String->XmlStateFilterstate
+addFatalmsg
+=liftF(fatalmsg
++++
+setStatusc_fatal"accessing documents"
+)
+
+-- ------------------------------------------------------------
+
+-- |
+-- checks the value of the attribute 'a_status' in a document root.
+-- if it contains a value greater or equal to 'c_err', an error with error message
+-- stored in attribute 'a_module' is issued and the filter acts as the 'noneM' filter
+-- else its the 'thisM' filter
+
+checkStatus::XmlStateFilterstate
+checkStatust
+=ifstatus>=c_err
+thendo
+errorMsgHandler(mkXErrorTreec_warn(errClassstatus++"s detected in "++msg)[])
+noneMt
+else
+thisMt
+where
+status=intValueOfa_statust
+msg=valueOfa_modulet
+
+-- |
+-- add the error level and the module where the error occured
+-- to the attributes of a document root node and remove the children when level is greater or equal to 'c_err'
+
+setStatus::Int->String->XmlFilter
+setStatuslevelmsg
+=(addAttrInta_statuslevel
+.>
+addAttra_modulemsg
+.>
+(iflevel>=c_err
+thenreplaceChildren[]
+elsethis
+)
+)
+`when`isRoot
+
+-- |
+-- check whether tree is a document root and the status attribute has a value less than 'c_err'
+
+statusOk::XmlFilter
+statusOk
+=isRoot
+.>
+isOf(\t->not(intValueOfa_statust>=c_err))
+-- |
+-- check whether the error level attribute in the system state
+-- is set to error, in this case the children of the document root are
+-- removed and error info is added as attributes with 'setStatus'
+-- else nothing is changed
+
+checkResult::String->XmlStateFilterstate
+checkResultmsgt
+=do
+level<-getSysParamInta_status0
+(iflevel<=c_warn
+thenthisM
+elseliftMf(setStatuslevelmsg)
+)t
+
+-- |
+-- monadic filter for processing the attribute list of a tag.
+-- for other trees this filter acts like 'noneM'
+--
+-- see also : 'processAttr', 'processAttrl'
+
+processAttrM::XmlStateFiltera->XmlStateFiltera
+processAttrMft
+=do
+res<-f$$<al
+return$replaceAttrlrest
+where
+al=getAttrlt
+
+-- ------------------------------------------------------------
+
-- |
+-- basic XmlTree filter
+
+moduleText.XML.HXT.DOM.XmlTreeFilter
+(moduleText.XML.HXT.DOM.XmlTreeFilter
+)
+where
+
+importText.XML.HXT.DOM.XmlTreeTypes
+importText.XML.HXT.DOM.XmlTreeFunctions
+importText.XML.HXT.DOM.XmlKeywords
+importText.XML.HXT.DOM.Unicode(isXmlSpaceChar)
+importText.XML.HXT.DOM.Util(decimalStringToInt)
+
+importData.List(partition)
+
+infixl7+=,++=
+
+-- -----------------------------------------------------------------------------
+--
+-- filter predicates
+
+-- |
+-- test whether the root of a tree contains a document root node.
+
+isRoot::XmlFilter
+isRoot=isOfNode(isTagNodet_root)
+
+-- |
+-- test whether the root of a tree contains a tag node.
+--
+-- see also: 'isNsTag'
+
+isTag::String->XmlFilter
+isTagtn=isOfNode(isTagNodetn)
+
+-- |
+-- namespace aware test whether the root of a tree contains a tag node. Parameters are the local part and namespace.
+-- Only usable after namespace propagation.
+--
+-- see also: 'isTag'
+
+isNsTag::String->String->XmlFilter
+isNsTaglpns=isOfTag(\t->localPartt==lp&&namespaceUrit==ns)
+
+-- |
+-- test whether the root of a tree has a given local name
+-- see also : 'hasNamespace', 'hasPrefix', 'isTag', 'isAttr'
+
+hasLocalPart::String->XmlFilter
+hasLocalPartlp=isOf((==lp).localPartOf)
+
+-- |
+-- test whether the root of a tree has a given prefix name
+-- see also : 'hasNamespace', 'hasLocalPart', 'isTag', 'isAttr'
+
+hasPrefix::String->XmlFilter
+hasPrefixpx=isOf((==px).prefixOf)
+
+-- |
+-- test whether the root of a tree belongs to a given namespace
+-- see also : 'isTag', 'isAttr', 'hasLocalPart', 'hasPrefix'
+
+hasNamespace::String->XmlFilter
+hasNamespacens=isOf((==ns).namespaceOf)
+
+-- |
+-- test whether the root of a tree contains a tag node with a special name.
+
+isOfTag::(TagName->Bool)->XmlFilter
+isOfTag=isOfNode.isOfTagNode
+
+-- |
+-- test whether the node of a tree is a XTag node or a XPi node with an attibute of a specific name
+--
+-- see also: 'isAttr', 'hasNsAttr'
+
+hasAttr::String->XmlFilter
+hasAttran=(getAttrl.>isAttran)`guards`this
+
+-- |
+-- test whether the tree is a XTag node with an attibute of a specific local name and namespace uri
+--
+-- see also: 'hasAttr', 'isNsAttr'
+
+hasNsAttr::String->String->XmlFilter
+hasNsAttranns=(getAttrl.>isNsAttranns)`guards`this
+
+-- |
+-- test whether the given node is a XTag node or a XPI node with an attribute with a value with a specific property.
+-- In case of a match, the attribute value represented by a text node is returned as single element list,
+-- else the empty list is the result.
+--
+-- see also : 'getValue'
+
+hasValue::String->(String->Bool)->XmlFilter
+hasValueapt
+|(not.null)att
+&&
+pval
+=xtextval
+|otherwise
+=[]
+where
+att=getAttrl.>isAttra$t
+val=xshow.getChildren$$att
+
+-- |
+-- test whether the tree is a processing instruction with a given name.
+
+isPi::String->XmlFilter
+isPipn=isOfNode(isPiNodepn)
+
+-- |
+-- test whether the tree is a \<?xml ... ?\> declaration
+
+isXmlPi::XmlFilter
+isXmlPi=isPit_xml
+
+-- |
+-- test whether the root of a tree contains a processing instruction of a special name.
+
+isOfPi::(TagName->Bool)->XmlFilter
+isOfPi=isOfNode.isOfPiNode
+
+-- -----------------------------------------------------------------------------
+
+-- simple XNode Filter predicates
+--
+
+-- |
+-- test whether the root of a tree contains a CDATA node.
+
+isXCdata::XmlFilter
+isXCdata=isOfNodeisXCdataNode
+
+-- |
+-- test whether the root of a tree contains a character reference node.
+
+isXCharRef::XmlFilter
+isXCharRef=isOfNodeisXCharRefNode
+
+-- |
+-- test whether the root of a tree contains a comment node.
+
+isXCmt::XmlFilter
+isXCmt=isOfNodeisXCmtNode
+
+-- |
+-- test whether the root of a tree contains a DTD part.
+
+isXDTD::XmlFilter
+isXDTD=isOfNodeisXDTDNode
+
+-- |
+-- test whether the root of a tree contains an entity reference node.
+
+isXEntityRef::XmlFilter
+isXEntityRef=isOfNodeisXEntityRefNode
+
+-- |
+-- test whether the root of a tree contains an error node.
+
+isXError::XmlFilter
+isXError=isOfNodeisXErrorNode
+
+-- |
+-- test whether the root of a tree contains a processing instruction node.
+
+isXPi::XmlFilter
+isXPi=isOfNodeisXPiNode
+
+-- |
+-- test whether the root of a tree contains a tag node.
+
+isXTag::XmlFilter
+isXTag=isOfNodeisXTagNode
+
+-- |
+-- test whether the root of a tree contains an attribute node.
+
+isXAttr::XmlFilter
+isXAttr=isOfNodeisXAttrNode
+
+-- |
+-- test whether the root of a tree is an attribute node for a given attribute name
+
+isAttr::String->XmlFilter
+isAttran=isOfNode(isAttrNodean)
+
+-- |
+-- namespace aware test whether the tree contains an attribute node. Parameters are the local part of the atribute name and the namespace.
+-- Only usable after namespace propagation.
+--
+-- see also: 'isNsTag', 'isAttr', 'hasNsAttr'
+
+isNsAttr::String->String->XmlFilter
+isNsAttrlpns=isOfAttr(\a->localParta==lp&&namespaceUria==ns)
+
+-- |
+-- general test for an attribute name
+
+isOfAttr::(AttrName->Bool)->XmlFilter
+isOfAttr=isOfNode.isOfAttrNode
+
+-- |
+-- test whether the root of a tree contains a text node.
+
+isXText::XmlFilter
+isXText=isOfNodeisXTextNode
+
+-- |
+-- test whether the root of a tree contains a special text.
+
+isText::String->XmlFilter
+isTextt=isOfNode(isTextNodet)
+
+-- |
+-- test whether the root of a tree contains a text node with a special property
+
+isOfText::(String->Bool)->XmlFilter
+isOfText=isOfNode.isOfTextNode
+
+-- |
+-- test whether the root of a tree contains a text node only with whitespace.
+
+isWhiteSpace::XmlFilter
+isWhiteSpace
+=isOfNodeisWS
+where
+isWSn
+=isXTextNoden
+&&allisXmlSpaceChar(textOfXNoden)
+
+-- ------------------------------------------------------------
+--
+-- XDTD Predicates
+
+-- |
+-- test whether the root of a tree contains a DOCTYPE DTD part.
+
+isDoctype::XmlFilter
+isDoctype=isOfNode(isDTDElemNodeDOCTYPE)
+
+-- |
+-- test whether the root of a tree contains an ATTLIST DTD part.
+
+isAttlist::XmlFilter
+isAttlist=isOfNode(isDTDElemNodeATTLIST)
+
+-- |
+-- test whether the root of a tree contains an ELEMENT DTD part.
+
+isElement::XmlFilter
+isElement=isOfNode(isDTDElemNodeELEMENT)
+
+-- |
+-- test whether the root of a tree contains an ENTITY DTD part.
+
+isEntity::XmlFilter
+isEntity=isOfNode(isDTDElemNodeENTITY)
+
+-- |
+-- test whether the root of a tree contains a parameter ENTITY reference.
+
+isPeRef::XmlFilter
+isPeRef=isOfNode(isDTDElemNodePEREF)
+
+-- |
+-- test whether the root of a tree contains a DTD name part.
+
+isDTDName::XmlFilter
+isDTDName=isOfNode(isDTDElemNodeNAME)
+
+-- |
+-- test whether the root of a tree contains a conditional section DTD part.
+
+isCondSect::XmlFilter
+isCondSect=isOfNode(isDTDElemNodeCONDSECT)
+
+-- |
+-- test whether the root of a tree contains a parameter entity declaration.
+
+isParameterEntity::XmlFilter
+isParameterEntity=isOfNode(isDTDElemNodePENTITY)
+
+-- |
+-- test whether the root of a tree contains a NOTATION DTD part.
+
+isNotation::XmlFilter
+isNotation=isOfNode(isDTDElemNodeNOTATION)
+
+-- ATTLIST predicates
+
+isDefaultAttrKind::XmlFilter
+isDefaultAttrKind=isOf(a_kind`ofDTDequals`k_default)
+
+isEnumAttrType::XmlFilter
+isEnumAttrType=isOf(a_type`ofDTDequals`k_enumeration)
+
+isFixedAttrKind::XmlFilter
+isFixedAttrKind=isOf(a_kind`ofDTDequals`k_fixed)
+
+isIdAttrType::XmlFilter
+isIdAttrType=isOf(a_type`ofDTDequals`k_id)
+
+isIdRefAttrType::XmlFilter
+isIdRefAttrType=isOf((`elem`[k_idref,k_idrefs]).valueOfDTDa_type)
+
+isNotationAttrType::XmlFilter
+isNotationAttrType=isOf(a_type`ofDTDequals`k_notation)
+
+isRequiredAttrKind::XmlFilter
+isRequiredAttrKind=isOf(a_kind`ofDTDequals`k_required)
+
+isAttlistParameterEntity::XmlFilter
+isAttlistParameterEntity=isAttlist.>isOf(a_type`ofDTDequals`k_peref)
+
+-- ELEMENT predicates
+
+isEmptyElement::XmlFilter
+isEmptyElement=isOf(a_type`ofDTDequals`k_empty)
+
+isMixedContentElement::XmlFilter
+isMixedContentElement=isOf(a_type`ofDTDequals`v_mixed)
+
+isElemWithContent::XmlFilter
+isElemWithContent=isElement
+.>
+isOf((`elem`[v_mixed,v_children]).valueOfDTDa_type)
+
+isAttlistOfElement::String->XmlFilter
+isAttlistOfElementel=isAttlist
+.>
+isOf(a_name`ofDTDequals`el)
+
+isElemContentParamEntity::XmlFilter
+isElemContentParamEntity=isElement
+.>
+isOf(a_type`ofDTDequals`k_peref)
+
+-- ENTITY predicates
+
+isUnparsedEntity::XmlFilter
+isUnparsedEntity=isOf(hasEntryk_ndata.attrlOfDTD)
+
+isExternalParameterEntity::XmlFilter
+isExternalParameterEntity=isParameterEntity
+.>
+isOf(hasEntryk_system.attrlOfDTD)
+
+isInternalParameterEntity::XmlFilter
+isInternalParameterEntity=isParameterEntity
+.>isOf(not.hasEntryk_system.attrlOfDTD)
+
+-- -----------------------------------------------------------------------------
+
+-- |
+-- test whether the root of a tree contains an error node for a warning.
+
+isWarning::XmlFilter
+isWarning=isOfNode$isErrorNodec_warn
+
+-- |
+-- test whether the root of a tree contains an error node for an error.
+
+isError::XmlFilter
+isError=isOfNode$isErrorNodec_err
+
+-- |
+-- test whether the root of a tree contains an error node for a fatal error.
+
+isFatalError::XmlFilter
+isFatalError=isOfNode$isErrorNodec_fatal
+
+-- -----------------------------------------------------------------------------
+--
+-- constructor filter
+
+-- |
+-- constructor filter for a tag node.
+-- a new tree is constructed.
+-- the attributes and the children are computed by applying the aproprate filter to the input tree
+--
+-- * 1.parameter n : the tag name
+--
+-- - 2.parameter af : the filter for the attribute list
+--
+-- - 3.parameter cf : the filter for the children
+--
+-- - returns : the constructor filter
+
+mkXTag::String->XmlFilter->XmlFilter->XmlFilter
+mkXTagnafcf
+=\t->[mkXTagTreen(aft)(cft)]
+
+-- | Version with qualified names of 'mkXTag'
+
+mkQTag::QName->XmlFilter->XmlFilter->XmlFilter
+mkQTagqafcf
+=\t->[mkQTagTreeq(aft)(cft)]
+
+-- |
+-- constructor filter for a tag node.
+-- a new tree is constructed.
+-- the attributes and the children are computed by applying the aproprate filter to the input tree
+--
+-- * 1.parameter n : the tag name in form of prefix:localpart
+--
+-- - 2.parameter ns: the namespace uri
+--
+-- - 3.parameter af : the filter for the attribute list
+--
+-- - 4.parameter cf : the filter for the children
+--
+-- - returns : the constructor filter
+
+mkXNsTag::String->String->XmlFilter->XmlFilter->XmlFilter
+mkXNsTagnnsafcf
+=\t->[mkXNsTagTreenns(aft)(cft)]
+
+-- |
+-- filter for attribute construction.
+-- a new tree with attribute name and a value computed by a filter
+-- is build.
+
+mkXAttr::String->XmlFilter->XmlFilter
+mkXAttrnaf
+=\t->[mkXAttrTreen(aft)]
+
+-- | Qualified version 'mkXAttr'
+
+mkQAttr::QName->XmlFilter->XmlFilter
+mkQAttrqaf
+=\t->[mkQAttrTreeq(aft)]
+
+-- |
+-- filter for attribute construction.
+-- a new tree with attribute name and namespace and a value computed by a filter
+-- is build.
+
+mkXNsAttr::String->String->XmlFilter->XmlFilter
+mkXNsAttrnnsaf
+=\t->[mkXNsAttrTreenns(aft)]
+
+-- |
+-- constructor filter for a text node.
+-- a new tree is constructed.
+-- the input tree is ignored.
+
+mkXText::String->XmlFilter
+mkXText=mkNTree.mkXTextTree
+
+-- |
+-- constructor filter for a character reference node.
+-- a new tree is constructed.
+-- the input tree is ignored.
+
+mkXCharRef::Int->XmlFilter
+mkXCharRef=mkNTree.mkXCharRefTree
+
+-- |
+-- constructor filter for an entity reference node.
+-- a new tree is constructed.
+-- the input tree is ignored.
+
+mkXEntityRef::String->XmlFilter
+mkXEntityRef=mkNTree.mkXEntityRefTree
+
+-- |
+-- constructor filter for a comment node.
+-- a new tree is constructed.
+-- the xml string representation of the filter result
+-- forms the comment
+
+mkXCmt::XmlFilter->XmlFilter
+mkXCmtcf
+=\t->[mkXCmtTree((xshow.cf)t)]
+
+-- |
+-- constructor filter for a DTD part.
+-- a new tree is constructed.
+-- the input tree is ignored.
+
+mkXDTD::DTDElem->Attributes->XmlTrees->XmlFilter
+mkXDTDnal=mkNTree.mkXDTDTreenal
+
+-- |
+-- constructor filter for a CDATA section node.
+-- a new tree is constructed.
+-- the input tree is ignored.
+
+mkXCdata::XmlFilter->XmlFilter
+mkXCdatacf
+=\t->[mkXCdataTree((xshow.cf)t)]
+
+-- |
+-- constructor filter for a processing instruction
+-- a new tree is constructed from the text representation
+-- of the input tree
+
+mkXPi::String->XmlFilter->XmlFilter
+mkXPipiNamecf
+=\t->[mkXPiTreepiName((xshow.cf)t)]
+
+-- |
+-- constructor filter for an error message node.
+-- a new tree is constructed.
+-- the input tree is ignored.
+
+mkXError::Int->String->XmlFilter
+mkXErrorls=this.mkXErrorTreels.this
+
+-- -----------------------------------------------------------------------------
+--
+-- selector filters
+
+-- |
+-- filter for selecting the name of a tag node, an attribute node or a pi node.
+-- Result of the filter is a single element list with a text node or the empty list
+
+getName::XmlFilter
+getNamet
+|nulls=[]
+|otherwise=xtexts
+where
+s=nameOft
+
+-- |
+-- filter for selecting the attibute list
+
+getAttrl::XmlFilter
+getAttrl
+=selAttrl.getNode
+where
+selAttrl(XTag_al)=al
+selAttrl(XPi_al)=al
+selAttrl_=[]
+
+-- |
+-- filter for selecting the value of an attribute in a tag node.
+-- Result of the filter is a single element list with a text node or the empty list
+--
+-- see also : 'hasValue', 'getNsValue'
+
+getValue::String->XmlFilter
+getValuea=xmlTreesToText.(getAttrl.>isAttra.>getChildren)
+
+-- |
+-- filter for selecting the value of an attribute with namespace in a tag node.
+-- Result of the filter is a single element list with a text node or the empty list
+--
+-- see also : 'getValue', 'isNsAttr'
+
+getNsValue::String->String->XmlFilter
+getNsValuelpns=xmlTreesToText.(getAttrl.>isNsAttrlpns.>getChildren)
+
+-- |
+-- filter for selecting an attribute of a DTD node.
+-- Result of the filter is a single element list with a text node or the empty list
+
+getDTDValue::String->XmlFilter
+getDTDValuea=xtext.valueOfDTDa
+
+-- |
+-- filter for selecting content of a comment.
+-- Result of the filter is a single element list with a text node or the empty list
+
+getXCmt::XmlFilter
+getXCmt
+=selCmt.getNode
+where
+selCmt(XCmtc)=xtextc
+selCmt_=[]
+
+-- |
+-- filter for selecting the CDATA content.
+-- Result of the filter is a single element list with a text node or the empty list
+
+getXCdata::XmlFilter
+getXCdata
+=selData.getNode
+where
+selData(XCdatad)=xtextd
+selData_=[]
+
+-- -----------------------------------------------------------------------------
+--
+-- edit filter
+
+-- |
+-- edit filter for changing the name of a tag node, an attribute or a pi.
+-- result of the filter is a single element list with a tag node or the empty list
+
+replaceQName::String->XmlFilter
+replaceQNamen=modifyQName(const(mkNamen))
+
+-- |
+-- edit filter for changing the text of a text node.
+-- result of the filter is a single element list with a text node or the empty list
+--
+-- example for editing all text nodes of a tree with an edit function @f@:
+--
+-- @processBottomUp (modifyText f \`when\` isXText)@
+
+modifyText::(String->String)->XmlFilter
+modifyTextft@(NTreen_)
+|isXTextNoden=replaceNode(XText(f(textOfXNoden)))t
+modifyText__=[]
+
+-- |
+-- edit filter for changing the name of a tag node.
+-- result of the filter is a single element list with a text node or the empty list
+
+modifyQName::(TagName->TagName)->XmlFilter
+modifyQNamef(NTree(XTagnal)cs)=[NTree(XTag(fn)al)cs]
+modifyQNamef(NTree(XPinal)cs)=[NTree(XPi(fn)al)cs]
+modifyQNamef(NTree(XAttrn)cs)=[NTree(XAttr(fn))cs]
+modifyQName__=[]
+
+-- -----------------------------------------------------------------------------
+
+-- |
+-- process the attribute list of a tag node with a tree list filter.
+-- for other trees this filter acts like 'none'
+
+processAttrl::XmlSFilter->XmlFilter
+processAttrlft
+=replaceAttrl(fal)t
+where
+al=getAttrlt
+
+-- |
+-- elementwise processing of the attributes of a tag.
+-- for other trees this filter acts like 'none'
+--
+-- see also : 'processAttrl'
+processAttr::XmlFilter->XmlFilter
+processAttrf
+=processAttrl(f$$)
+
+-- |
+-- replace an attribute list
+-- to be renamed when replaceAttrl is eliminated
+
+replaceAttrl::XmlTrees->XmlFilter
+replaceAttrlal(NTree(XTagn_al)cs)=[NTree(XTagnal)cs]
+replaceAttrlal(NTree(XPin_al)cs)=[NTree(XPinal)cs]
+replaceAttrl__=[]
+
+-- |
+-- delete an attribute from the attribute list of a tag tree
+
+del1Attr::String->XmlFilter
+del1Attran=processAttr(none`when`isAttran)
+
+-- |
+-- add an attribute to the attribute list of a tag.
+-- If the attribute already exists, it\'s substituted,
+--
+-- see also: 'sattr', '+='
+
+add1Attr::XmlTree->XmlFilter
+add1Attra@(NTree(XAttran)_av)t
+=replaceAttrl(replaceal)t
+where
+al=getAttrlt
+replace[]=[a]
+replace(a1:as)
+|satisfies(isAttr(qualifiedNamean))a1
+=a:as
+|otherwise
+=a1:replaceas
+
+add1Attr_t
+=thist
+
+-- |
+-- adds an attribute list computed by a filter, uses 'add1Attr'.
+--
+-- see also: '+='
+
+addAttrl::XmlFilter->XmlFilter
+addAttrlattrFiltert
+=((foldl(.>)this.mapadd1Attr)al)t
+where
+al=attrFiltert
+
+-- |
+-- add or change an attribute with a given string as value for a XTag or XPi tree,
+-- uses 'add1Attr'.
+
+addAttr::String->String->XmlFilter
+addAttranav
+=add1Attr(mkXAttrTreean(ifnullavthen[]elsextextav))
+
+-- |
+-- add or change an attribute with an Int value.
+-- uses 'addAttr'.
+
+addAttrInt::String->Int->XmlFilter
+addAttrIntanav
+=addAttran(showav)
+
+-- |
+-- edit filter for changing the value of an attribute in a tag node.
+-- result of the filter is a single element list with the tag node or the empty list.
+--
+-- * 1.parameter n : the name of the attribute
+--
+-- - 2.parameter f : the edit function for the attribute value
+--
+-- - returns : the edit filter
+
+modifyAttr::String->(String->String)->XmlFilter
+modifyAttranf
+=processAttr(modifyValue`when`isAttran)
+where
+modifyValue=modifyChildren((modifyTextf$$).xmlTreesToText)
+
+-- |
+-- add or change an attribute of a DTD tree
+
+addDTDAttr::String->String->XmlFilter
+addDTDAttranav(NTree(XDTDeal)cs)
+=[NTree(XDTDe(addEntryanaval))cs]
+
+addDTDAttr___
+=[]
+
+
+-- -----------------------------------------------------------------------------
+--
+
+-- |
+-- convenient function for tag node tree construction
+--
+-- infixl 7
+--
+-- filter combinator for tag tree constrcution
+-- take a 1. filter for computing a tag node tree (or a whole list of tag node trees)
+-- then add all trees computed by the 2. filter to the attribute list when they represent attributes
+-- else append them to the list of children.
+--
+-- if the 1. filter computes a list of tag nodes, the results of the 2. filter are added to all trees
+--
+-- example: @ etag \"a\" += sattr \"href\" \"\#42\" += txt \"the answer\" @
+-- gives the tree @ \<a href=\"\#42\"\>the answer\<\/a\> @
+--
+-- example: @ ( etag \"a\" +++ etag \"b\" ) += sattr \"x\" \"42\" @
+-- gives the tree @ \<a x=\"42\"\/\>\<b x=\"42\"\/\> @
+--
+-- see also : 'etag', 'tag', 'add1Attr', 'modifyChildren', '++='
+
+(+=)::XmlFilter->XmlFilter->XmlFilter
+(+=)tfcft
+=concat
+[(isXTag`guards`(addaf.>addcf))$t'
+|t'<-tft
+]
+where
+(as,cs)=partition(satisfiesisXAttr).cf$t
+
+addaf|nullas=this
+|otherwise=addAttrl(constas)
+
+addcf|nullcs=this
+|otherwise=modifyChildren(++cs)
+
+-- |
+-- convenient filter function adding a whole list of trees, just for not writing to many ( ... ).
+--
+-- infixl 7
+--
+-- @ f ++= gl == f += cat gl @
+--
+-- see also : '+='
+
+(++=)::XmlFilter->[XmlFilter]->XmlFilter
+tf++=cfs
+=tf+=catcfs
+
+-- -----------------------------------------------------------------------------
+--
+-- string access functions
+
+-- |
+-- combination of 'getValue' and conversion into a String
+
+valueOf::String->XmlTree->String
+valueOfa=xshow.getValuea
+
+-- |
+-- combination of 'getValue' and conversion to a Int
+
+intValueOf::String->XmlTree->Int
+intValueOfa=decimalStringToInt.valueOfa
+
+-- -----------------------------------------------------------------------------
+--
+-- convenient filter (short cuts)
+
+-- |
+-- variant of mkXTag with a list of filters for the attributes and a list of filters for the children.
+-- this variant leads to a more readable source for a complicated construction filter
+-- than the simple solution with a combination of 'mkXTag' and 'cat'.
+--
+-- see also : 'mkXTag', 'stag', 'etag', 'cat', '+='
+
+tag::String->[XmlFilter]->[XmlFilter]->XmlFilter
+tagnafscfs=mkXTagn(catafs)(catcfs)
+
+-- |
+-- variant of tag, useful for tags without attributes and with a list of filters for
+-- constructing the children
+--
+-- see also : 'mkXTag', 'tag', 'etag', 'cat', '+='
+
+stag::String->[XmlFilter]->XmlFilter
+stagncfs=mkXTagnnone(catcfs)
+
+-- |
+-- variant of tag, useful for tags with attributes but without children
+--
+-- see also : 'mkXTag', 'tag', 'stag', 'etag', 'cat'
+
+atag::String->[XmlFilter]->XmlFilter
+atagncfs=mkXTagn(catcfs)none
+
+-- |
+-- Short cut for empty tags without attributes
+--
+-- see also : 'tag', 'atag', 'stag', 'mkXTag' and '+='
+
+etag::String->XmlFilter
+etagn=mkXTagnnonenone
+
+-- | Qualified version of etag
+
+qetag::QName->XmlFilter
+qetagq=mkQTagqnonenone
+
+-- | Alias for mkQTag
+
+qtag::QName->XmlFilter->XmlFilter->XmlFilter
+qtag=mkQTag
+
+
+-- |
+-- filter for creating a document root node with a list of filters for the attributes and a list of filters for the document.
+--
+-- see also : 'tag'
+
+rootTag::[XmlFilter]->[XmlFilter]->XmlFilter
+rootTagafscfs=mkXTagt_root(catafs)(catcfs)
+
+-- |
+-- Alias for 'mkXAttr'
+
+attr::String->XmlFilter->XmlFilter
+attr=mkXAttr
+
+-- | Alias for mkQAttr
+qattr::QName->XmlFilter->XmlFilter
+qattr=mkQAttr
+
+-- |
+-- short cut for attribute construction with string constants
+--
+-- set also : 'attr', 'mkXAttr' and 'mkXText'
+
+sattr::String->String->XmlFilter
+sattrav=mkXAttra(mkXTextv)
+
+-- |
+-- short cut for 'mkXText'
+
+txt::String->XmlFilter
+txt=mkXText
+
+-- |
+-- short cut for simple comment
+-- the input tree is ignored
+--
+-- see also : 'mkXCmt'
+
+cmt::String->XmlFilter
+cmtc=mkXCmt(txtc)
+
+-- |
+-- short cut for generating simple processing instructions (spi)
+-- the input tree is ignored
+--
+-- @spi \"xyz\" \"abc\"@ is equal to @mkXPi \"xyz\" (txt \"abc\")@
+-- (the name pi is already used in prelude)
+
+spi::String->String->XmlFilter
+spinc=mkXPin(txtc)
+
+-- |
+-- short cut for generating simple cdata sections,
+-- the input tree is ignored
+
+cdata::String->XmlFilter
+cdatas=mkXCdata(txts)
+
+-- |
+-- DTD part generation with filter for attributes and children
+-- see also: 'mkXDTDTree'
+
+dtd::DTDElem->[XmlFilter]->[XmlFilter]->XmlFilter
+dtddtdpartafscfst
+=mkXDTDdtdpart(toAttrl.catafs$t)(catcfst)$t
+
+-- |
+-- short cut for mkXError c_warn.
+--
+-- see also : 'mkXError'
+
+warn::String->XmlFilter
+warn=mkXErrorc_warn
+
+-- |
+-- short cut for mkXError c_fatal.
+--
+-- see also : 'mkXError'
+
+err::String->XmlFilter
+err=mkXErrorc_err
+
+-- |
+-- short cut for mkXError c_fatal.
+--
+-- see also : 'mkXError'
+
+fatal::String->XmlFilter
+fatal=mkXErrorc_fatal
+
+-- |
+-- check whether an option is set
+--
+-- reads the value of an attribute, usually applied to a document root node,
+-- and checks if the value represents True. The following strings are interpreted
+-- as true: \"1\", \"True\", \"true\", \"yes\", \"Yes\".
+
+hasOption::String->XmlFilter
+hasOptionopt
+=getValueopt.>isOfTextisSet
+where
+isSetx
+=x`elem`["1","True","true","yes","Yes"]
+
+
+-- -----------------------------------------------------------------------------
+
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.DOM.XmlTreeFunctions
+ Copyright : Copyright (C) 2008 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : stable
+ Portability: portable
+
+ Basic XmlTree functions
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.DOM.XmlTreeFunctions
+(moduleText.XML.HXT.DOM.XmlTreeFunctions
+,moduleText.XML.HXT.DOM.ShowXml
+)
+where
+
+importText.XML.HXT.DOM.XmlTreeTypes
+importText.XML.HXT.DOM.XmlKeywords
+importText.XML.HXT.DOM.ShowXml
+
+importData.Maybe
+
+-- -----------------------------------------------------------------------------
+--
+-- XNode Predicates
+--
+
+isXCdataNode::XNode->Bool
+isXCdataNode(XCdata_)=True
+isXCdataNode_=False
+
+isXCharRefNode::XNode->Bool
+isXCharRefNode(XCharRef_)=True
+isXCharRefNode_=False
+
+isXCmtNode::XNode->Bool
+isXCmtNode(XCmt_)=True
+isXCmtNode_=False
+
+isXDTDNode::XNode->Bool
+isXDTDNode(XDTD__)=True
+isXDTDNode_=False
+
+isXAttrNode::XNode->Bool
+isXAttrNode(XAttr_)=True
+isXAttrNode_=False
+
+isXEntityRefNode::XNode->Bool
+isXEntityRefNode(XEntityRef_)=True
+isXEntityRefNode_=False
+
+isXErrorNode::XNode->Bool
+isXErrorNode(XError__)=True
+isXErrorNode_=False
+
+isXPiNode::XNode->Bool
+isXPiNode(XPi__)=True
+isXPiNode_=False
+
+isXTagNode::XNode->Bool
+isXTagNode(XTag__)=True
+isXTagNode_=False
+
+isXTextNode::XNode->Bool
+isXTextNode(XText_)=True
+isXTextNode_=False
+
+-- -----------------------------------------------------------------------------
+
+isRootNode::XNode->Bool
+isRootNode=isTagNodet_root
+
+isTagNode::String->XNode->Bool
+isTagNoden=isOfTagNode((==n).qualifiedName)
+
+isOfTagNode::(TagName->Bool)->XNode->Bool
+isOfTagNodep(XTagn_)=pn
+isOfTagNode__=False
+
+isAttrNode::String->XNode->Bool
+isAttrNoden=isOfAttrNode((==n).qualifiedName)
+
+isOfAttrNode::(AttrName->Bool)->XNode->Bool
+isOfAttrNodep(XAttrn)=pn
+isOfAttrNode__=False
+
+isTextNode::String->XNode->Bool
+isTextNodet=isOfTextNode(==t)
+
+isOfTextNode::(String->Bool)->XNode->Bool
+isOfTextNodep(XTextt)=pt
+isOfTextNode__=False
+
+isPiNode::String->XNode->Bool
+isPiNoden=isOfPiNode((==n).qualifiedName)
+
+isOfPiNode::(TagName->Bool)->XNode->Bool
+isOfPiNodep(XPin_)=pn
+isOfPiNode__=False
+
+isDTDElemNode::DTDElem->XNode->Bool
+isDTDElemNodee(XDTDn_)=n==e
+isDTDElemNode__=False
+
+isErrorNode::Int->XNode->Bool
+isErrorNodel(XErrorl'_)=l==l'
+isErrorNode__=False
+
+-- -----------------------------------------------------------------------------
+
+textOfXNode::XNode->String
+textOfXNode(XTextt)=t
+textOfXNode_=""
+
+-- -----------------------------------------------------------------------------
+--
+-- XmlTree constructors
+
+-- |
+-- Create a tree with a tag node.
+--
+-- * 1.parameter n : the name of the tag
+--
+-- - 2.parameter al : the tag attribte list
+--
+-- - 3.parameter cs : the list of children
+--
+-- - returns : the new tree
+
+mkXTagTree::String->XmlTrees->XmlTrees->XmlTree
+mkXTagTreenalcs=mkNode(XTag(mkNamen)al)cs
+
+-- | Version with qualified name of 'mkXTagTree'
+
+mkQTagTree::QName->XmlTrees->XmlTrees->XmlTree
+mkQTagTreeqalcs=mkNode(XTagqal)cs
+
+-- |
+-- create a tree with a namespace aware tag node.
+--
+-- * 1.parameter n : the prefix:localpart of the tag
+--
+-- - 2.parameter ns: the namespace uri
+--
+-- - 3.parameter al : the tag attribte list
+--
+-- - 4.parameter cs : the list of children
+--
+-- - returns : the new tree
+--
+-- see also: 'mkXTagTree'
+
+mkXNsTagTree::String->String->XmlTrees->XmlTrees->XmlTree
+mkXNsTagTreennsalcs=mkNode(XTag(mkNsNamenns)al)cs
+
+-- |
+-- creates a new document tree with empty contents.
+--
+-- * 1.parameter al : the attribute list for the root node
+--
+-- returns a single node tree with tag name \"\/\" indicating a root and
+-- with empty list of children
+--
+-- see also : 'emptyRoot'
+
+newRoot::XmlTrees->XmlTree
+newRootal=mkXTagTreet_rootal[]
+
+-- | the empty document tree
+--
+-- see also : 'newRoot'
+
+emptyRoot::XmlTree
+emptyRoot=newRoot[]
+
+-- |
+-- create a new empty document with source name as parameter
+
+newDocument::String->XmlTree
+newDocumentn
+=newDocument'[(a_source,n),(a_status,showc_ok)]
+
+-- |
+-- create a new empty document with a list of attributes for source location and options
+--
+-- see also : 'newDocument'
+
+newDocument'::Attributes->XmlTree
+newDocument'al
+=newRoot(fromAttrlal)
+
+-- |
+-- create a document root tree.
+--
+-- * 1.parameter al : the attribute list for the root. This list must contain at
+-- least an attribute \"source\" that contains the URI of the document to be processed
+--
+-- - 2.parameter cs : the list for the document content
+--
+-- - returns : the document root
+
+mkRootTree::XmlTrees->XmlTrees->XmlTree
+mkRootTreealcs=mkXTagTreet_rootalcs
+
+-- |
+-- create a leaf for a text element.
+--
+-- * 1.parameter txt : the text
+--
+-- - returns : the tree with the single node containing the text
+
+mkXTextTree::String->XmlTree
+mkXTextTrees=mkLeaf(XTexts)
+
+-- |
+-- create a leaf for a char reference.
+--
+-- * 1.parameter i : the integer representing the Unicode char
+--
+-- - returns : the tree with the single node containing the char reference
+
+mkXCharRefTree::Int->XmlTree
+mkXCharRefTrees=mkLeaf(XCharRefs)
+
+-- |
+-- create a leaf for an entity reference.
+--
+-- * 1.parameter n : the name of the entity reference
+--
+-- - returns : the tree with the single node containing the entity reference
+
+mkXEntityRefTree::String->XmlTree
+mkXEntityRefTrees=mkLeaf(XEntityRefs)
+
+-- |
+-- create a leaf for a comment,
+--
+-- * 1.parameter c : the comment text
+--
+-- - returns : the tree with the single node containing the comment
+
+mkXCmtTree::String->XmlTree
+mkXCmtTreec=mkLeaf(XCmtc)
+
+-- |
+-- create a tree for a part of a DTD
+--
+-- * 1.parameter d : the type of the DTD part
+--
+-- - 2.parameter al : the attribute list for the DTD part
+--
+-- - 3.parameter ds : the possibly empty list of components for the DTD part
+--
+-- - returns : the tree with the composed DTD part
+
+mkXDTDTree::DTDElem->Attributes->XmlTrees->XmlTree
+mkXDTDTreedalds=mkNode(XDTDdal)ds
+
+
+-- |
+-- create an attribute tree as part of a tag attribute list of tag nodes
+--
+-- * 1.parameter al : the attribute name
+--
+-- - 2.parameter av : the attribute value as tree list, usually containing a single text node
+
+mkXAttrTree::String->XmlTrees->XmlTree
+mkXAttrTreeanav=mkNode(XAttr(mkNamean))av
+
+-- | Qualified version of 'mkXAttrTree'
+
+mkQAttrTree::QName->XmlTrees->XmlTree
+mkQAttrTreeaqav=mkNode(XAttraq)av
+
+
+-- |
+-- create an attribute tree with a namespace
+--
+-- * 1.parameter al : the attribute name
+--
+-- - 2.parameter ns : namespace uri
+--
+-- - 3.parameter av : the attribute value as tree list, usually containing a single text node
+--
+-- see also: 'mkXAttrTree', 'mkXNsTagTree'
+
+mkXNsAttrTree::String->String->XmlTrees->XmlTree
+mkXNsAttrTreeannsav=mkNode(XAttr(mkNsNameanns))av
+
+-- |
+-- create a parameter entity reference DTD part.
+--
+-- * 1.parameter ref : the name of the reference
+--
+-- - returns : the DTD part for a PERef
+
+mkXPERefTree::String->XmlTree
+mkXPERefTreeref=mkLeaf(XDTDPEREF[(a_peref,ref)])
+
+-- |
+-- create a processing instruction tree.
+--
+-- * 1.parameter n : the name of the PI
+--
+-- - 2.parameter str : the content of a PI
+--
+-- - returns : the processing instruction tree with a single attribute \"value\"
+-- with the str parameter as attribute value, with @valueOf a_value@ applied to the result tree
+-- the content of the PI can be selected
+
+mkXPiTree::String->String->XmlTree
+mkXPiTreenstr=mkLeaf(XPi(mkNamen)(xattra_valuestr))
+
+-- |
+-- create xml declaration
+
+mkXmlDeclTree::XmlTrees->XmlTree
+mkXmlDeclTreeal=mkLeaf(XPi(mkNamet_xml)al)
+
+-- |
+-- create a CDATA section tree.
+--
+-- * 1.parameter s : the content of the CDATA section
+--
+-- - returns : the tree for the CDATA section
+
+mkXCdataTree::String->XmlTree
+mkXCdataTrees=mkLeaf(XCdatas)
+
+-- |
+-- create an error tree.
+--
+-- * 1.parameter l : the level of the error (warning, error fatal)
+--
+-- - 2.parameter msg : the error message
+--
+-- - 3.parameter cs : the context, where the error was detected
+
+mkXErrorTree::Int->String->XmlTrees->XmlTree
+mkXErrorTreelscs=mkNode(XErrorls)cs
+
+maybeString2XText::MaybeString->XmlTrees
+maybeString2XText=mapmkXTextTree.maybeToList
+
+-- ------------------------------------------------------------
+--
+-- text selection
+
+showXText::XmlTrees->String
+showXText
+=concatMapshowT
+where
+showT(NTree(XTextt)_)=t
+showT_=""
+
+showXCharRef::XmlTrees->String
+showXCharRef
+=concatMapshowT
+where
+showT(NTree(XCharRefr)_)="&#"++showr++";"
+showT_=""
+
+showXEntityRef::XmlTrees->String
+showXEntityRef
+=concatMapshowT
+where
+showT(NTree(XEntityRefr)_)="&"++r++";"
+showT_=""
+
+showXErrors::XmlTrees->String
+showXErrors
+=concatMapshowE
+where
+showE(NTree(XErrorlevelstr)_)=msglevel++": "++str++"\n"
+showE_=""
+
+msg::Int->String
+msgl
+|l==c_warn="Warning"
+|l==c_err="Error"
+|otherwise="Fatal error"
+
+-- ------------------------------------------------------------
+--
+-- the toString conversion functions
+
+-- |
+-- old name for 'xshow' (deprecated)
+
+xmlTreesToString::XmlTrees->String
+xmlTreesToString=xshow
+
+-- |
+-- conversion of a filter result into a text node
+--
+-- see also : 'xshow'
+
+xmlTreesToText::XmlSFilter
+xmlTreesToTextts@[(NTree(XText_)_)]=ts-- special case optimisation
+xmlTreesToTextts@[]=ts
+xmlTreesToTextts=xtext.xshow$ts
+
+-- ------------------------------------------------------------
+
+xmlContentModelToString::XmlTree->String
+xmlContentModelToString(NTree(XDTDELEMENTal)cs)
+=showElemType(lookup1a_typeal)cs""
+
+xmlContentModelToString_
+=""
+
+-- -----------------------------------------------------------------------------
+--
+-- string access functions
+
+-- |
+-- select the name of a node. For tags, attributes and pi\'s the name string
+-- is returned, else the empty string.
+
+nameOf::XmlTree->String
+nameOf
+=selName.getNode
+where
+selName(XTagn_)=qualifiedNamen
+selName(XAttrn)=qualifiedNamen
+selName(XPin_)=qualifiedNamen
+selName_=""
+
+-- |
+-- select the local part of a name of a node. For tags, attributes the name string
+-- is returned, for pi's the whole name, else the empty string.
+
+localPartOf::XmlTree->String
+localPartOf
+=selName.getNode
+where
+selName(XTagn_)=localPartn
+selName(XAttrn)=localPartn
+selName(XPin_)=qualifiedNamen
+selName_=""
+
+-- |
+-- select the namespace URI of a tag or an attribute tree, else the empty string is returned
+-- see also : 'nameOf'
+
+namespaceOf::XmlTree->String
+namespaceOf
+=selName.getNode
+where
+selName(XTagn_)=namespaceUrin
+selName(XAttrn)=namespaceUrin
+selName_=""
+
+-- |
+-- select the namespace prefix of a tag or an attribute tree, else the empty string is returned
+-- see also : 'nameOf', 'localPartOf'
+
+prefixOf::XmlTree->String
+prefixOf
+=selName.getNode
+where
+selName(XTagn_)=namePrefixn
+selName(XAttrn)=namePrefixn
+selName_=""
+
+-- |
+-- select the universal name (namespace uri ++ localPart) of a tag or an attribute tree, else the empty string is returned
+-- see also : 'nameOf', 'namespaceOf'
+
+universalNameOf::XmlTree->String
+universalNameOf
+=selName.getNode
+where
+selName(XTagn_)=universalNamen
+selName(XAttrn)=universalNamen
+selName_=""
+
+-- |
+-- select the attributes of a dtd tree
+
+attrlOfDTD::XmlTree->Attributes
+attrlOfDTD(NTree(XDTD_al)_)=al
+attrlOfDTD_=[]
+
+
+-- |
+-- select a special attribute of a DTD part
+
+valueOfDTD::String->XmlTree->String
+valueOfDTDn=lookup1n.attrlOfDTD
+
+-- |
+-- test an attribute of a DTD part
+
+ofDTDequals::String->String->XmlTree->Bool
+ofDTDequalsnv=(==v).valueOfDTDn
+
+-- -----------------------------------------------------------------------------
+--
+-- convenient functions
+
+xcmt::String->XmlTrees
+xcmtcmt=[mkXCmtTreecmt]
+
+xerr::String->XmlTrees
+xerrmsg=[mkXErrorTreec_errmsg[]]
+
+xwarn::String->XmlTrees
+xwarnmsg=[mkXErrorTreec_warnmsg[]]
+
+xtext::String->XmlTrees
+xtextt=[mkXTextTreet]
+
+xtag::String->XmlTrees->XmlTrees->XmlTrees
+xtagtalcl=[mkXTagTreetalcl]
+
+xattr::String->String->XmlTrees
+xattrnv=[mkXAttrTreen(xtextv)]
+
+-- -----------------------------------------------------------------------------
+--
+-- conversion functions: XmlTrees <-> Attributes
+
+toTreel::XmlTrees->AssocListStringXmlTrees
+toTreel
+=concatMaptoTree
+where
+toTree(NTree(XAttrn)cs)=[(qualifiedNamen,cs)]
+toTree_=[]
+
+toAttrl::XmlTrees->Attributes
+toAttrl
+=map(\(k,tl)->(k,xshowtl)).toTreel
+
+
+fromTreel::AssocListStringXmlTrees->XmlTrees
+fromTreel
+=map(\(k,tl)->mkXAttrTreektl)
+
+fromAttrl::Attributes->XmlTrees
+fromAttrl
+=fromTreel.map(\(k,v)->(k,xtextv))
+
+-- -----------------------------------------------------------------------------
+
-- ------------------------------------------------------------
+--
+-- defaut uri computation
+-- this routine is platform dependent
+-- and must be exchanged when porting the toolbox e.g. to windows
+
+moduleText.XML.HXT.Parser.DefaultURI
+(setDefaultURI
+)
+
+where
+
+importText.XML.HXT.DOM.XmlTree
+
+importText.XML.HXT.DOM.XmlState
+
+importSystem.Directory
+(getCurrentDirectory
+)
+
+importNetwork.URI
+(escapeURIChar
+,isUnescapedInURI
+)
+
+setDefaultURI::XStatestate()
+setDefaultURI
+=do
+wd<-iogetCurrentDirectory
+setSysParamtransferDefaultURI("file://"++normalizewd++"/")
+
+where
+
+-- under Windows getCurrentDirectory returns something like: "c:\path\to\file"
+-- backslaches are not allowed in URIs and paths must start with a /
+-- so this is transformed into "/c:/path/to/file"
+
+normalizewd'@(d:':':_)
+|d`elem`['A'..'Z']||d`elem`['a'..'z']
+='/':concatMapwin32ToUriCharwd'
+normalizewd'
+=concatMapescapeNonUriCharwd'
+
+win32ToUriChar'\\'="/"
+win32ToUriCharc=escapeNonUriCharc
+
+escapeNonUriCharc=escapeURICharisUnescapedInURIc-- from Network.URI
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.Parser.HtmlParser
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : stable
+ Portability: portable
+
+ This parser tries to interprete everything as HTML
+ no errors are emitted during parsing. If something looks
+ weired, warning messages are inserted in the document tree.
+
+ Module contains state filter for easy parsing and error handling
+ real work is done in 'Text.XML.HXT.Parser.HtmlParsec'
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.Parser.HtmlParser
+(getHtmlDoc
+,parseHtmlDoc
+,runHtmlParser
+,substHtmlEntities
+,moduleText.XML.HXT.Parser.HtmlParsec
+)
+
+where
+
+importText.XML.HXT.DOM.XmlTree
+importText.XML.HXT.DOM.XmlState
+importText.XML.HXT.Parser.HtmlParsec
+
+importText.XML.HXT.Parser.XmlInput
+(getXmlContents
+)
+
+importText.XML.HXT.Parser.XmlOutput
+(traceTree
+,traceSource
+,traceMsg
+)
+
+importText.XML.HXT.Parser.XhtmlEntities
+(xhtmlEntities
+)
+
+-- ------------------------------------------------------------
+
+-- |
+-- read a document and parse it with 'parseHtmlDoc'. The main entry point of this module
+--
+-- The input tree must be a root tree like in ' Text.XML.HXT.Parser.MainFunctions.getXmlDoc'. The content is read with 'Text.XML.HXT.Parser.XmlInput.getXmlContents',
+-- is parsed with 'parseHtmlDoc' and canonicalized (char refs are substituted in content and attributes,
+-- but comment is preserved)
+--
+-- see also : 'Text.XML.HXT.Parser.DTDProcessing.getWellformedDoc'
+
+getHtmlDoc::XmlStateFilterstate
+getHtmlDoc
+=setSystemParams
+.>>
+getXmlContents
+.>>
+parseHtmlDoc
+
+-- | The HTML parsing filter
+--
+-- The input is parsed with 'runHtmlParser', everything is interpreted as HTML,
+-- if errors ocuur, the parser will try to do some meaningfull action and continues
+-- parsing. Afterwards the entitiy references for defined for XHTML are resovled,
+-- any unresolved reference is transformed into plain text.
+--
+-- Error messages
+-- during parsing and entity resolving are added as warning nodes into the resulting tree.
+--
+-- The warnings are issued, if the 1. parameter noWarnings is set to True,
+-- afterwards all are removed from the resulting tree.
+
+parseHtmlDoc::XmlStateFiltera
+parseHtmlDoc
+=parseDoc
+`whenM`(isRoot.>getChildren.>isXText)
+where
+parseDoct'
+=(traceMsg2("parseHtmlDoc: parse HTML document "++showloc)
+.>>
+runHtmlParser
+.>>
+liftMf(processTopDownsubstHtmlEntities)
+.>>
+removeWarnings
+.>>
+traceTree
+.>>
+traceSource
+)$t'
+where
+loc=valueOfa_sourcet'-- get document source uri
+
+removeWarnings::XmlStateFiltera
+removeWarningst'
+=let
+noWarnings=not(satisfies(hasOptiona_issue_warnings)t')
+selWarnings=deep
+(choice[isWarning:->this
+,isXTag:->(getAttrl.>selWarnings)
+]
+)
+remWarnings=processTopDown
+(choice[isWarning:->none
+,isXTag:->(processAttrl(remWarnings$$))
+,this:->this
+]
+)
+warnings=selWarningst'
+indo
+ifnullwarnings
+thenthisMt'
+elsedo
+ifnoWarnings
+thenreturn[]
+elsedo
+issueError$$<warnings
+return(remWarningst')
+
+-- | The pure HTML parser, usually called via 'parseHtmlDoc'.
+--
+
+runHtmlParser::XmlStateFiltera
+runHtmlParsert
+=ifnullerrs
+thendo
+return(replaceChildrenrest)
+elsedo
+issueError$$<errs
+return(setStatusc_err"parsing HTML"t)
+where
+res=getChildren.>parseHtmlTextloc$t
+errs=isXError.>negisWarning$$res
+loc=valueOfa_sourcet
+
+
+-- ------------------------------------------------------------
+--
+-- XHTML entities
+
+substHtmlEntities::XmlTree->XmlTrees
+substHtmlEntities
+=choice[isXEntityRef:->substEntity
+,isXTag:->processAttr(processChildrensubstHtmlEntities)
+,this:->this
+]
+where
+substEntityt'@(NTree(XEntityRefen)_)
+=case(lookupenxhtmlEntities)of
+Justi
+->[mkXCharRefTreei]
+Nothing
+->xwarn("no XHTML entity found for reference: \"&"++en++";\"")
+++
+(xmlTreesToText[t'])
+
+substEntity_
+=error"substHtmlEntities: illegal argument"
+
+-- ------------------------------------------------------------
+
-- |
+-- Simple parse functions.
+--
+-- the main building blocks for an application.
+-- this module exports complex filters and functions for
+-- common tasks for input and parsing, output and option handling.
+--
+
+moduleText.XML.HXT.Parser.MainFunctions
+(getXmlDocument
+,putXmlDocument
+
+,parseDocument
+,writeDocument
+)
+where
+
+importText.XML.HXT.DOM.XmlTree
+importText.XML.HXT.DOM.XmlState
+importText.XML.HXT.Parser.HtmlParser
+importText.XML.HXT.Parser.XmlInput
+importText.XML.HXT.Parser.XmlOutput
+importText.XML.HXT.Parser.DTDProcessing
+importText.XML.HXT.Validator.Validation
+importText.XML.HXT.DOM.EditFilters
+importText.XML.HXT.DOM.Namespace
+
+importSystem.IO
+
+-- ------------------------------------------------------------
+
+-- |
+-- convenient function for reading a XML document without
+-- dealing with state monads, error messages collection and other details
+--
+-- getXmlDocument calls 'parseDocument' with the list of parsing options
+-- and an url or filename as document source.
+--
+-- result is a triple
+--
+-- * the resulting document tree with a root node containing all
+-- meta info about the document (options, status info, http header, ...)
+--
+-- - the list of errors and warnings
+--
+-- - the error level: one of 'c_ok', 'c_warn', 'c_err', 'c_fatal'
+--
+-- example for input (see also example in 'putXmlDocument' and example in 'writeDocument')
+--
+-- > main :: IO ()
+-- > main
+-- > = do
+-- > (res, errs, rc) <- getXmlDocument [] "test.xml"
+-- > if rc >= c_err
+-- > then issueErrors errs
+-- > else processTree res
+-- >
+-- > issueErrors :: XmlTrees -> IO ()
+-- >
+-- > processTree :: XmlTree -> IO ()
+--
+-- for options see 'parseDocument', 'a_collect_errors' is set implicitly
+
+getXmlDocument::Attributes->String->IO(XmlTree,XmlTrees,Int)
+getXmlDocumentoptionsurl
+=do
+letoptions'=[(a_collect_errors,v_1)-- collect errors
+,(a_issue_errors,v_0)-- but don't issue
+]-- can be overwritten by supporting other values in options
+++
+options
+++
+[(a_source,url)-- set the source url
+]
+res<-run'$parseDocumentoptions'emptyRoot
+letroot=headres
+leterrs=tailres
+letelvl=intValueOfa_statusroot
+return(root,errs,elvl)
+
+
+-- |
+-- the inverse operation to 'getXmlDocument'
+--
+-- writes a complete document tree to a file, writing can be
+-- controlled by options, the real work is done with filter 'writeDocument'.
+-- useful options are the options of 'writeDocument'.
+--
+-- result is a pair: 1.part is a list of error messages, 2. part is the return code,
+-- the status info of the write filter
+--
+-- this filter is useful, when processing XML in an arbitray context in the IO monad
+--
+-- an example main program for such an application is:
+--
+-- > main :: IO ()
+-- > main
+-- > = do
+-- > (input, readErrs, rc) <- getXmlDocument [...] "test.xml"
+-- > if rc >= c_err
+-- > then issueErrors readErrs
+-- > else processTree input
+-- >
+-- > processTree :: XmlTree -> IO ()
+-- > processTree t
+-- > = let res = computeNewTree input
+-- > in do
+-- > (writeErrs, rc2) <- putXmlDocument [...] "out.xml" res
+-- > if rc2 >= c_err
+-- > then issueErrors writeErrs
+-- > else return ()
+-- >
+-- > issueErrors :: XmlTrees -> IO ()
+-- >
+-- > computeNewTree :: XmlTree -> XmlTree
+
+
+putXmlDocument::Attributes->String->XmlTree->IO(XmlTrees,Int)
+putXmlDocumentoptionsfileNamet
+=do
+letoptions'=[(a_collect_errors,v_1)-- collect errors
+,(a_issue_errors,v_0)-- but don't issue
+]-- can be overwritten by supporting other values in options
+++
+options
+++
+[(a_output_file,fileName)-- set the source url
+]
+res<-run'$writeDocumentoptions't
+letroot=headres
+leterrs=tailres
+letelvl=intValueOfa_statusroot
+return(errs,elvl)
+
+-- ------------------------------------------------------------
+
+-- |
+-- the main parsing filter
+--
+-- this filter can be configured by an option list, a list of
+-- option name, option value pairs.
+-- the input tree must be a possibly empty document root tree.
+-- all the options are stored as attributes in this root node to control processing.
+--
+-- available options:
+--
+-- * 'a_parse_html': use HTML parser, else use XML parser (default)
+--
+-- - 'a_validate' : validate document (default), else skip validation
+--
+-- - 'a_check_namespaces' : check namespaces, else skip namespace processing (default)
+--
+-- - 'a_canonicalize' : canonicalize document (default), else skip canonicalization
+--
+-- - 'a_preserve_comment' : preserve comments during canonicalization, else remove comments (default)
+--
+-- - 'a_remove_whitespace' : remove all whitespace, used for document indentation, else skip this step (default)
+--
+-- - 'a_indent' : indent document by inserting whitespace, else skip this step (default)
+--
+-- - 'a_issue_warnings' : issue warnings, when parsing HTML (default), else ignore HTML parser warnings
+--
+-- - 'a_issue_errors' : issue all error messages on stderr (default), or ignore all error messages
+--
+-- - 'a_collect_errors' : all error messages are collected during processing and appended to the result document
+-- for further processing within the calling modules
+--
+-- - 'a_trace' : trace level: values: 0 -4
+--
+-- - 'a_proxy' : proxy for http access, e.g. www-cache:3128
+--
+-- - 'a_use_curl' : for http access via external programm curl, default is native HTTP access
+--
+-- - 'a_options_curl' : more options for external program curl
+--
+-- - 'a_source' : the document source url
+--
+-- - 'a_encoding' : default document encoding ('utf8', 'isoLatin1', 'usAscii', ...)
+--
+-- examples:
+--
+-- > parseDocument [ (a_source, "test.xml")
+-- > , (a_validate, "0")
+-- > , (a_encoding, isoLatin1)
+-- > ] emptyRoot
+--
+-- reads document \"test.xml\" without validation and default encoding 'isoLatin1'
+--
+-- > parseDocument [ (a_source, "http://www.haskell.org/")
+-- > , (a_parse_html, "1")
+-- > , (a_proxy, "www-cache:3128")
+-- > , (a_curl, "1")
+-- > , (a_issue_warnings, "0")
+-- > ] emptyRoot
+--
+-- reads Haskell homepage with HTML parser ignoring any warnings and with http access via external program curl and proxy \"www-cache\" at port 3128
+--
+-- > parseDocument [ (a_source, "http://www.w3c.org/")
+-- > , (a_parse_html, "0") -- default
+-- > , (a_validate, "1") -- default
+-- > , (a_check_namespace, "1")
+-- > , (a_remove_whitespace, "1")
+-- > , (a_trace, "2")
+-- > ] emptyRoot
+--
+-- read w3c home page, validate and chech namespaces, remove whitespace between tags, trace activities with level 2
+--
+-- > parseDocument [ (a_source, "test.xml")
+-- > , (a_validate, "1")
+-- > , (a_check_namespace, "1")
+-- > , (a_collect_errors, "1")
+-- > , (a_issue_errors, "0")
+-- > ] emptyRoot
+--
+-- reads file \"test.xml\", validates it, checks namespaces, does not issue any erros
+-- but collects errors and appends the list of errors to the single element list for the document.
+-- this enables the calling application to define own error handlers.
+
+parseDocument::Attributes->XmlStateFilterstate
+parseDocumentuserOptions
+=processDocumentuserOptionsdefaultOptions
+(traceMsg1"parseDocument: options added, start processing"
+.>>
+traceTree
+.>>
+getXmlContents-- get the content as text
+.>>
+choiceM-- select parser
+[hasOptiona_parse_html
+:->parseHtmlDoc-- parse everything as HTML
+,this
+:->checkWellformedDoc-- parse XML and process entities
+.>>
+(getValidatedDoc-- validate
+`whenM`
+hasOptiona_validate
+)
+]
+.>>
+(propagateAndValidateNamespaces-- namespace processing
+`whenM`
+hasOptiona_check_namespaces
+)
+.>>
+liftMf-- canonicalization
+(choice
+[hasOptiona_preserve_comment-- don't remove comments (in XPath required)
+:->canonicalizeForXPath
+,this
+:->canonicalizeAllNodes-- do normal canonicaliazion
+]
+`when`
+hasOptiona_canonicalize-- caconicalization can be switched off
+)
+.>>
+liftMf
+(removeDocWhiteSpace-- remove all whitespace between tags
+`when`
+hasOptiona_remove_whitespace
+)
+.>>
+traceMsg1"parseDocument: document processed"-- trace output
+.>>
+traceSource
+.>>
+traceTree
+)
+where
+defaultOptions
+=[(a_parse_html,v_0)
+,(a_validate,v_1)
+,(a_issue_errors,v_1)
+,(a_issue_warnings,v_1)
+,(a_check_namespaces,v_0)
+,(a_canonicalize,v_1)
+,(a_preserve_comment,v_0)
+,(a_remove_whitespace,v_0)
+]
+
+-- ------------------------------------------------------------
+
+addOptions::Attributes->XmlFilter
+addOptions
+=seqF.map(\(n,v)->addAttrnv)
+
+addDefaultOptions::Attributes->XmlFilter
+addDefaultOptions
+=seqF.map(\(n,v)->addAttrnv`whenNot`hasAttrn)
+
+-- ------------------------------------------------------------
+
+-- |
+-- the main filter for writing documents
+--
+-- this filter can be configured by an option list like 'getXmlDocument'
+--
+-- available options are
+--
+-- * 'a_indent' : indent document for readability, (default: no indentation)
+--
+-- - 'a_remove_whitespace' : remove all redundant whitespace for shorten text (default: no removal)
+--
+-- - 'a_output_file' : destination file for document, default is \"-\" for stdout
+--
+-- - 'a_output_encoding' : encoding of document, default is 'a_encoding' or 'utf8'
+--
+-- - 'a_output_xml' : (default) issue XML: quote special XML chars \>,\<,\",\',&
+-- add XML processing instruction
+-- and encode document with respect to 'a_output_encoding',
+-- if explizitly switched of, the plain text is issued, this is useful
+-- for non XML output, e.g. generated Haskell code, LaTex, Java, ...
+--
+-- - 'a_show_tree' : show tree representation of document (for debugging)
+--
+-- - 'a_show_haskell' : show Haskell representaion of document (for debugging)
+--
+-- - 'a_issue_errors', 'a_collect_errors' : see 'parseDocument'
+--
+-- a typical main program running in the XmlState monad
+-- has the following structure:
+--
+-- >
+-- > main :: IO ()
+-- > main
+-- > = do
+-- > argv <- getArgs -- get the commandline arguments
+-- > (inp, outp, options) <- cmdlineOpts argv -- and evaluate them, return a key-value list
+-- > -- and input and output
+-- > res <- run' $ application inp outp options $ emptyRoot -- run the application
+-- >
+-- > exitWith (if null res
+-- > then ExitFailure (-1)
+-- > else exitSuccess
+-- > )
+-- >
+-- > application :: String -> String -> Attributes -> XmlStateFilter ()
+-- > application inp outp al
+-- > = parseDocument (al ++ [(a_source, inp)]) -- set options and source
+-- > .>> -- and parse document
+-- > processDocument -- the hard work
+-- > .>>
+-- > writeDocument [(a_output_file, outp)] -- issue results
+-- > .>>
+-- > checkStatus -- check errors
+-- >
+
+
+writeDocument::Attributes->XmlStateFilterstate
+writeDocumentuserOptions
+=processDocumentuserOptionsdefaultOptions
+(traceMsg1"writeDocument: options added, start processing"
+.>>
+liftMf
+(choice
+[hasOptiona_indent:->indentDoc-- document indentation
+,hasOptiona_remove_whitespace:->removeDocWhiteSpace-- remove all whitespace between tags
+,this:->this
+]
+)
+.>>
+liftMf
+(choice
+[hasOptiona_show_tree:->treeRepOfXmlDoc
+,hasOptiona_show_haskell:->haskellRepOfXmlDoc
+,hasOptiona_output_xml:->(escapeXmlDoc-- escape lt, gt, amp, quot,
+.>
+addXmlPiToDoc-- add <?xml ... > pi
+.>
+unparseXmlDoc-- convert doc into text with respect to output encoding
+)
+,this:->this
+]
+)
+.>>
+writeXmlDoc
+.>>
+traceMsg1"writeDocument: finished"
+)
+where
+defaultOptions
+=[(a_output_file,"-")
+,(a_indent,v_0)
+,(a_remove_whitespace,v_0)
+,(a_output_xml,v_1)
+,(a_output_encoding,utf8)
+,(a_show_tree,v_0)
+,(a_show_haskell,v_0)
+]
+
+writeXmlDoc::XmlStateFilterstate
+writeXmlDoct'
+=putt'
+where
+put
+|nullfn||fn=="-"=putXmlDoc
+|otherwise=putXmlDocToFilefn
+
+fn=xshow.getValuea_output_file$t'
+
+
+-- ------------------------------------------------------------
+--
+
+-- |
+-- wrapper filter for running a monadic filter
+-- controlled by common options
+--
+-- input tree must be a complete document
+-- parameters and default parameters can be used to contol
+-- the filer and common tasks like error message handling
+
+processDocument::Attributes->Attributes->XmlStateFilterstate->XmlStateFilterstate
+processDocumentuserOptionsdefaultOptionsprocessFilter
+=liftMfisRoot
+.>>
+liftMf(addOptionsuserOptions
+.>
+addOptions[(a_status,showc_ok)]
+)
+.>>
+liftMf(addDefaultOptionsdefaultOptions)
+.>>
+setSystemParams-- store options in system state
+.>>
+choiceM
+[hasOptiona_propagate_errors-- error handling is set by calling environment
+:->thisM
+
+,hasOptiona_collect_errors
+.>
+hasOptiona_issue_errors
+:->performAction(\_->setSysErrorHandler(errorMsgLogging.>>errorMsgToStderr))
+
+,hasOptiona_collect_errors
+:->performAction(\_->setSysErrorHandlererrorMsgLogging)
+
+,hasOptiona_issue_errors
+:->performAction(\_->setSysErrorHandlererrorMsgToStderr)
+
+,this
+:->performAction(\_->setSysErrorHandlernoneM)
+]
+.>>
+processFilter
+.>>
+(thisM
++++>>
+(hasOptiona_collect_errors
+`guardsM`
+getErrorMsg
+)
+)
+
+-- ------------------------------------------------------------
+
+
-- ------------------------------------------------------------
+--
+-- input functions
+-- implemented as filer
+
+moduleText.XML.HXT.Parser.XmlInput
+(getXmlContents
+,getXmlEntityContents
+,getUrlContents
+,getContentLength
+,guessDocEncoding
+,runInLocalURIContext
+,runInNewURIContext
+,getBaseURI
+,setBaseURI
+,getAbsolutURI
+,isStandaloneDocument
+)
+
+where
+
+importText.XML.HXT.DOM.XmlTree
+
+importText.XML.HXT.DOM.XmlState
+
+importText.XML.HXT.Parser.DefaultURI
+(setDefaultURI
+)
+
+importText.XML.HXT.Parser.XmlParser
+(parseXmlDocEncodingSpec
+,parseXmlEntityEncodingSpec
+,removeEncodingSpec
+)
+
+importText.XML.HXT.DOM.Unicode
+(getDecodingFct
+,guessEncoding
+,normalizeNL
+)
+
+importText.XML.HXT.Parser.XmlOutput
+(traceTree
+,traceSource
+,traceMsg
+)
+
+importText.XML.HXT.Parser.ProtocolHandler
+(getProtocolHandler
+)
+
+-- ------------------------------------------------------------
+--
+-- URI manipulation
+
+importNetwork.URI
+(parseURIReference
+,relativeTo
+,uriScheme
+)
+
+-- ------------------------------------------------------------
+--
+-- utilities
+
+importData.Maybe
+
+-- ------------------------------------------------------------
+--
+-- filter for reading the content
+-- input: a root node with arguments in tag attribute list
+-- and without any children.
+
+-- attribute a_source ("source") for input file or uri
+--
+-- attribute a_encoding ("encoding") for encoding scheme
+--
+-- attribute a_proxy ("proxy") for proxy tob be used in http access
+
+getXmlContents'::XmlFilter->XmlStateFiltera
+getXmlContents'parseEncodingSpec
+=getContent'
+`whenM`isRoot
+where
+getContent't'
+=(liftMf(setStatusc_ok"getXmlContents")
+.>>
+getUrlContents
+.>>
+liftFparseEncodingSpec
+.>>
+guessDocEncoding
+.>>
+traceMsg1("getXmlContents: content read and decoded from "++showinput')
+.>>
+traceTree
+.>>
+traceSource
+)t'
+where
+input'=valueOfa_sourcet'
+
+-- |
+-- filter for reading the content of a XML document
+--
+-- input is a root node with the source as an attibute
+-- the text is read, the encoding scheme is parsed and selected
+-- and the input is translated into the internal UTF-8 string representation
+
+getXmlContents::XmlStateFiltera
+getXmlContents
+=getXmlContents'parseXmlDocEncodingSpec
+.>>
+setBaseURIFilter
+.>>
+setStandAloneFilter
+
+-- |
+-- filter for reading the content of an external XML entity
+--
+--
+-- see also : 'getXmlContents'
+
+getXmlEntityContents::XmlStateFiltera
+getXmlEntityContents
+=getXmlContents'parseXmlEntityEncodingSpec
+.>>
+liftF(processChildrenremoveEncodingSpec)-- remove encoding spec, it's not part of the entity value
+.>>
+setBaseURIFilter
+
+-- ------------------------------------------------------------
+
+setBaseURIFilter::XmlStateFiltera
+setBaseURIFilter
+=performAction(\t->setBaseURI(valueOftransferURIt))
+`whenM`isRoot
+
+-- |
+-- filter command for saving and restoring
+-- the base URI
+--
+-- * 1.parameter f : the filter that possible changes the base URI
+--
+--
+-- - returns : a filter with the same effect as f, that restores the base URI after application of f
+
+runInLocalURIContext::XmlStateFiltera->XmlStateFiltera
+runInLocalURIContextft
+=do
+oldContext<-getBaseURI
+trace2("runInLocalURIContext: save base URI "++showoldContext)
+res<-ft
+setBaseURIoldContext
+trace2("runInLocalURIContext: restore base URI "++showoldContext)
+returnres
+
+-- |
+-- filter command for running an action in a new URI context
+
+runInNewURIContext::String->XmlStateFiltera->XmlStateFiltera
+runInNewURIContexturif
+|nulluri
+=f
+|otherwise
+=runInLocalURIContext
+(\t->(do
+trace2("runInNewURIContext: new base URI "++showuri)
+setBaseURIuri
+ft
+)
+)
+
+-- ------------------------------------------------------------
+-- |
+-- guessEncoding uses encoding attribute and content
+-- to determine the encoding scheme.
+--
+-- it's assumed that an encoding spec has been tried to parse before guessing the encoding.
+--
+-- UTF-8 is the default encoding
+--
+-- other supported encodings are ISO-8859-1 (also known as ISO-Latin-1),
+-- US-ASCII, UTF-16 or ISO-10646-UCS-2, UTF-16BE, UTF-16LE
+
+guessDocEncoding::XmlStateFiltera
+guessDocEncoding
+=addDocEncoding
+`whenM`isRoot
+where
+addDocEncodingn'
+=do
+trace2("guessDocEncoding: encoding is "++showguess)
+(encFilter(getDecodingFctguess)
+.>>
+issueError
+.>>
+liftMf(addAttrtransferEncodingguess))n'
+where
+guess::String
+guess=head.filter(not.null)
+$[(guessEncoding.showXText.getChildren)n'
+,valueOftransferEncodingn'
+,valueOfa_encodingn'
+,utf8
+]
+encFilter(Justfct)
+=decodeDocfct
+
+encFilterNothing
+=addFatal("encoding scheme not supported: "++showguess)
+
+decodeDocdfn''
+|nullerrs=liftMf(replaceChildren(xtext(normalizeNLres)))$n''
+|otherwise=(liftMf(replaceChildren(xtext""))
+.>>
+(issueDecodingErrs
++++>>
+addFatal"decoding errors detected"
+)
+)n''
+where
+str=xshow.getChildren$n''
+(res,errs)=dfstr
+issueDecodingErrs=catM.map(issueErr.(guess++).(" encoding error"++))$errs
+
+-- ------------------------------------------------------------
+
+getDefaultURI::XStatestateString
+getDefaultURI
+=do
+uri<-getSysParamtransferDefaultURI
+ifnulluri
+thendo
+setDefaultURI
+getDefaultURI
+elsereturnuri
+
+-- |
+-- set the base URI, all other URIs are handled relative to this base URI
+--
+-- the default base URI is @file:\/\/\/\<current-working-dir\>\/@
+--
+-- see also : 'getBaseURI'
+
+setBaseURI::String->XStatestate()
+setBaseURIstr
+=do
+trace2("setBaseURI: new base URI: "++showstr)
+setSysParamtransferURIstr
+
+-- |
+-- read the current base URI
+--
+-- see also : 'setBaseURI'
+
+getBaseURI::XStatestateString
+getBaseURI
+=do
+uri<-getSysParamtransferURI
+ifnulluri
+thendo
+res<-getDefaultURI
+setBaseURIres
+getBaseURI
+elsereturnuri
+
+-- |
+-- transform an URI into an absolut URI using the current base URI
+--
+--
+-- * 1.parameter uri : the URI as string
+--
+--
+-- - returns : the absolut URI as string or \"\" in case of an error
+
+getAbsolutURI::String->XStatestateString
+getAbsolutURIuri
+=do
+baseUri<-getBaseURI
+return$expandURIuribaseUri
+
+expandURI::String->String->String
+expandURIuribase
+=fromMaybe""$expand
+where
+expand=do
+base'<-parseURIReferencebase
+uri'<-parseURIReferenceuri
+abs'<-relativeTouri'base'
+return$showabs'
+
+-- ------------------------------------------------------------
+
+setStandAloneFilter::XmlStateFiltera
+setStandAloneFilter
+=performActionsetStandAlone
+where
+setStandAlonet
+=do
+ifnullstandalone
+thenreturn()
+elsedo
+trace2("setStandAloneFilter: standalone="++showstandaloneVal)
+setSysParama_standalonestandaloneVal
+where
+standalone=getValuea_standalonet
+standaloneVal=showXTextstandalone
+
+-- |
+-- predicate for testing the standalone document attribute
+
+isStandaloneDocument::XStatestateBool
+isStandaloneDocument
+=do
+val<-getSysParama_standalone
+return(val=="yes")
+
+-- ------------------------------------------------------------
+
+-- |
+-- the hard io operations
+--
+-- for reading a file or accessing a document via http
+-- input must be a root node with a @source@ attribute specifying the URI
+
+getUrlContents::XmlStateFiltera
+getUrlContents
+=getCont
+`whenM`isRoot
+where
+getContn'
+=do
+trace1("getUrlContent: reading "++showsrc)
+uri<-getAbsolutURIsrc
+ifnulluri
+thenurlErr("illegal URI for input: "++showsrc)
+elselet
+uri'=fromJust$parseURIReferenceuri
+proto=init.uriScheme$uri'
+handler=getProtocolHandlerproto
+in
+(liftMf(addAttrtransferProtocolproto
+.>
+addAttrtransferURIuri
+)
+.>>
+handleruri'
+)$n'
+where
+src=valueOfa_sourcen'
+urlErrmsg=addFatalmsgn'
+
+-- ------------------------------------------------------------
+
+-- |
+-- compute the length of the data for a document read previously
+-- by a call of 'getUrlContents. The result is stored as an attribute
+-- value in the document root node. the attribute name is 'a_contentLength'
+
+getContentLength::XmlFilter
+getContentLength
+=addAttrlcontentLengthAttr
+`when`isRoot
+where
+http_contentLength=httpPrefix++"Content-Length"
+
+contentLengthAttr::XmlFilter
+contentLengthAttrt
+=choice[hasAttra_contentLength
+:->none
+,hasAttrhttp_contentLength
+:->mkXAttra_contentLength(getValuehttp_contentLength)
+,this
+:->mkXAttra_contentLengthgetLength
+]t
+
+getLength::XmlFilter
+getLengtht
+=xtext(show.length.xshow.getChildren$t)
+
+-- ------------------------------------------------------------
+
-- |
+-- Simple parse functions.
+--
+-- the "main" building blocks for an application.
+-- this module exports all important functions for parsing, validating and transforming XML.
+-- it also exports all basic datatypes and functions of the toolbox.
+--
+
+moduleText.XML.HXT.Parser
+(moduleText.XML.HXT.DOM
+
+,moduleText.XML.HXT.Parser.XmlParser
+,moduleText.XML.HXT.Parser.HtmlParser
+,moduleText.XML.HXT.Parser.XmlInput
+,moduleText.XML.HXT.Parser.XmlOutput
+,moduleText.XML.HXT.Parser.DTDProcessing
+,moduleText.XML.HXT.Parser.MainFunctions
+
+,moduleText.XML.HXT.Validator.Validation
+)
+where
+
+importText.XML.HXT.DOM
+
+importText.XML.HXT.Parser.XmlParser
+importText.XML.HXT.Parser.HtmlParser
+importText.XML.HXT.Parser.XmlInput
+importText.XML.HXT.Parser.XmlOutput
+importText.XML.HXT.Parser.DTDProcessing
+importText.XML.HXT.Parser.MainFunctions
+
+importText.XML.HXT.Validator.Validation
+
+-- ------------------------------------------------------------
+
+
-- |
+-- This module provides functions for validating attributes.
+
+-- The main functions are:
+--
+-- - Check if the attribute value meets the lexical constraints of its type
+--
+-- - Normalization of an attribute value
+--
+
+-- Special namings in source code:
+--
+-- - nd - XDTD node
+--
+-- - n - XTag node
+--
+
+moduleText.XML.HXT.Validator.AttributeValueValidation
+(checkAttributeValue
+,normalizeAttributeValue
+)
+where
+
+importText.XML.HXT.Parser.XmlParser
+(parseNMToken
+,parseName
+)
+
+importText.XML.HXT.DOM.XmlTree
+importText.XML.HXT.DOM.Util
+
+-- |
+-- Checks if the attribute value meets the lexical constraints of its type.
+--
+-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
+--
+-- - 2.parameter attrDecl : the declaration of the attribute from the DTD
+--
+-- - returns : a function which takes an element (XTag or XDTD ATTLIST),
+-- checks if the attribute value meets the lexical constraints
+-- of its type and returns a list of errors
+
+checkAttributeValue::XmlTrees->XmlTree->XmlFilter
+checkAttributeValuedtdPartattrDecl@(NTree(XDTDATTLISTal)_)n@(NTree(XTag__al')_)
+=checkValueattrTypedtdPartnormalizedValattrDecln
+where
+attrType=lookup1a_typeal
+attrValue=valueOf(getAttrNameal)n
+normalizedVal=normalizeAttributeValue(JustattrDecl)attrValue
+
+checkAttributeValuedtdPartattrDecl@(NTree(XDTDATTLISTal)_)n@(NTree(XDTDATTLISTal')_)
+=checkValueattrTypedtdPartnormalizedValattrDecln
+where
+attrType=lookup1a_typeal
+attrValue=lookup1a_defaultal'
+normalizedVal=normalizeAttributeValue(JustattrDecl)attrValue
+
+checkAttributeValue_ndn
+=error("checkAttributeValue: illegeal parameter:\n"++shownd++shown)
+
+
+-- |
+-- Dispatches the attibute check by the attribute type.
+--
+-- * 1.parameter typ : the attribute type
+--
+-- - 2.parameter dtdPart : the children of the @DOCTYPE@ node
+--
+-- - 3.parameter attrValue : the normalized attribute value to be checked
+--
+-- - 4.parameter attrDecl : the declaration of the attribute from the DTD
+--
+-- - returns : a functions which takes an element (XTag or XDTD ATTLIST),
+-- checks if the attribute value meets the lexical constraints
+-- of its type and returns a list of errors
+
+checkValue::String->XmlTrees->String->XmlTree->XmlFilter
+checkValuetypdtdPartattrValueattrDecl
+|typ==k_cdata=none
+|typ==k_enumeration=checkValueEnumerationattrDeclattrValue
+|typ==k_entity=checkValueEntitydtdPartattrDeclattrValue
+|typ==k_entities=checkValueEntitiesdtdPartattrDeclattrValue
+|typ==k_id=checkValueIdattrDeclattrValue
+|typ==k_idref=checkValueIdrefattrDeclattrValue
+|typ==k_idrefs=checkValueIdrefsattrDeclattrValue
+|typ==k_nmtoken=checkValueNmtokenattrDeclattrValue
+|typ==k_nmtokens=checkValueNmtokensattrDeclattrValue
+|typ==k_notation=checkValueEnumerationattrDeclattrValue
+|otherwise=error("Attribute type "++showtyp++" unknown.")
+
+-- |
+-- Checks the value of Enumeration attribute types. (3.3.1 \/ p.27 in Spec)
+--
+-- * 1.parameter attrDecl : the declaration of the attribute from the DTD
+--
+-- - 2.parameter attrValue : the normalized attribute value to be checked
+
+checkValueEnumeration::XmlTree->String->XmlFilter
+checkValueEnumeration(NTree(XDTDATTLISTal)cs)attrValue
+=ifattrValue`elem`enumVals
+thennone
+elseerr("Attribute "++show(getAttrNameal)++" for element "++show(getElemNameal)++
+" must have a value from list "++showenumVals++".")
+where
+enumVals::[String]
+enumVals=map(getEnumVal)cs
+
+getEnumVal::XmlTree->String
+getEnumVal(NTree(XDTDNAMEal')_)=lookup1a_nameal'
+getEnumVal_=""
+
+checkValueEnumerationn_
+=error("checkValueEnumeration: illegeal parameter:\n"++shown)
+
+
+-- |
+-- Checks the value of ENTITY attribute types. (3.3.1 \/ p.26 in Spec)
+--
+-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node, to get the
+-- unparsed entity declarations
+--
+-- - 2.parameter attrDecl : the declaration of the attribute from the DTD
+--
+-- - 3.parameter attrValue : the normalized attribute value to be checked
+
+checkValueEntity::XmlTrees->XmlTree->String->XmlFilter
+checkValueEntitydtdPart(NTree(XDTDATTLISTal)_)attrValue
+=ifattrValue`elem`upEntities
+thennone
+elseerr("Entity "++showattrValue++" of attribute "++show(getAttrNameal)++
+" for element "++show(getElemNameal)++" is not unparsed. "++
+"The following unparsed entities exist: "++showupEntities++".")
+where
+upEntities::[String]
+upEntities=map(getEnumVal)(isUnparsedEntity$$dtdPart)
+
+getEnumVal::XmlTree->String
+getEnumVal(NTree(XDTDENTITYal')_)=lookup1a_nameal'
+getEnumVal_=""
+
+
+checkValueEntity_n_
+=error("checkValueEntity: illegeal parameter:\n"++shown)
+
+
+-- |
+-- Checks the value of ENTITIES attribute types. (3.3.1 \/ p.26 in Spec)
+--
+-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node, to get the
+-- unparsed entity declarations
+--
+-- - 2.parameter attrDecl : the declaration of the attribute from the DTD
+--
+-- - 3.parameter attrValue : the normalized attribute value to be checked
+
+checkValueEntities::XmlTrees->XmlTree->String->XmlFilter
+checkValueEntitiesdtdPartattrDecl@(NTree(XDTDATTLISTal)_)attrValue
+=ifnullvalueList
+thenerr("Attribute "++show(getAttrNameal)++" of element "++
+show(getElemNameal)++" must be one or more names.")
+elsecat(map(checkValueEntitydtdPartattrDecl)valueList)
+where
+valueList=wordsattrValue
+
+checkValueEntities_n_
+=error("checkValueEntities: illegeal parameter:\n"++shown)
+
+
+-- |
+-- Checks the value of NMTOKEN attribute types. (3.3.1 \/ p.26 in Spec)
+--
+-- * 1.parameter attrDecl : the declaration of the attribute from the DTD
+--
+-- - 2.parameter attrValue : the normalized attribute value to be checked
+
+checkValueNmtoken::XmlTree->String->XmlFilter
+checkValueNmtoken(NTree(XDTDATTLISTal)_)attrValue
+=checkNmtokenparseRes
+where
+parseRes::XmlTrees
+parseRes=parseNMToken""(mkXTextTreeattrValue)
+
+checkNmtoken::XmlTrees->XmlFilter
+checkNmtoken((NTree(XError_s)_):_)
+=err("Attribute value "++showattrValue++" of attribute "++show(getAttrNameal)++
+" for element "++show(getElemNameal)++" must be a name token, "++(liness)!!1++".")
+
+checkNmtoken_=none
+
+
+checkValueNmtokenn_
+=error("checkValueNmtoken: illegeal parameter:\n"++shown)
+
+
+-- |
+-- Checks the value of NMTOKENS attribute types. (3.3.1 \/ p.26 in Spec)
+--
+-- * 1.parameter attrDecl : the declaration of the attribute from the DTD
+--
+-- - 2.parameter attrValue : the normalized attribute value to be checked
+
+checkValueNmtokens::XmlTree->String->XmlFilter
+checkValueNmtokensattrDecl@(NTree(XDTDATTLISTal)_)attrValue
+=ifnullvalueList
+thenerr("Attribute "++show(getAttrNameal)++" of element "++
+show(getElemNameal)++" must be one or more name tokens.")
+elsecat(map(checkValueNmtokenattrDecl)valueList)
+where
+valueList=wordsattrValue
+
+checkValueNmtokensn_
+=error("checkValueNmtokens: illegeal parameter:\n"++shown)
+
+
+-- |
+-- Checks the value of ID attribute types. (3.3.1 \/ p.25 in Spec)
+--
+-- * 1.parameter attrDecl : the declaration of the attribute from the DTD
+--
+-- - 2.parameter attrValue : the normalized attribute value to be checked
+
+checkValueId::XmlTree->String->XmlFilter
+checkValueIdattrDeclattrValue
+=checkForName"Attribute value"attrDeclattrValue
+
+
+-- |
+-- Checks the value of IDREF attribute types. (3.3.1 \/ p.26 in Spec)
+--
+-- * 1.parameter attrDecl : the declaration of the attribute from the DTD
+--
+-- - 2.parameter attrValue : the normalized attribute value to be checked
+
+checkValueIdref::XmlTree->String->XmlFilter
+checkValueIdrefattrDeclattrValue
+=checkForName"Attribute value"attrDeclattrValue
+
+
+-- |
+-- Checks the value of IDREFS attribute types. (3.3.1 \/ p.26 in Spec)
+--
+-- * 1.parameter attrDecl : the declaration of the attribute from the DTD
+--
+-- - 2.parameter attrValue : the normalized attribute value to be checked
+
+checkValueIdrefs::XmlTree->String->XmlFilter
+checkValueIdrefsattrDeclattrValue
+=cat(map(checkValueIdrefattrDecl)(wordsattrValue))
+
+
+
+-- -----------------------------------------------------------------------------
+-- General helper functions for checking attribute values
+--
+
+-- |
+-- Checks if the value of an attribute is a name.
+--
+-- * 1.parameter msg : error message, should be "Entity" or "Attribute value"
+--
+-- - 2.parameter attrDecl : the declaration of the attribute from the DTD
+--
+-- - 3.parameter attrValue : the normalized attribute value to be checked
+
+checkForName::String->XmlTree->String->XmlFilter
+checkForNamemsg(NTree(XDTDATTLISTal)_)attrValue
+=checkNameparseRes
+where
+parseRes::XmlTrees
+parseRes=parseName""(mkXTextTreeattrValue)
+
+checkName::XmlTrees->XmlFilter
+checkName((NTree(XError_s)_):_)
+=err(msg++" "++showattrValue++" of attribute "++show(getAttrNameal)++
+" for element "++show(getElemNameal)++" must be a name, "++(liness)!!1++".")
+
+checkName_=none
+
+
+checkForName_n_
+=error("checkForName: illegeal parameter:\n"++shown)
+
+
+-- |
+-- Gets the element name from an attribute list of an XDTD ATTLIST node.
+--
+-- * 1.parameter tag : the attibute list of an XDTD ATTLIST
+--
+-- - returns : the element name
+
+getElemName::Attributes->String
+getElemName=lookup1a_name
+
+
+-- |
+-- Gets the attribute name from an attribute list of an XDTD ATTLIST node.
+--
+-- * 1.parameter tag : the attibute list of an XDTD ATTLIST
+--
+-- - returns : the attribute name
+
+getAttrName::Attributes->String
+getAttrName=lookup1a_value
+
+
+
+-- -----------------------------------------------------------------------------
+
+
+-- |
+-- Normalizes an attribute value with respect to its type. (3.3.3 \/ p.29 in Spec)
+--
+-- * 1.parameter attrDecl : the declaration of the attribute from the DTD. Expected
+-- is a list. If the list is empty, no declaration exists.
+--
+-- - 2.parameter value : the attribute value to be normalized
+--
+-- - returns : the normalized value
+--
+normalizeAttributeValue::MaybeXmlTree->String->String
+normalizeAttributeValue(Just(NTree(XDTDATTLISTal)_))value
+=normalizeAttributeattrType
+where
+attrType=lookup1a_typeal
+
+normalizeAttribute::String->String
+normalizeAttributetyp
+|typ==k_cdata=cdataNormalizationvalue
+|otherwise=otherNormalizationvalue
+
+
+-- Attribute not declared in DTD, normalization as CDATA
+normalizeAttributeValue_value
+=cdataNormalizationvalue
+
+
+-- ------------------------------------------------------------
+-- Helper functions for normalization
+
+
+-- |
+-- Normalization of CDATA attribute values.
+-- is already done when parsing
+-- during entity substituion for attribute values
+cdataNormalization::String->String
+cdataNormalization=id
+
+
+-- | Normalization of attribute values other than CDATA.
+otherNormalization::String->String
+otherNormalization=reduceWSSequences.stringTrim.cdataNormalization
+
+-- | Reduce whitespace sequences to a single whitespace.
+reduceWSSequences::String->String
+reduceWSSequencesstr=unwords(wordsstr)
+
+
+
-- |
+-- This module provides functions for validating the DTD of XML documents
+-- represented as XmlTree.
+
+-- Unlike other popular XML validation tools the validation process returns
+-- a list of errors instead of aborting after the first error was found.
+
+
+-- Unlike validation of the document, the DTD branch is traversed four times:
+--
+-- - Validation of Notations
+--
+-- - Validation of Unparsed Entities
+--
+-- - Validation of Element declarations
+--
+-- - Validation of Attribute declarations
+
+-- Special namings in source code:
+--
+-- - nd - XDTD node
+--
+-- Author : .\\artin Schmidt
+
+moduleText.XML.HXT.Validator.DTDValidation
+(removeDoublicateDefs
+,validateDTD
+)
+where
+
+importText.XML.HXT.DOM.XmlTree
+
+importText.XML.HXT.Validator.AttributeValueValidation
+
+
+
+-- |
+-- Validate a DTD.
+--
+-- - returns : a functions which takes the DTD subset of the XmlTree, checks
+-- if the DTD is valid and returns a list of errors
+
+validateDTD::XmlFilter
+validateDTDdtdPart
+={-# SCC "validateNotations" #-}validateNotationsdtdPart'
+++
+{-# SCC "validateEntities" #-}validateEntitiesdtdPart'notationNames
+++
+{-# SCC "validateElements" #-}validateElementsdtdPart'elemNames
+++
+{-# SCC "validateAttributes" #-}validateAttributesdtdPart'elemNamesnotationNames
+
+where
+dtdPart'=getChildrendtdPart
+
+notationNames::[String]
+notationNames
+=getXTextValues(isNotation.>getDTDValuea_name$$dtdPart')
+
+elemNames::[String]
+elemNames
+=getXTextValues(isElement.>getDTDValuea_name$$dtdPart')
+
+
+
+
+-- ------------------------------------------------------------
+
+-- |
+-- Returns a list of XText values.
+--
+-- * 1.parameter xtextList : a list of XText nodes
+--
+-- - returns : the values of the XText nodes
+
+getXTextValues::XmlTrees->[String]
+getXTextValues
+=concatMapshowT
+where
+showT(NTreen_)
+|isXTextNoden=[textOfXNoden]
+showT_=[]
+
+
+-- ------------------------------------------------------------
+
+
+-- |
+-- Validation of Notations, checks if all notation names are unique.
+-- Validity constraint: Unique Notation Name (4.7 \/ p.44 in Spec)
+--
+-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
+--
+-- - returns : a list of errors
+
+validateNotations::XmlTrees->XmlTrees
+validateNotationsdtdPart
+=checkForUniqueNotationnotations[]
+where
+notations=isNotation$$dtdPart
+
+checkForUniqueNotation::XmlTrees->[String]->XmlTrees
+checkForUniqueNotation(x@(NTree(XDTDNOTATIONal)_):xs)used
+=ifname`elem`used
+thenerr("Notation "++showname++" was already specified.")x
+++
+checkForUniqueNotationxsused
+
+elsecheckForUniqueNotationxs(name:used)
+where
+name=lookup1a_nameal
+
+checkForUniqueNotation[]_=[]
+
+checkForUniqueNotationnd_
+=error("checkForUniqueNotation: illegeal parameter:\n"++shownd)
+
+
+-- |
+-- Validation of Entities.
+--
+-- 1. Issues a warning if entities are declared multiple times.
+--
+-- Optional warning: (4.2 \/ p.35 in Spec)
+--
+--
+-- 2. Validates that a notation is declared for an unparsed entity.
+--
+-- Validity constraint: Notation Declared (4.2.2 \/ p.36 in Spec)
+--
+-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
+--
+-- - 2.parameter notationNames : list of all notation names declared in the DTD
+--
+-- - returns : a list of errors
+
+validateEntities::XmlTrees->[String]->XmlTrees
+validateEntitiesdtdPartnotationNames
+=checkForUniqueEntityentities[]
+++
+checkNotationDeclsnotationNamesupEntities
+
+where
+entities=isEntity$$dtdPart
+upEntities=isUnparsedEntity$$dtdPart
+
+-- Check if entities are declared multiple times
+checkForUniqueEntity::XmlTrees->[String]->XmlTrees
+checkForUniqueEntity(x@(NTree(XDTDENTITYal)_):xs)used
+=ifname`elem`used
+thenwarn("Entity "++showname++" was already specified. "++
+"First declaration will be used.")x
+++
+checkForUniqueEntityxsused
+
+elsecheckForUniqueEntityxs(name:used)
+where
+name=lookup1a_nameal
+
+checkForUniqueEntity[]_=[]
+
+checkForUniqueEntitynd_
+=error("checkForUniqueEntity: illegeal parameter:\n"++shownd)
+
+
+-- Find unparsed entities for which no notation is specified
+checkNotationDecls::[String]->XmlTrees->XmlTrees
+checkNotationDeclsnotationNames'upEntities'
+=concatMap(checkNotationDecl)upEntities'
+where
+checkNotationDecl::XmlTree->XmlTrees
+checkNotationDecln@(NTree(XDTDENTITYal)_)
+=if(notationNameal)`elem`notationNames'
+then[]
+elseerr("The notation "++show(notationNameal)++" must be declared "++
+"when referenced in the unparsed entity declaration for "++
+show(upEntityNameal)++".")n
+where
+notationName=lookup1k_ndata
+upEntityName=lookup1a_name
+
+checkNotationDeclnd
+=error("checkNotationDecl: illegeal parameter:\n"++shownd)
+
+
+
+-- |
+-- Validation of Element declarations.
+--
+-- 1. Validates that an element is not declared multiple times.
+--
+-- Validity constraint: Unique Element Type Declaration (3.2 \/ p.21 in Spec)
+--
+--
+-- 2. Validates that an element name only appears once in a mixed-content declaration.
+--
+-- Validity constraint: No Duplicate Types (3.2 \/ p.21 in Spec)
+--
+--
+-- 3. Issues a warning if an element mentioned in a content model is not declared in the
+-- DTD.
+--
+-- Optional warning: (3.2 \/ p.21 in Spec)
+--
+-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
+--
+-- - 2.parameter elemNames : list of all element names declared in the DTD
+--
+-- - returns : a list of errors
+
+
+validateElements::XmlTrees->[String]->XmlTrees
+validateElementsdtdPartelemNames
+=checkForUniqueElementelements[]
+++
+checkMixedContentsmixedContentElems
+++
+checkContentModelselemNameselements
+
+where
+elements=isElement$$dtdPart
+mixedContentElems=isMixedContentElement$$dtdPart
+
+
+-- Validates that an element is not declared multiple times
+checkForUniqueElement::XmlTrees->[String]->XmlTrees
+checkForUniqueElement(x@(NTree(XDTDELEMENTal)_):xs)used
+=ifname`elem`used
+thenerr("Element type "++showname++
+" must not be declared more than once.")x
+++
+checkForUniqueElementxsused
+
+elsecheckForUniqueElementxs(name:used)
+where
+name=lookup1a_nameal
+
+checkForUniqueElement[]_=[]
+
+checkForUniqueElementnd_
+=error("checkForUniqueElement: illegeal parameter:\n"++shownd)
+
+
+-- Validates that an element name only appears once in a mixed-content declaration
+checkMixedContentselems
+=concatMap(checkMixedContent)elems
+where
+checkMixedContent(NTree(XDTDELEMENTal)cs)
+=checkMC(getChildren(headcs))[]
+where
+elemName=lookup1a_nameal
+
+checkMC::XmlTrees->[String]->XmlTrees
+checkMC(x@(NTree(XDTDNAMEal')_):xs)used
+=ifname`elem`used
+thenerr("The element type "++showname++
+" was already specified in the mixed-content model of the element declaration "++
+showelemName++".")x
+++
+checkMCxsused
+
+elsecheckMCxs(name:used)
+where
+name=lookup1a_nameal'
+
+checkMC[]_=[]
+
+checkMCnd_
+=error("checkMC: illegeal parameter:\n"++shownd)
+
+checkMixedContentnd
+=error("checkMixedContent: illegeal parameter:\n"++shownd)
+
+
+-- Issues a warning if an element mentioned in a content model is not
+-- declared in the DTD.
+checkContentModelsnameselems
+=concatMapcheckContentModelelems
+where
+checkContentModel::XmlFilter
+checkContentModel(NTree(XDTDELEMENTal)cs)
+=validateContent(lookup1a_typeal)
+where
+elemName=lookup1a_nameal
+
+validateContent::String->XmlTrees
+validateContentcm
+|cm==v_children=checkContent(headcs)
+|cm==v_mixed=checkContent(headcs)
+|otherwise=[]-- no child elements to check
+
+checkContent::XmlFilter
+checkContentn@(NTree(XDTDNAMEal')_)
+=ifchildElemName`elem`names
+then[]
+elsewarn("The element type "++showchildElemName++
+", used in content model of element "++showelemName++
+", is not declared.")n
+where
+childElemName=lookup1a_nameal'
+
+checkContent(NTree(XDTDCONTENT_)cs')
+=concatMap(checkContent)cs'
+
+checkContentnd
+=error("checkContent: illegeal parameter:\n"++shownd)
+
+checkContentModelnd
+=error("checkContentModel: illegeal parameter:\n"++shownd)
+
+
+-- |
+-- Validation of Attribute declarations.
+--
+-- (1) Issues a warning if an attribute is declared for an element type not itself
+-- decared.
+--
+-- Optinal warning: (3.3 \/ p. 24 in Spec)
+--
+--
+-- 2. Issues a warning if more than one definition is provided for the same
+-- attribute of a given element type. Fist declaration is binding, later
+-- definitions are ignored.
+--
+-- Optional warning: (3.3 \/ p.24 in Spec)
+--
+--
+-- 3. Issues a warning if the same Nmtoken occures more than once in enumerated
+-- attribute types of a single element type.
+--
+-- Optional warning: (3.3.1 \/ p.27 in Spec)
+--
+--
+-- 4. Validates that an element type has not more than one ID attribute defined.
+--
+-- Validity constraint: One ID per Element Type (3.3.1 \/ p.26 in Spec)
+--
+--
+-- 5. Validates that an element type has not more than one NOTATION attribute defined.
+--
+-- Validity constraint: One Notation per Element Type (3.3.1 \/ p.27 in Spec)
+--
+--
+-- 6. Validates that an ID attributes has the type #IMPLIED or #REQUIRED.
+--
+-- Validity constraint: ID Attribute Default (3.3.1 \/ p.26 in Spec)
+--
+--
+-- 7. Validates that all referenced notations are declared.
+--
+-- Validity constraint: Notation Attributes (3.3.1 \/ p.27 in Spec)
+--
+--
+-- 8. Validates that notations are not declared for EMPTY elements.
+--
+-- Validity constraint: No Notation on Empty Element (3.3.1 \/p.27 in Spec)
+--
+--
+-- 9. Validates that the default value matches the lexical constraints of it's type.
+--
+-- Validity constraint: Attribute default legal (3.3.2 \/ p.28 in Spec)
+--
+--
+-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
+--
+-- - 2.parameter elemNames : list of all element names declared in the DTD
+--
+-- - 3.parameter notationNames : list of all notation names declared in the DTD
+--
+-- - returns : a list of errors
+
+validateAttributes::XmlTrees->[String]->[String]->XmlTrees
+validateAttributesdtdPartelemNamesnotationNames
+=-- 1. Find attributes for which no elements are declared
+((checkDeclaredElementselemNames)$$attributes)
+++
+-- 2. Find attributes which are declared more than once
+(checkForUniqueAttributeDeclarationattributes[])
+++
+-- 3. Find enumerated attribute types which nmtokens are declared more than once
+(checkEnumeratedTypes
+`o`
+(isEnumAttrType`orElse`isNotationAttrType)$$attributes)
+++
+-- 4. Validate that there exists only one ID attribute for an element
+(checkForUniqueIdidAttributes[])
+++
+-- 5. Validate that there exists only one NOTATION attribute for an element
+(checkForUniqueNotationnotationAttributes[])
+++
+-- 6. Validate that ID attributes have the type #IMPLIED or #REQUIRED
+(checkIdKindConstraint$$idAttributes)
+++
+-- 7. Validate that all referenced notations are declared
+((checkNotationDeclarationnotationNames)$$notationAttributes)
+++
+-- 8. Validate that notations are not declared for EMPTY elements
+((checkNoNotationForEmptyElement
+(
+getXTextValues(getDTDValuea_name$$(isEmptyElement$$dtdPart))
+)
+)$$notationAttributes)
+++
+-- 9. Validate that the default value matches the lexical constraints of it's type
+((checkDefaultValueTypesdtdPart)$$(isDefaultAttrKind$$attributes))
+
+where
+--------------------------------------------------------------------------
+-- helper functions
+attributes=isAttlist$$dtdPart
+idAttributes=isIdAttrType$$attributes
+notationAttributes=isNotationAttrType$$attributes
+
+
+elemName=lookup1a_name
+attName=lookup1a_value
+
+--------------------------------------------------------------------------
+-- 1. Find attributes for which no elements are declared
+checkDeclaredElements::[String]->XmlFilter
+checkDeclaredElementselemNames'n@(NTree(XDTDATTLISTal)_)
+=if(elemNameal)`elem`elemNames'
+then[]
+elsewarn("The element type \""++elemNameal++"\" used in declaration "++
+"of attribute \""++attNameal++"\" is not declared.")n
+
+checkDeclaredElements_nd
+=error("checkDeclaredElements: illegeal parameter:\n"++shownd)
+
+--------------------------------------------------------------------------
+-- 2. Find attributes which are declared more than once
+checkForUniqueAttributeDeclaration::XmlTrees->[String]->XmlTrees
+checkForUniqueAttributeDeclaration(x@(NTree(XDTDATTLISTal)_):xs)used
+=ifname`elem`used
+thenwarn("Attribute \""++aname++"\" for element type \""++
+ename++"\" is already declared. First "++
+"declaration will be used.")x
+++
+checkForUniqueAttributeDeclarationxsused
+
+elsecheckForUniqueAttributeDeclarationxs(name:used)
+where
+ename=elemNameal
+aname=attNameal
+name=ename++"|"++aname
+
+checkForUniqueAttributeDeclaration[]_=[]
+
+checkForUniqueAttributeDeclarationnd_
+=error("checkForUniqueAttributeDeclaration: illegeal parameter:\n"++shownd)
+
+
+--------------------------------------------------------------------------
+-- 3. Find enumerated attribute types which nmtokens are declared more than once
+checkEnumeratedTypes::XmlFilter
+checkEnumeratedTypes(NTree(XDTDATTLISTal)cs)
+=checkForUniqueTypecs[]
+where
+checkForUniqueType::XmlTrees->[String]->XmlTrees
+checkForUniqueType(x@(NTree(XDTDNAMEal')_):xs)used
+=ifnmtoken`elem`used
+thenwarn("Nmtoken \""++nmtoken++"\" should not "++
+"occur more than once in attribute \""++attNameal++
+"\" for element \""++elemNameal++"\".")x
+++
+checkForUniqueTypexsused
+
+elsecheckForUniqueTypexs(nmtoken:used)
+where
+nmtoken=lookup1a_nameal'
+
+checkForUniqueType[]_=[]
+
+checkForUniqueTypend_
+=error("checkForUniqueType: illegeal parameter:\n"++shownd)
+
+checkEnumeratedTypesnd
+=error("checkEnumeratedTypes: illegeal parameter:\n"++shownd)
+
+
+--------------------------------------------------------------------------
+-- 4. Validate that there exists only one ID attribute for an element
+checkForUniqueId::XmlTrees->[String]->XmlTrees
+checkForUniqueId(x@(NTree(XDTDATTLISTal)_):xs)used
+=ifename`elem`used
+thenerr("Element \""++ename++"\" already has attribute of type "++
+"ID, another attribute \""++attNameal++"\" of type ID is "++
+"not permitted.")x
+++
+checkForUniqueIdxsused
+
+elsecheckForUniqueIdxs(ename:used)
+where
+ename=elemNameal
+
+checkForUniqueId[]_=[]
+
+checkForUniqueIdnd_
+=error("checkForUniqueId: illegeal parameter:\n"++shownd)
+
+--------------------------------------------------------------------------
+-- 5. Validate that there exists only one NOTATION attribute for an element
+checkForUniqueNotation::XmlTrees->[String]->XmlTrees
+checkForUniqueNotation(x@(NTree(XDTDATTLISTal)_):xs)used
+=ifename`elem`used
+thenerr("Element \""++elemNameal++"\" already has attribute of type "++
+"NOTATION, another attribute \""++attNameal++"\" of type NOTATION "++
+"is not permitted.")x
+++
+checkForUniqueNotationxsused
+
+elsecheckForUniqueNotationxs(ename:used)
+where
+ename=elemNameal
+
+checkForUniqueNotation[]_=[]
+
+checkForUniqueNotationnd_
+=error("checkForUniqueNotation: illegeal parameter:\n"++shownd)
+
+--------------------------------------------------------------------------
+-- 6. Validate that ID attributes have the type #IMPLIED or #REQUIRED
+checkIdKindConstraint::XmlFilter
+checkIdKindConstraintnd@(NTree(XDTDATTLISTal)_)
+=if(attKind==k_implied)||(attKind==k_required)
+then[]
+elseerr("ID attribute \""++attNameal++"\" must have a declared default "++
+"of \"#IMPLIED\" or \"REQUIRED\"")nd
+where
+attKind=lookup1a_kindal
+
+checkIdKindConstraintnd
+=error("checkIdKindConstraint: illegeal parameter:\n"++shownd)
+
+
+--------------------------------------------------------------------------
+-- 7. Validate that all referenced notations are declared
+checkNotationDeclaration::[String]->XmlFilter
+checkNotationDeclarationnotations(NTree(XDTDATTLISTal)cs)
+=checkNotations$$cs
+where
+checkNotations::XmlFilter
+checkNotationsnd@(NTree(XDTDNAMEal')_)
+=ifnotation`elem`notations
+then[]
+elseerr("The notation \""++notation++"\" must be declared when "++
+"referenced in the notation type list for attribute \""++attNameal++
+"\" of element \""++elemNameal++"\".")nd
+where
+notation=lookup1a_nameal'
+
+checkNotationsnd
+=error("checkNotations: illegeal parameter:\n"++shownd)
+
+checkNotationDeclaration_nd
+=error("checkNotationDeclaration: illegeal parameter:\n"++shownd)
+
+--------------------------------------------------------------------------
+-- 8. Validate that notations are not declared for EMPTY elements
+checkNoNotationForEmptyElement::[String]->XmlFilter
+checkNoNotationForEmptyElementemptyElemsnd@(NTree(XDTDATTLISTal)_)
+=if(elemNameal)`elem`emptyElems
+thenerr("Attribute \""++attNameal++"\" of type NOTATION must not be "++
+"declared on the element \""++elemNameal++"\" declared EMPTY.")
+nd
+else[]
+
+checkNoNotationForEmptyElement_nd
+=error("checkNoNotationForEmptyElement: illegeal parameter:\n"++shownd)
+
+--------------------------------------------------------------------------
+-- 9. Validate that default values meet the lexical constraints of the attribute types
+checkDefaultValueTypes::XmlTrees->XmlFilter
+checkDefaultValueTypesdtdPart'n@(NTree(XDTDATTLIST_)_)
+=checkAttributeValuedtdPart'nn
+
+checkDefaultValueTypes_nd
+=error("checkDefaultValueTypes: illegeal parameter:\n"++shownd)
+
+
+
+-- ------------------------------------------------------------
+
+-- |
+-- Removes doublicate declarations from the DTD, which first declaration is
+-- binding. This is the case for ATTLIST and ENTITY declarations.
+--
+-- - returns : A function that replaces the children of DOCTYPE nodes by a list
+-- where all multiple declarations are removed.
+
+removeDoublicateDefs::XmlFilter
+removeDoublicateDefsn@(NTree(XDTDDOCTYPE_)cs)
+=replaceChildren(removeDoubleDefs[]cs)n
+where
+removeDoubleDefs::[String]->XmlTrees->XmlTrees
+removeDoubleDefsused(x@(NTree(XDTDATTLISTal)_):xs)
+=ifelemAttr`elem`used
+thenremoveDoubleDefsusedxs
+elsex
+:
+removeDoubleDefs(elemAttr:used)xs
+where
+elemAttr=elemName++"|"++attrName
+attrName=lookup1a_valueal
+elemName=lookup1a_nameal
+
+
+removeDoubleDefsused(x@(NTree(XDTDENTITYal)_):xs)
+=ifname`elem`used
+thenremoveDoubleDefsusedxs
+elsex
+:
+removeDoubleDefs(name:used)xs
+where
+name=lookup1a_nameal
+
+
+removeDoubleDefsused(x:xs)
+=x:removeDoubleDefsusedxs
+
+removeDoubleDefs_[]
+=[]
+
+
+removeDoublicateDefsn
+=[n]
+
+
-- |
+-- This module provides functions for transforming XML documents represented as
+-- XmlTree with respect to its DTD.
+
+-- Transforming an XML document with respect to its DTD means:
+--
+-- - add all attributes with default values
+--
+-- - normalize all attribute values
+--
+-- - sort all attributes in lexical order
+--
+
+
+-- Note: Transformation should be started after validation.
+
+
+-- Before the document is validated, a lookup-table is build on the basis of
+-- the DTD which maps element names to their transformation functions.
+-- After this initialization phase the whole document is traversed in preorder
+-- and every element is transformed by the XmlFilter from the lookup-table.
+
+-- Special namings in source code:
+--
+-- - nd - XDTD node
+--
+-- - n - XTag node
+--
+-- Author : .\\artin Schmidt
+
+moduleText.XML.HXT.Validator.DocTransformation
+(transform
+)
+where
+
+importText.XML.HXT.DOM.XmlTree
+
+importText.XML.HXT.Validator.AttributeValueValidation
+
+importData.Maybe
+importData.List
+
+
+
+-- |
+-- Lookup-table which maps element names to their transformation functions. The
+-- transformation functions are XmlFilters.
+
+typeTransEnvTable=[TransEnv]
+typeTransEnv=(ElemName,TransFct)
+typeElemName=String
+typeTransFct=XmlFilter
+
+
+-- ------------------------------------------------------------
+
+
+-- |
+-- filter for transforming the document.
+--
+-- * 1.parameter dtdPart : the DTD subset (Node @DOCTYPE@) of the XmlTree
+--
+-- - 2.parameter doc : the document subset of the XmlTree
+--
+-- - returns : a list of errors
+
+transform::XmlTree->XmlTree->XmlTrees
+transformdtdPartdom
+=traverseTreetransTabledom
+where
+transTable={-# SCC "buildAllTransFcts" #-}buildAllTransformationFunctionsdtdPart
+
+
+
+-- |
+-- Traverse the XmlTree in preorder.
+--
+-- * 1.parameter transEnv : lookup-table which maps element names to their transformation functions
+--
+-- - returns : the whole transformed document
+
+traverseTree::TransEnvTable->XmlFilter
+traverseTreetransEnvn@(NTree(XTagname_)cs)
+=replaceChildren(concatMap(traverseTreetransEnv)cs)(head(transFctn))
+where
+transFct=case(lookup(qualifiedNamename)transEnv)of
+Nothing->this-- element not in DTD, can't be transformed
+Justf->f
+
+traverseTree_n=[n]
+
+
+-- |
+-- Build all transformation functions.
+--
+-- * 1.parameter dtdPart : the DTD subset, root node should be of type @DOCTYPE@
+--
+-- - returns : lookup-table which maps element names to their transformation functions
+
+buildAllTransformationFunctions::XmlTree->TransEnvTable
+buildAllTransformationFunctionsdtdPart
+=buildTransRoot
+:
+-- construct the list of filters
+map(buildTransformationFunctionsdtdNodes)(isElement$$dtdNodes)
+where
+dtdNodes=getChildrendtdPart
+
+
+-- |
+-- Build a transformation function for the document root. By root @\/@
+-- is meant, which is the topmost dummy created by the parser. This function is only a
+-- dummy, too.
+--
+-- * returns : entry for the lookup-table
+
+buildTransRoot::TransEnv
+buildTransRoot=(t_root,this)
+
+
+
+-- |
+-- Build transformation functions for an element.
+--
+-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
+--
+-- * 1.parameter nd : element declaration for which the transformation functions are
+-- created
+--
+-- - returns : entry for the lookup-table
+
+buildTransformationFunctions::XmlTrees->XmlTree->TransEnv
+
+buildTransformationFunctionsdtdPartn@(NTree(XDTDELEMENTal)_)
+=(name,transFct)
+where
+name=lookup1a_nameal
+transFct=lexicographicAttributeOrder
+`o`
+normalizeAttributeValuesndtdPart
+`o`
+setDefaultAttributeValuesndtdPart
+
+buildTransformationFunctions_n
+=error("buildTransformationFunctions: illegeal parameter:\n"++shown)
+
+
+
+-- ------------------------------------------------------------
+
+
+-- |
+-- Sort the attributes of an element in lexicographic order.
+--
+-- * returns : a function which takes an element (XTag), sorts its
+-- attributes in lexicographic order and returns the changed element
+
+lexicographicAttributeOrder::XmlFilter
+lexicographicAttributeOrder
+=processAttrlsortAttrl
+where
+sortAttrlal
+=map(al!!)ixs
+where
+ns=mapnameOfal
+ixs=mapsnd.sort.zipns$[(0::Int)..]
+
+-- |
+-- Normalize attribute values.
+--
+-- * returns : a function which takes an element (XTag), normalizes its
+-- attribute values and returns the changed element
+
+normalizeAttributeValues::XmlTree->XmlTrees->XmlFilter
+normalizeAttributeValueselemDescr@(NTree(XDTDELEMENT_)_)dtdPart
+=processAttrnormalizeAttr
+where
+elemName=valueOfDTDa_nameelemDescr
+declaredAtts=isAttlistOfElementelemName$$dtdPart
+
+normalizeAttr::XmlFilter
+normalizeAttratt
+=normalizeAttrValue(ifnullattDescr
+thenNothing
+elseJust(headattDescr))att
+where
+attDescr=filter(\x->(valueOfDTDa_valuex)==nameOfatt)declaredAtts
+
+normalizeAttrValue::MaybeXmlTree->XmlFilter
+normalizeAttrValuedescr
+=modifyChildren((modifyText(normalizeAttributeValuedescr)$$).xmlTreesToText)
+
+normalizeAttributeValuesn_
+=error("normalizeAttributeValues: illegeal parameter:\n"++shown)
+
+
+
+-- |
+-- Set default attribute values if they are not set.
+--
+-- * returns : a function which takes an element (XTag), adds missing attribute
+-- defaults and returns the changed element
+
+setDefaultAttributeValues::XmlTree->XmlTrees->XmlFilter
+setDefaultAttributeValueselemDescr@(NTree(XDTDELEMENT_)_)dtdPart
+=seqF(mapsetDefaultdefaultAtts)
+where
+-- select the element name from the dtd
+elemName=valueOfDTDa_nameelemDescr
+
+defaultAtts=(isFixedAttrKind-- select attributes with default values
+`orElse`
+isDefaultAttrKind
+)
+$$
+(isAttlistOfElementelemName$$dtdPart)
+
+setDefault::XmlTree->XmlFilter
+setDefaultattrDescr-- add the default attributes
+=(addAttrattNamedefaultValue-- to tag nodes with missing attributes
+`whenNot`
+hasAttrattName
+)
+`when`
+isXTag
+where
+attName=valueOfDTDa_valueattrDescr
+defaultValue=valueOfDTDa_defaultattrDescr
+
+
+setDefaultAttributeValuesn_
+=error("setDefaultAttributeValues: illegeal parameter:\n"++shown)
+
+
+
-- |
+-- This module provides functions for validating XML Documents represented as
+-- XmlTree.
+
+-- Unlike other popular XML validation tools the validation process returns
+-- a list of errors instead of aborting after the first error was found.
+
+
+-- Before the document is validated, a lookup-table is build on the basis of
+-- the DTD which maps element names to their validation functions.
+-- After this initialization phase the whole document is traversed in preorder
+-- and every element is validated by the XmlFilter from the lookup-table.
+
+-- Special namings in source code:
+--
+-- - nd - XDTD node
+--
+-- - n - XTag node
+--
+-- Author : .\\artin Schmidt
+
+moduleText.XML.HXT.Validator.DocValidation
+(validateDoc
+)
+where
+
+importText.XML.HXT.DOM.XmlTree
+
+importText.XML.HXT.Validator.AttributeValueValidation
+importText.XML.HXT.Validator.XmlRE
+
+importData.Maybe
+
+-- |
+-- Lookup-table which maps element names to their validation functions. The
+-- validation functions are XmlFilters.
+
+typeValiEnvTable=[ValiEnv]
+typeValiEnv=(ElemName,ValFct)
+typeElemName=String
+typeValFct=XmlFilter
+
+
+
+-- ------------------------------------------------------------
+
+
+-- |
+-- Validate a document.
+--
+-- * 1.parameter dtdPart : the DTD subset (Node @DOCTYPE@) of the XmlTree
+--
+-- - 2.parameter doc : the document subset of the XmlTree
+--
+-- - returns : a list of errors
+
+validateDoc::XmlTree->XmlTree->XmlTrees
+validateDocdtdPartdoc
+=traverseTreevalTabledoc
+where
+valTable={-# SCC "buildAllValFcts" #-}buildAllValidationFunctionsdtdPart
+
+
+-- |
+-- Traverse the XmlTree in preorder.
+--
+-- * 1.parameter valiEnv : lookup-table which maps element names to their validation functions
+--
+-- - returns : list of errors
+
+traverseTree::ValiEnvTable->XmlFilter
+traverseTreevaliEnvn@(NTree(XTagname_)cs)
+=(valFctn)++concatMap(traverseTreevaliEnv)cs
+where
+valFct::XmlFilter
+valFct
+=case(lookup(qualifiedNamename)valiEnv)of
+Nothing->err("Element "++show(qualifiedNamename)++" not declared in DTD.")
+Justf->f
+
+traverseTree__=[]
+
+
+
+-- ------------------------------------------------------------
+
+
+-- |
+-- Build all validation functions.
+--
+-- * 1.parameter dtdPart : DTD subset, root node should be of type @DOCTYPE@
+--
+-- - returns : lookup-table which maps element names to their validation functions
+
+buildAllValidationFunctions::XmlTree->ValiEnvTable
+buildAllValidationFunctionsdtdPart
+=buildValidateRootdtdPart
+:
+-- construct a list of validation filters for all element declarations
+map(buildValidateFunctionsdtdNodes)(isElement$$dtdNodes)
+where
+dtdNodes=getChildrendtdPart
+
+
+-- |
+-- Build a validation function for the document root. By root node @\/@
+-- is meant, which is the topmost dummy created by the parser.
+--
+-- * 1.parameter dtdPart : DTD subset, root node should be of type @DOCTYPE@
+--
+-- - returns : entry for the lookup-table
+
+buildValidateRoot::XmlTree->ValiEnv
+buildValidateRoot(NTree(XDTDDOCTYPEal)_)
+=(t_root,valFct)
+where
+name=lookup1a_nameal
+
+valFct::XmlFilter
+valFctnd@(NTree(XTag__)cs)
+=ifmsg==""
+then[]
+elseerr("Root Element must be "++showname++". "++msg)nd
+where
+re=re_sym(name)
+msg=checkRE(matchesrecs)
+
+valFctn=error("buildValidateRoot: illegeal parameter:\n"++shown)
+
+buildValidateRootnd
+=error("buildValidateRoot: illegeal parameter:\n"++shownd)
+
+
+-- |
+-- Build validation functions for an element.
+--
+-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
+--
+-- - 2.parameter nd : element declaration for which the validation functions are
+-- created
+--
+-- - returns : entry for the lookup-table
+
+buildValidateFunctions::XmlTrees->XmlTree->ValiEnv
+
+buildValidateFunctionsdtdPartnd@(NTree(XDTDELEMENTal)_)
+=(elemName,valFct)
+where
+elemName=lookup1a_nameal
+
+valFct::XmlFilter
+valFct=buildContentValidationnd
++++
+buildAttributeValidationdtdPartnd
+
+buildValidateFunctions_nd
+=error("buildValidateFunctions: illegeal parameter:\n"++shownd)
+
+
+-- ------------------------------------------------------------
+
+
+-- |
+-- Build validation functions for the content model of an element.
+-- Validity constraint: Element Valid (3 \/ p.18 in Spec)
+--
+-- * 1.parameter nd : element declaration for which the content validation functions
+-- are built
+--
+-- - returns : a function which takes an element (XTag), checks if its
+-- children match its content model and returns a list of errors
+
+buildContentValidation::XmlTree->XmlFilter
+buildContentValidationnd@(NTree(XDTDELEMENTal)_)
+=contentValidationattrTypend
+where
+attrType=lookup1a_typeal
+
+
+-- Delegates construction of the validation function on the basis of the
+-- content model type
+contentValidation::String->XmlTree->XmlFilter
+contentValidationtyp(NTree(XDTDELEMENT_)cs)
+|typ==k_pcdata=contentValidationPcdata
+|typ==k_empty=contentValidationEmpty
+|typ==k_any=contentValidationAny
+|typ==v_children=contentValidationChildrencs
+|typ==v_mixed=contentValidationMixedcs
+|otherwise=error("contentValidation: unknown type: "++showtyp)
+
+contentValidation_nd'
+=error("contentValidation: illegeal parameter:\n"++shownd')
+
+
+-- Checks #PCDATA content models
+contentValidationPcdata::XmlFilter
+contentValidationPcdatan@(NTree(XTagname_)cs)
+=ifmsg==""
+then[]
+elseerr("The content of element "++show(qualifiedNamename)++
+" must match (#PCDATA). "++msg)n
+where
+re=re_rep(re_symk_pcdata)
+msg=checkRE(matchesrecs)
+
+contentValidationPcdatan
+=error("contentValidationPcdata: illegeal parameter:\n"++shown)
+
+
+-- Checks EMPTY content models
+contentValidationEmpty::XmlFilter
+contentValidationEmptyn@(NTree(XTagname_)cs)
+=ifmsg==""
+then[]
+elseerr("The content of element "++show(qualifiedNamename)++
+" must match EMPTY. "++msg)n
+where
+re=re_unit
+msg=checkRE(matchesrecs)
+
+contentValidationEmptyn
+=error("contentValidationEmpty: illegeal parameter:\n"++shown)
+
+
+-- Checks ANY content models
+contentValidationAny::XmlFilter
+contentValidationAnyn@(NTree(XTagname_)cs)
+=ifmsg==""
+then[]
+elseerr("The content of element "++show(qualifiedNamename)++
+" must match ANY. "++msg)n
+where
+re=re_rep(re_dot)
+msg=checkRE(matchesrecs)
+
+contentValidationAnyn
+=error("contentValidationAny: illegeal parameter:\n"++shown)
+
+
+-- Checks "children" content models
+contentValidationChildren::XmlTrees->XmlFilter
+contentValidationChildrencmn@(NTree(XTagname_)cs)
+=ifmsg==""
+then[]
+elseerr("The content of element "++show(qualifiedNamename)++
+" must match "++printREre++". "++msg)n
+where
+re=createRE(headcm)
+msg=checkRE(matchesrecs)
+
+contentValidationChildren_n
+=error("contentValidationChildren: illegeal parameter:\n"++shown)
+
+
+-- Checks "mixed content" content models
+contentValidationMixed::XmlTrees->XmlFilter
+contentValidationMixedcmn@(NTree(XTagname_)cs)
+=ifmsg==""
+then[]
+elseerr("The content of element "++show(qualifiedNamename)++
+" must match "++printREre++". "++msg)n
+where
+re=re_rep(re_alt(re_symk_pcdata)(createRE(headcm)))
+msg=checkRE(matchesrecs)
+
+contentValidationMixed_n
+=error("contentValidationMixed: illegeal parameter:\n"++shown)
+
+
+buildContentValidationnd
+=error("buildContentValidation: illegeal parameter:\n"++shownd)
+
+
+
+-- |
+-- Build a regular expression from the content model. The regular expression
+-- is provided by the module XmlRE.
+--
+-- * 1.parameter nd : node of the content model. Expected: @CONTENT@ or
+-- @NAME@
+--
+-- - returns : regular expression of the content model
+
+createRE::XmlTree->REString
+createRE(NTree(XDTDCONTENTal)cs)
+=processModifiermodifier
+where
+modifier=lookup1a_modifieral
+kind=lookup1a_kindal
+
+processModifier::String->REString
+processModifierm
+|m==v_plus=re_plus(processKindkind)
+|m==v_star=re_rep(processKindkind)
+|m==v_option=re_opt(processKindkind)
+|m==v_null=processKindkind
+|otherwise=error("Unknown modifier: "++showm)
+
+processKind::String->REString
+processKindk
+|k==v_seq=makeSequencecs
+|k==v_choice=makeChoicecs
+|otherwise=error("Unknown kind: "++showk)
+
+makeSequence::XmlTrees->REString
+makeSequence[]=re_unit
+makeSequence(x:xs)=re_seq(createREx)(makeSequencexs)
+
+makeChoice::XmlTrees->REString
+makeChoice[]=re_zero""
+makeChoice(x:xs)=re_alt(createREx)(makeChoicexs)
+
+createRE(NTree(XDTDNAMEal)_)
+=re_sym(lookup1a_nameal)
+
+createREnd
+=error("createRE: illegeal parameter:\n"++shownd)
+
+
+
+-- ------------------------------------------------------------
+
+
+
+-- |
+-- Build validation functions for the attributes of an element.
+--
+-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
+--
+-- - 2.parameter nd : element declaration for which the attribute validation functions
+-- are created
+--
+-- - returns : a function which takes an element (XTag), checks if its
+-- attributes are valid and returns a list of errors
+
+buildAttributeValidation::XmlTrees->XmlTree->XmlFilter
+buildAttributeValidationdtdPartnd=
+noDoublicateAttributes
++++
+checkNotDeclardAttributesattrDeclsnd
++++
+checkRequiredAttributesattrDeclsnd
++++
+checkFixedAttributesattrDeclsnd
++++
+checkValuesOfAttributesattrDeclsdtdPartnd
+where
+attrDecls=isAttlist$$dtdPart
+
+
+-- |
+-- Validate that all attributes of an element are unique.
+-- Well-formdness constraint: Unique AttSpec (3.1 \/ p.19 in Spec)
+--
+-- - returns : a function which takes an element (XTag), checks if its
+-- attributes are unique and returns a list of errors
+
+noDoublicateAttributes::XmlFilter
+noDoublicateAttributesn@(NTree(XTag__)_)
+=doubles.reverse$names
+where
+tagname=nameOfn
+names=mapnameOf.getAttrl$n
+
+doubles::[String]->XmlTrees
+doubles[]
+=[]
+doubles(n1:ns)
+=(ifn1`elem`ns
+thenerr("Attribute "++shown1++" was already specified for element "++showtagname++".")n
+else[]
+)++doublesns
+
+noDoublicateAttributesn
+=error("noDoublicateAttributes: illegeal parameter:\n"++shown)
+
+
+-- |
+-- Validate that all \#REQUIRED attributes are provided.
+-- Validity constraint: Required Attributes (3.3.2 \/ p.28 in Spec)
+--
+-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
+--
+-- - 2.parameter nd : element declaration which attributes have to be checked
+--
+-- - returns : a function which takes an element (XTag), checks if all
+-- required attributes are provided and returns a list of errors
+
+checkRequiredAttributes::XmlTrees->XmlTree->XmlFilter
+checkRequiredAttributesattrDecls(NTree(XDTDELEMENTal)_)
+=checkRequiredrequiredAtts
+where
+elemName=lookup1a_nameal
+requiredAtts=isRequiredAttrKind$$(isAttlistOfElementelemName$$attrDecls)
+
+
+checkRequired::XmlTrees->XmlFilter
+checkRequired((NTree(XDTDATTLISTal')_):xs)n@(NTree(XTagname_)_)
+=ifsatisfies(hasAttrattName)n
+thencheckRequiredxsn
+elseerr("Attribute "++showattName++" must be declared for element type "++
+show(qualifiedNamename)++".")n
+++
+checkRequiredxsn
+where
+attName=lookup1a_valueal'
+
+checkRequired[]_=[]
+
+checkRequiredndn
+=error("checkRequired: illegeal parameter:\n"++shownd++shown)
+
+
+checkRequiredAttributes_nd
+=error("checkRequiredAttributes: illegeal parameter:\n"++shownd)
+
+
+
+-- |
+-- Validate that \#FIXED attributes match the default value.
+-- Validity constraint: Fixed Attribute Default (3.3.2 \/ p.28 in Spec)
+--
+-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
+--
+-- - 2.parameter nd : element declaration which attributes have to be checked
+--
+-- - returns : a function which takes an element (XTag), checks if all
+-- fixed attributes match the default value and returns a list of errors
+
+checkFixedAttributes::XmlTrees->XmlTree->XmlFilter
+checkFixedAttributesattrDecls(NTree(XDTDELEMENTal)_)
+=checkFixedfixedAtts
+where
+elemName=lookup1a_nameal
+fixedAtts=isFixedAttrKind$$(isAttlistOfElementelemName$$attrDecls)
+
+
+checkFixed::XmlTrees->XmlFilter
+checkFixed(x@(NTree(XDTDATTLISTal')_):xs)n@(NTree(XTagname_)_)
+=ifsatisfies(hasAttrattName)n
+thenifattValue==fixedValue
+thencheckFixedxsn
+elseerr("Attribute "++showattName++" of element "++show(qualifiedNamename)++
+" with value "++showattValue++" must have a value of "++
+showfixedValue++".")n
+++
+checkFixedxsn
+elsecheckFixedxsn
+where
+attName=lookup1a_valueal'
+fixedValue=normalizeAttributeValue(Justx)(lookup1a_defaultal')
+attValue=normalizeAttributeValue(Justx)(valueOfattNamen)
+
+checkFixed[]_=[]
+
+checkFixedndn
+=error("checkFixed: illegeal parameter:\n"++shownd++shown)
+
+
+checkFixedAttributes_nd
+=error("checkFixedAttributes: illegeal parameter:\n"++shownd)
+
+
+-- |
+-- Validate that an element has no attributes which are not declared.
+-- Validity constraint: Attribute Value Type (3.1 \/ p.19 in Spec)
+--
+-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
+--
+-- - 2.parameter nd : element declaration which attributes have to be checked
+--
+-- - returns : a function which takes an element (XTag), checks if all
+-- attributes are declared and returns a list of errors
+
+checkNotDeclardAttributes::XmlTrees->XmlTree->XmlFilter
+checkNotDeclardAttributesattrDeclselemDescr
+=checkNotDeclared
+where
+elemName=valueOfDTDa_nameelemDescr
+decls=isAttlistOfElementelemName$$attrDecls
+
+checkNotDeclared::XmlFilter
+checkNotDeclaredn
+=(isXTag
+`guards`
+cat(map(searchForDeclaredAttelemNamedecls)(getAttrln))
+)n
+
+searchForDeclaredAtt::String->XmlTrees->XmlTree->XmlFilter
+searchForDeclaredAttname((NTree(XDTDATTLISTal')_):xs)att
+=if(lookup1a_valueal')==nameOfatt
+thennone
+elsesearchForDeclaredAttnamexsatt
+
+searchForDeclaredAttname[](NTree(XAttrattrName)_)
+=err("Attribute "++show(qualifiedNameattrName)++" of element "++showname++" is not declared in DTD.")
+
+searchForDeclaredAtt_nda
+=error("searchForDeclaredAtt: illegeal paramter:\n"++shownd++showa)
+
+-- |
+-- Validate that the attribute value meets the lexical constraints of its type.
+-- Validity constaint: Attribute Value Type (3.1 \/ p.19 in Spec)
+--
+-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
+--
+-- - 2.parameter nd : element declaration which attributes have to be checked
+--
+-- - returns : a function which takes an element (XTag), checks if all
+-- attributes meet the lexical constraints and returns a list of errors
+
+checkValuesOfAttributes::XmlTrees->XmlTrees->XmlTree->XmlFilter
+checkValuesOfAttributesattrDeclsdtdPartelemDescr
+=checkValues
+where
+elemName=valueOfDTDa_nameelemDescr
+decls=isAttlistOfElementelemName$$attrDecls
+
+checkValues::XmlFilter
+checkValuesn
+=(isXTag
+`guards`
+cat(map(checkValuedecls)(getAttrln))
+)n
+
+checkValue::XmlTrees->XmlTree->XmlFilter
+checkValue(attrDecl@(NTree(XDTDATTLISTal')_):xs)att
+=if(lookup1a_valueal')==nameOfatt
+thencheckAttributeValuedtdPartattrDecl
+elsecheckValuexsatt
+
+checkValue[]_
+=none-- undeclared attribute, reported by separate function
+
+checkValuen_
+=error("checkValue: illegeal parameter:\n"++shown)
+
+
-- |
+-- This module provides functions for checking special ID/IDREF/IDREFS constraints.
+
+-- Checking special ID/IDREF/IDREFS constraints means:
+--
+-- - checking that all ID values are unique.
+--
+-- - checking that all IDREF/IDREFS values match the value of some ID attribute
+--
+
+
+-- ID-Validation should be started before or after validating the document.
+
+
+-- First all nodes with ID attributes are collected from the document, then
+-- it is validated that values of ID attributes do not occure more than once.
+-- During a second iteration over the document it is validated that there exists
+-- an ID attribute value for IDREF/IDREFS attribute values.
+
+-- Special namings in source code:
+--
+-- - nd - XDTD node
+--
+-- - n - XTag node
+--
+-- Author : .\\artin Schmidt
+
+moduleText.XML.HXT.Validator.IdValidation
+(validateIds
+)
+where
+
+
+importText.XML.HXT.DOM.XmlTree
+importText.XML.HXT.Validator.AttributeValueValidation
+
+
+
+-- |
+-- Lookup-table which maps element names to their validation functions. The
+-- validation functions are XmlFilters.
+
+typeIdEnvTable=[IdEnv]
+typeIdEnv=(ElemName,IdFct)
+typeElemName=String
+typeIdFct=XmlFilter
+
+
+
+-- |
+-- Perform the validation of the ID/IDREF/IDREFS constraints.
+--
+-- * 1.parameter dtdPart : the DTD subset (Node @DOCTYPE@) of the XmlTree
+--
+-- - 2.parameter doc : the document subset of the XmlTree
+--
+-- - returns : a list of errors
+
+validateIds::XmlTree->XmlTree->XmlTrees
+validateIdsdtdPartdoc
+={-# SCC "checkForUniqueIds" #-}checkForUniqueIdsidNodeListdtdNodes
+++
+{-# SCC "checkIdReferences" #-}checkIdReferencesidRefEnvdoc
+where
+idEnv=buildIdCollectorFctsdtdNodes
+idRefEnv=buildIdrefValidationFctsdtdNodesidNodeList
+idNodeList=traverseTreeidEnvdoc
+dtdNodes=getChildrendtdPart
+
+
+-- |
+-- Traverse the XmlTree in preorder.
+--
+-- * 1.parameter idEnv : lookup-table which maps element names to their validation functions
+--
+-- - returns : list of errors
+
+traverseTree::IdEnvTable->XmlFilter
+traverseTreeidEnvn@(NTree(XTagname_)cs)
+=(idFctn)++concatMap(traverseTreeidEnv)cs
+where
+idFct::XmlFilter
+idFct
+=case(lookup(qualifiedNamename)idEnv)of
+Nothing->none
+Justf->f
+
+traverseTree__=[]
+
+
+
+-- |
+-- Returns the value of an element's ID attribute. The attribute name has to be
+-- retrieved first from the DTD.
+--
+-- * 1.parameter dtdPart : list of ID attribute definitions from the DTD
+--
+-- - 2.parameter n : element which ID attribute value should be returned
+--
+-- - returns : normalized value of the ID attribute
+
+getIdValue::XmlTrees->XmlTree->String
+getIdValue(x@(NTree(XDTDATTLISTal)_):xs)n@(NTree(XTagname_al')_)
+=if(qualifiedNamename)==elemName
+thenattrValue
+elsegetIdValuexsn
+where
+elemName=lookup1a_nameal
+attrName=lookup1a_valueal
+attrValue=normalizeAttributeValue(Justx)(valueOfattrNamen)
+
+getIdValue__=""
+
+
+
+-- ------------------------------------------------------------
+
+
+-- |
+-- Build collector functions which return XTag nodes with ID attributes from
+-- a document.
+--
+-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
+--
+-- - returns : lookup-table which maps element names to their collector function
+
+buildIdCollectorFcts::XmlTrees->IdEnvTable
+buildIdCollectorFctsdtdPart
+=map(buildIdCollectorFct)(isIdAttrType$$dtdPart)
+where
+buildIdCollectorFct::XmlTree->IdEnv
+buildIdCollectorFct(NTree(XDTDATTLISTal)_)
+=(elemName,hasAttrattrName)
+where
+elemName=lookup1a_nameal
+attrName=lookup1a_valueal
+
+buildIdCollectorFctnd
+=error("buildIdCollectorFct: illegeal parameter:\n"++shownd)
+
+
+-- |
+-- Build validation functions for checking if IDREF\/IDREFS values match a value
+-- of some ID attributes.
+--
+-- * 1.parameter dtdPart : the children of the @DOCTYPE@ node
+--
+-- - 2.parameter idNodeList : list of all XTag nodes with ID attributes
+--
+-- - returns : lookup-table which maps element names to their validation function
+
+buildIdrefValidationFcts::XmlTrees->XmlTrees->IdEnvTable
+buildIdrefValidationFctsdtdPartidNodeList
+=mapbuildElemValidationFctelements
+where
+elements=isElement$$dtdPart
+idValueList=getIdValues(isIdAttrType$$dtdPart)
+
+getIdValues::XmlTrees->[String]
+getIdValuesidAttrTypes
+=map(getIdValueidAttrTypes)idNodeList
+
+
+buildElemValidationFct::XmlTree->IdEnv
+buildElemValidationFct(NTree(XDTDELEMENTal)_)
+=(elemName,buildIdrefValidationFctidRefAttrTypes)
+where
+elemName=lookup1a_nameal
+idRefAttrTypes=isIdRefAttrType$$(isAttlistOfElementelemName)$$dtdPart
+
+buildElemValidationFctnd
+=error("buildIdrefValidationFct: illegeal parameter:\n"++shownd)
+
+
+buildIdrefValidationFct::XmlTrees->XmlFilter
+buildIdrefValidationFct(nd@(NTree(XDTDATTLISTal)_):xs)
+=checkIdref+++buildIdrefValidationFctxs
+where
+attrName=lookup1a_valueal
+attrType=lookup1a_typeal
+
+checkIdref::XmlFilter
+checkIdrefn@(NTree(XTagname_)_)
+=ifsatisfies(hasAttrattrName)n
+thenifattrType==k_idref
+thencheckValueDeclarednattrValue
+elseletvalueList=wordsattrValue
+inifnullvalueList
+thenerr("Attribute "++showattrName++
+" of Element "++show(qualifiedNamename)++
+" must have at least one name.")n
+elseconcatMap(checkValueDeclaredn)(wordsattrValue)
+else[]
+where
+attrValue=normalizeAttributeValue(Justnd)(valueOfattrNamen)
+
+checkIdref_=[]
+
+
+checkValueDeclared::XmlTree->String->XmlTrees
+checkValueDeclaredn@(NTree(XTag__)_)attrValue
+=ifattrValue`elem`idValueList
+then[]
+elseerr("An Element with identifier "++showattrValue++
+" must appear in the document.")n
+
+checkValueDeclared__=[]
+
+buildIdrefValidationFct[]
+=none
+
+buildIdrefValidationFctnd
+=error("buildIdCollectorFct: illegeal parameter:\n"++shownd)
+
+
+-- ------------------------------------------------------------
+
+
+-- |
+-- Validate that all ID values are unique within a document.
+-- Validity constraint: ID (3.3.1 \/p. 25 in Spec)
+--
+-- * 1.parameter idNodeList : list of all XTag nodes with ID attributes
+--
+-- - 2.parameter dtdPart : the children of the @DOCTYPE@ node
+--
+-- - returns : a list of errors
+
+checkForUniqueIds::XmlTrees->XmlTrees->XmlTrees
+checkForUniqueIdsidNodeListdtdPart
+=checkForUniqueIdidNodeList[]
+where
+idAttrTypes=isIdAttrType$$dtdPart
+
+checkForUniqueId::XmlTrees->[String]->XmlTrees
+checkForUniqueId(x@(NTree(XTagname_)_):xs)used
+=ifattrValue`elem`used
+thenerr("Attribute value "++showattrValue++" of type ID for element "++
+show(qualifiedNamename)++" must be unique within the document.")x
+++
+checkForUniqueIdxsused
+
+elsecheckForUniqueIdxs(attrValue:used)
+where
+attrValue=getIdValue(isAttlistOfElement(qualifiedNamename)$$idAttrTypes)x
+
+checkForUniqueId__=[]
+
+
+
+-- |
+-- Validate that all IDREF\/IDREFS values match the value of some ID attribute.
+-- Validity constraint: IDREF (3.3.1 \/ p.26 in Spec)
+--
+-- * 1.parameter idRefEnv : lookup-table which maps element names to their validation function
+--
+-- - 2.parameter doc : the document to validate
+--
+-- - returns : a list of errors
+
+checkIdReferences::IdEnvTable->XmlTree->XmlTrees
+checkIdReferencesidRefEnvdoc
+=traverseTreeidRefEnvdoc
+
+
+
+
+
+
-- |
+-- A module for regular expression matching based on derivatives of regular expressions.
+--
+-- The code was taken from Joe English (<http://www.flightlab.com/~joe/sgml/validate.html>).
+-- Tested and extended by Martin Schmidt.
+--
+-- Further references for the algorithm:
+--
+-- Janusz A. Brzozowski.
+--
+-- Derivatives of Regular Expressions. Journal of the ACM, Volume 11, Issue 4, 1964.
+--
+-- Mark Hopkins.
+--
+-- Regular Expression Package. Posted to comp.compilers, 1994.
+-- Available per FTP at <ftp://iecc.com/pub/file/regex.tar.gz>.
+
+
+
+moduleText.XML.HXT.Validator.RE
+(RE(..)
+
+,re_unit
+,re_zero
+,re_sym
+,re_rep
+,re_plus
+,re_opt
+,re_seq
+,re_alt
+,re_dot
+
+,checkRE
+,matches
+,nullable
+,printRE
+)
+where
+
+-- |
+-- Data type for regular expressions.
+
+dataREa=
+RE_ZEROString--' L(0) = {} (empty set)
+|RE_UNIT--' L(1) = { [] } (empty sequence)
+|RE_SYMa--' L(x) = { [x] }
+|RE_DOT--' accept any single symbol
+|RE_REP(REa)--' L(e*) = { [] } `union` L(e+)
+|RE_PLUS(REa)--' L(e+) = { x ++ y | x <- L(e), y <- L(e*) }
+|RE_OPT(REa)--' L(e?) = L(e) `union` { [] }
+|RE_SEQ(REa)(REa)--' L(e,f) = { x ++ y | x <- L(e), y <- L(f) }
+|RE_ALT(REa)(REa)--' L(e|f) = L(e) `union` L(f)
+deriving(Show,Eq)
+
+
+
+-- ------------------------------------------------------------
+-- Constructor functions to simplify regular expressions when constructing them.
+
+-- |
+-- Constructs a regular expression for an empty set.
+--
+-- * 1.parameter errMsg : error message
+--
+-- - returns : regular expression for an empty set
+
+re_zero::String->REa
+re_zerom=RE_ZEROm
+
+
+-- |
+-- Constructs a regular expression for an empty sequence.
+--
+-- - returns : regular expression for an empty sequence
+
+re_unit::REa
+re_unit=RE_UNIT
+
+
+-- |
+-- Constructs a regular expression for accepting a symbol
+--
+-- * 1.parameter sym : the symbol to be accepted
+--
+-- - returns : regular expression for accepting a symbol
+
+re_sym::a->REa
+re_symx=RE_SYMx
+
+
+-- |
+-- Constructs a regular expression for accepting any singel symbol
+--
+-- - returns : regular expression for accepting any singel symbol
+
+re_dot::REa
+re_dot=RE_DOT
+
+
+-- |
+-- Constructs an optional repetition (*) of a regular expression
+--
+-- * 1.parameter re_a : regular expression to be repeted
+--
+-- - returns : new regular expression
+
+re_rep::REa->REa
+re_repRE_UNIT=RE_UNIT
+re_rep(RE_ZERO_)=RE_UNIT
+re_repe@(RE_REP_)=RE_REP(rem_repe)-- remove nested reps
+re_repe@(RE_ALT__)=RE_REP(rem_repe)-- remove nested reps in alternatives
+re_repe=RE_REPe
+
+-- |
+-- remove redundant nested *'s in RE
+-- theoretically this is unneccessary,
+-- but without this simplification the runtime can increase exponentally
+-- when computing deltas, e.g. for a** or (a|b*)* which is the same as (a|b)*
+
+rem_rep::REa->REa
+rem_rep(RE_ALTe1e2)=RE_ALT(rem_repe1)(rem_repe2)
+rem_rep(RE_REPe1)=rem_repe1
+rem_repe1=e1
+
+
+-- |
+-- Constructs a repetition (+) of a regular expression
+--
+-- * 1.parameter re_a : regular expression to be repeted
+--
+-- - returns : new regular expression
+
+re_plus::REa->REa
+re_plusRE_UNIT=RE_UNIT
+re_plus(RE_ZEROm)=RE_ZEROm
+re_pluse=RE_PLUSe
+
+
+-- |
+-- Constructs an option (?) of a regular expression
+--
+-- * 1.parameter re_a : regular expression to be optional
+--
+-- - returns : new regular expression
+
+re_opt::REa->REa
+re_optRE_UNIT=RE_UNIT
+re_opt(RE_ZERO_)=RE_UNIT
+re_opte=RE_OPTe
+
+
+-- |
+-- Constructs a sequence (,) of two regular expressions
+--
+-- * 1.parameter re_a : first regular expression in sequence
+--
+-- - 2.parameter re_b : second regular expression in sequence
+--
+-- - returns : new regular expression
+
+re_seq::REa->REa->REa
+re_seq(RE_ZEROm)_=RE_ZEROm
+re_seqRE_UNITf=f
+re_seq_(RE_ZEROm)=RE_ZEROm
+re_seqeRE_UNIT=e
+re_seqef=RE_SEQef
+
+
+-- |
+-- Constructs an alternative (|) of two regular expressions
+--
+-- * 1.parameter re_a : first regular expression of alternative
+--
+-- - 2.parameter re_b : second regular expression of alternative
+--
+-- - returns : new regular expression
+
+re_alt::REa->REa->REa
+re_alt(RE_ZERO_)f=f
+re_alte(RE_ZERO_)=e
+re_altef=RE_ALTef
+
+
+
+-- ------------------------------------------------------------
+
+
+-- |
+-- Checks if a regular expression matches the empty sequence.
+--
+-- nullable e == [] `in` L(e)
+--
+-- This check indicates if a regular expression fits to a sentence or not.
+--
+-- * 1.parameter re : regular expression to be checked
+--
+-- - returns : true if regular expression matches the empty sequence,
+-- otherwise false
+
+nullable::(Showa)=>REa->Bool
+nullable(RE_ZERO_)=False
+nullableRE_UNIT=True
+nullable(RE_SYM_)=False
+nullable(RE_REP_)=True
+nullable(RE_PLUSe)=nullablee
+nullable(RE_OPT_)=True
+nullable(RE_SEQef)=nullablee&&nullablef
+nullable(RE_ALTef)=nullablee||nullablef
+nullableRE_DOT=False
+
+
+-- |
+-- Derives a regular expression with respect to one symbol.
+--
+-- L(delta e x) = x \ L(e)
+--
+-- * 1.parameter re : regular expression to be derived
+--
+-- - 2.parameter sym : the symbol on which the regular expression is applied
+--
+-- - returns : the derived regular expression
+
+delta::(Eqa,Showa)=>REa->a->REa
+deltarex=casereof
+RE_ZERO_->re-- re_zero m
+RE_UNIT->re_zero("Symbol "++showx++" unexpected.")
+RE_SYMsym
+|x==sym->re_unit
+|otherwise->re_zero("Symbol "++showsym++" expected, but symbol "++showx++" found.")
+RE_REPe->re_seq(deltaex)re-- (re_rep e)
+RE_PLUSe->re_seq(deltaex)(re_repe)
+RE_OPTe->deltaex
+RE_SEQef
+|nullablee->re_alt(re_seq(deltaex)f)(deltafx)
+|otherwise->re_seq(deltaex)f
+RE_ALTef->re_alt(deltaex)(deltafx)
+RE_DOT->re_unit
+
+
+-- |
+-- Derives a regular expression with respect to a sentence.
+--
+-- * 1.parameter re : regular expression
+--
+-- - 2.parameter s : sentence to which the regular expression is applied
+--
+-- - returns : the derived regular expression
+
+matches::(Eqa,Showa)=>REa->[a]->REa
+matchese=foldldeltae
+
+
+-- |
+-- Checks if an input matched a regular expression. The function should be
+-- called after matches.
+--
+-- Was the sentence used in @matches@ in the language of the regular expression?
+-- -> matches e s == s `in` L(e)?
+--
+-- * 1.parameter re : the derived regular expression
+--
+-- - returns : empty String if input matched the regular expression, otherwise
+-- an error message is returned
+
+checkRE::(Showa)=>REa->String
+checkRE(RE_UNIT)=""
+checkRE(RE_ZEROm)=m
+checkREre
+|nullablere=""
+|otherwise="Input must match "++printREre
+
+
+
+-- ------------------------------------------------------------
+
+
+
+-- |
+-- Constructs a string representation of a regular expression.
+--
+-- * 1.parameter re : a regular expression
+--
+-- - returns : the string representation of the regular expression
+
+printRE::(Showa)=>REa->String
+printREre'
+="( "++printRE1re'++" )"
+where
+printRE1::(Showa)=>REa->String
+printRE1re=casereof
+RE_ZEROm->"ERROR: "++m
+RE_UNIT->""
+RE_SYMsym->showsym
+RE_DOT->"."
+RE_REPe
+|isSinglee->printRE1e++"*"
+|otherwise->"("++printRE1e++")*"
+RE_PLUSe
+|isSinglee->printRE1e++"+"
+|otherwise->"("++printRE1e++")+"
+RE_OPTe
+|isSinglee->printRE1e++"?"
+|otherwise->"("++printRE1e++")?"
+RE_SEQef
+|isAlte&¬(isAltf)->"("++printRE1e++") , "++printRE1f
+|not(isAlte)&&isAltf->printRE1e++" , ("++printRE1f++")"
+|isAlte&&isAltf->"("++printRE1e++") , ("++printRE1f++")"
+|otherwise->printRE1e++" , "++printRE1f
+RE_ALTef
+|isSeqe&¬(isSeqf)->"("++printRE1e++") | "++printRE1f
+|not(isSeqe)&&isSeqf->printRE1e++" | ("++printRE1f++")"
+|isSeqe&&isSeqf->"("++printRE1e++") | ("++printRE1f++")"
+|otherwise->printRE1e++" | "++printRE1f
+
+
+isSingle::REa->Bool
+isSingle(RE_ZERO_)=True
+isSingleRE_UNIT=True
+isSingle(RE_SYM_)=True
+isSingle_=False
+
+
+isSeq::REa->Bool
+isSeq(RE_SEQ__)=True
+isSeq_=False
+
+
+isAlt::REa->Bool
+isAlt(RE_ALT__)=True
+isAlt_=False
+
-- |
+-- This module provides a state filter as a main function for validating XML documents.
+--
+-- The real validation is done with pure filters from module 'Text.XML.HXT.Validator.ValidationFilter'
+--
+-- Author : .\\artin Schmidt
+
+moduleText.XML.HXT.Validator.Validation
+(getValidatedDoc
+,moduleText.XML.HXT.Validator.ValidationFilter
+)
+
+where
+
+importText.XML.HXT.DOM.XmlTree
+importText.XML.HXT.DOM.XmlState
+
+importText.XML.HXT.Validator.ValidationFilter
+
+importText.XML.HXT.Parser.XmlOutput
+(traceTree
+,traceSource
+,traceMsg
+)
+
+-- ------------------------------------------------------------
+
+-- |
+-- monadic filter for validating and transforming a wellformed document.
+--
+-- the "main" function for validation.
+--
+-- the input tree must consist of a root node with a complete document and DTD.
+-- Result is the single element list containing same tree but tranformed with respect to the DTD,
+-- or, in case of errors, the root with an empty list of children
+
+getValidatedDoc::XmlStateFilterstate
+getValidatedDoc
+=traceMsg1"validating document"
+.>>
+((runValidation
+.>>
+traceTree
+.>>
+traceSource
+)
+`whenM`(isRoot.>getChildren)
+)
+where
+runValidationt
+=do
+issueError$$<res
+(ifnullerrs
+then(traceMsg1"transforming validated document"
+.>>
+liftMftransform
+)
+elseliftMf(setStatusc_err"validating document")
+)t
+where
+res=validatet
+errs=isXError.>negisWarning$$res
+
+-- ------------------------------------------------------------
+
-- |
+-- This module provides functions for validating XML documents represented as
+-- XmlTree.
+
+-- Unlike other popular XML validation tools the validation functions return
+-- a list of errors instead of aborting after the first error was found.
+--
+-- Note: The validation process has been split into validation and transformation!
+-- If @validate@ did not report any errors, @transform@
+-- should be called, to change the document the way a validating parser
+-- is expected to do.
+
+--
+-- Author : .\\artin Schmidt
+
+moduleText.XML.HXT.Validator.ValidationFilter
+(getDTDSubset
+,validate
+,validateDTD
+,validateDoc
+,removeDoublicateDefs
+,transform
+)
+
+where
+
+importText.XML.HXT.DOM.XmlTree
+
+importqualifiedText.XML.HXT.Validator.DTDValidationasDTDValidation
+importqualifiedText.XML.HXT.Validator.DocValidationasDocValidation
+importqualifiedText.XML.HXT.Validator.IdValidationasIdValidation
+importqualifiedText.XML.HXT.Validator.DocTransformationasDocTransformation
+
+-- |
+-- Main validation filter. Check if the DTD and the document are valid.
+--
+--
+-- - returns : a function which expects a complete document as XmlTree input
+-- and returns a list of all errors found.
+
+validate::XmlFilter
+validate=validateDTD+++validateDoc
+
+-- |
+-- Check if the DTD is valid.
+--
+--
+-- - returns : a function which expects an XmlTree from the parser as input
+-- and returns a list of all errors found in the DTD.
+
+validateDTD::XmlFilter
+validateDTD
+=choice[getDTDSubset
+:->DTDValidation.validateDTD
+,this
+:->err"Can't validate DTD: There is no DOCTYPE declaration in the document."
+]
+-- |
+-- Check if the document corresponds to the given DTD.
+--
+--
+-- - returns : a function which expects a complete document as XmlTree input
+-- and returns a list of all errors found in the content part.
+
+validateDoc::XmlFilter
+validateDoct
+=(ifnulldtds
+thenerr"Can't validate document: There is no DOCTYPE declaration in the document."
+else(DocValidation.validateDocdtdPart
++++
+IdValidation.validateIdsdtdPart
+)
+)$t
+where
+dtds=getDTDSubset.>processBottomUpremoveDoublicateDefs$t
+dtdPart=headdtds
+
+-- |
+-- filter for transforming a document with respect to the given DTD.
+--
+-- Validating parsers
+-- are expected to normalize attribute values and add default values.
+-- This function should be called after a successful validation.
+--
+--
+-- - returns : a function which expects a complete XML document tree
+-- and returns the transformed XmlTree
+
+transform::XmlFilter
+transform
+=choice[isRoot
+:->transformDoc
+,this
+:->fatal"Can't transform document: No document root given"
+]
+where
+transformDoct
+|nulldtds
+=thist
+|otherwise
+=DocTransformation.transform(headdtds)t
+where
+dtds=getDTDSubset.>processBottomUpremoveDoublicateDefs$t
+
+-- |
+-- Removes doublicate declarations from the DTD which first declaration is
+-- binding. This is the case for ATTLIST and ENTITY declarations.
+--
+--
+-- - returns : A function that replaces the children of DOCTYPE nodes by a list
+-- where all multiple declarations are removed.
+
+removeDoublicateDefs::XmlFilter
+removeDoublicateDefs
+=DTDValidation.removeDoublicateDefs
+
+--
+-- selects the DTD part of a document
+-- but only, if there is more than the internal part for the 4 predefined XML entities
+
+getDTDSubset::XmlFilter
+getDTDSubset
+=getChildren.>isDoctype.>hasRootName
+where
+hasRootName=isOf(hasEntrya_name.attrlOfDTD)
+
-- |
+-- A module for regular expression matching, adapted for XML DTDs.
+--
+-- This module is based on the module RE.
+--
+-- Author .\\artin Schmidt
+
+moduleText.XML.HXT.Validator.XmlRE
+(RE
+
+,checkRE
+,matches
+,printRE
+
+,re_unit
+,re_zero
+,re_sym
+,re_rep
+,re_plus
+,re_opt
+,re_seq
+,re_alt
+,re_dot
+)
+where
+
+-- import Debug.Trace(trace)
+
+importText.XML.HXT.Validator.REhiding(matches)
+
+importText.XML.HXT.DOM.XmlTree
+
+importText.XML.HXT.DOM.EditFilters
+(removeComment
+,removeWhiteSpace
+)
+
+-- |
+-- Derives a regular expression with respect to a list of elements.
+--
+-- * 1.parameter re : regular expression
+--
+-- - 2.parameter list : list of elements to which the regular expression is applied
+--
+-- - returns : the derived regular expression
+
+matches::REString->XmlTrees->REString
+matchesrelist
+=foldldeltare(removeUnimportantStuff$$list)
+where
+removeUnimportantStuff::XmlFilter
+removeUnimportantStuff=processBottomUp(removeWhiteSpace`o`removeComment)
+-- trace of growth of REs
+-- delta' re el = delta (trace (("RE : " ++) . (++ "\n" ) . show $ re) re) el
+
+
+-- |
+-- Derives a regular expression with respect to one element.
+--
+-- L(delta e x) = x \ L(e)
+--
+-- * 1.parameter re : regular expression to be derived
+--
+-- - 2.parameter el : the element on which the regular expression is applied
+--
+-- - returns : the derived regular expression
+
+delta::REString->XmlTree->REString
+deltareel
+|not(allowedel)=re
+|otherwise=casereof
+RE_ZEROm->re_zerom
+RE_UNIT->re_zero(elemNameel++" unexpected.")
+RE_SYMsym
+|sym==k_pcdata->letnode=getNodeelin
+if((isXTextNodenode)||(isXCdataNodenode))
+thenre_unit
+elsere_zero("Character data expected, but "++elemNameel++" found.")
+|expectedNodeelsym->re_unit
+|otherwise->re_zero("Element "++showsym++" expected, but "++elemNameel++" found.")
+RE_REPe->re_seq(deltaeel)(re_repe)
+RE_PLUSe->re_seq(deltaeel)(re_repe)
+RE_OPTe->deltaeel
+RE_SEQef
+|nullablee->re_alt(re_seq(deltaeel)f)(deltafel)
+|otherwise->re_seq(deltaeel)f
+RE_ALTef->re_alt(deltaeel)(deltafel)
+RE_DOT->re_unit
+
+where
+expectedNode::XmlTree->String->Bool
+expectedNode(NTree(XTagn_)_)sym=(qualifiedNamen)==sym
+expectedNode__=False
+
+elemName::XmlTree->String
+elemName(NTree(XTagn_)_)="element "++show(qualifiedNamen)
+elemName_="character data"
+
+allowed::XmlTree->Bool
+allowed(NTree(XTag__)_)=True
+allowed(NTree(XText_)_)=True
+allowed(NTree(XCdata_)_)=True
+allowed_=False
+
+
diff --git a/doc/hxt-filter/src/hscolour.css b/doc/hxt-filter/src/hscolour.css
new file mode 100644
--- /dev/null
+++ b/doc/hxt-filter/src/hscolour.css
@@ -0,0 +1,5 @@
+.keyglyph, .layout {color: red;}
+.keyword {color: blue;}
+.comment, .comment a {color: green;}
+.str, .chr {color: teal;}
+.keyword,.conid, .varid, .conop, .varop, .num, .cpp, .sel, .definition {}
diff --git a/examples/Makefile b/examples/Makefile
new file mode 100644
--- /dev/null
+++ b/examples/Makefile
@@ -0,0 +1,40 @@
+# Example Applications
+#
+
+include ../Version.mk
+
+HXT_HOME = ..
+
+EXAMPLES = mini hparser hfilter hunit hsvg dtd2haskell
+MORE_SAMPLES = blutgraetsche photoalbum
+DIST = ../$(DIST_NAME)
+DIST_DIR = $(DIST)/examples
+
+all :
+ if [ -f $(HXT_HOME)/lib/$(SOFTWARE)/package.conf ] ; \
+ then $(MAKE) alllocal ; \
+ else $(MAKE) alldist ; \
+ fi
+
+alllocal :
+ $(foreach i,$(EXAMPLES),$(MAKE) -C $i PKGFLAGS="-ignore-package $(SOFTWARE)-$(LASTVERSION) -package-conf `pwd`/$(HXT_HOME)/lib/$(SOFTWARE)/package.conf -package $(SOFTWARE)" all ;)
+
+alldist :
+ $(foreach i,$(EXAMPLES),$(MAKE) -C $i all ;)
+
+test :
+ $(foreach i,$(EXAMPLES),$(MAKE) -C $i $@ ;)
+
+dist :
+ [ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR)
+ $(foreach i,$(EXAMPLES),$(MAKE) -C $i dist DIST=../$(DIST_DIR);)
+ [ -d $(DIST_DIR)/xhtml ] || mkdir -p $(DIST_DIR)/xhtml
+ cp xhtml/xhtml*.dtd xhtml/xhtml*.ent xhtml/xhtml*.xml $(DIST_DIR)/xhtml
+ cp Makefile $(DIST_DIR)
+
+clean :
+ $(foreach i,$(EXAMPLES),$(MAKE) -C $i $@ ;)
+
+
+.PHONY : all clean test dist
+
diff --git a/examples/dtd2haskell/DTDtoHXT.hs b/examples/dtd2haskell/DTDtoHXT.hs
new file mode 100644
--- /dev/null
+++ b/examples/dtd2haskell/DTDtoHXT.hs
@@ -0,0 +1,434 @@
+-- |
+-- DTDtoHXml - A program for generating access functions for the Haskell XML Toolbox
+-- from a DTD
+--
+-- Author : Uwe Schmidt
+--
+-- Version : $Id: DTDtoHXT.hs,v 1.2 2005/04/14 12:52:51 hxml Exp $
+--
+-- this program may be used as example main program for the
+-- Haskell XML Toolbox
+
+module Main
+where
+
+import Text.XML.HXT.Parser -- import all stuff for parsing, validating, and transforming XML
+
+import System.IO -- import the IO and commandline option stuff
+import System.Environment
+import System.Console.GetOpt
+import System.Exit
+
+import Data.Maybe
+import Data.Char
+import Data.List
+
+-- ------------------------------------------------------------
+
+-- |
+-- the main program
+
+main :: IO ()
+main
+ = do
+ argv <- getArgs -- get the commandline arguments
+ al <- cmdlineOpts argv -- and evaluate them, return a key-value list
+ res <- run' -- build a XML root from the list and start parsing
+ $ getDocumentAndGenerateHaskellCode al emptyRoot
+ exitProg (null res) -- set return code and terminate
+
+-- ------------------------------------------------------------
+
+exitProg :: Bool -> IO a
+exitProg True = exitWith (ExitFailure (-1))
+exitProg False = exitWith ExitSuccess
+
+-- ------------------------------------------------------------
+
+uppercaseInitials, namespaceAware, prefixUnderline :: String
+
+uppercaseInitials = "uppercase-initials"
+namespaceAware = "namespace-aware"
+prefixUnderline = "prefix-underline"
+
+-- ------------------------------------------------------------
+
+generateHXmlToolboxAccessFuntions :: XmlFilter
+generateHXmlToolboxAccessFuntions t
+ = processChildren (isXDTD `guards` genHaskell) t
+ where
+ genHaskell dt
+ = cat
+ [ code [ sepl
+ , "--"
+ , "-- don't edit this module"
+ , "-- generated with " ++ progName
+ , "-- simple access function for Haskell XML Toolbox"
+ , "-- generated from DTD of document: " ++ show source
+ , ""
+ , "module " ++ hsmodul
+ , "where"
+ , ""
+ , "import Text.XML.HXT.DOM.XmlTree (XmlFilter)"
+ , "import qualified Text.XML.HXT.DOM.XmlTree as X hiding (XmlFilter)"
+ ]
+
+ , comm "namespace declarations"
+ , code (map nsType nsPrefixes)
+ , comm ""
+ , code (zipWith nsDef nsPrefixes nsUris)
+
+ , comm "element names (tag names)"
+ , code (map (constNameType maxElemLen "tag") elements)
+ , comm ""
+ , code (map (constNameDef maxElemLen "tag") elements)
+
+ , comm "isTag test filter"
+ , code (map isTagType elements)
+ , comm ""
+ , code (map isTagDef elements)
+
+ , comm "make tag nodes constructor filter"
+ , code (map mkTagType elements)
+ , comm ""
+ , code (map mkTagDef elements)
+
+ , comm "attribute names"
+ , code (map (constNameType maxAttrLen "attr") attributes)
+ , comm ""
+ , code (map (constNameDef maxAttrLen "attr") attributes)
+
+ , comm "get attribute value access filter"
+ , code (map getValueType attributes)
+ , comm ""
+ , code (map getValueDef attributes)
+
+ , comm "has attribute test filter"
+ , code (map hasAttrType attributes)
+ , comm ""
+ , code (map hasAttrDef attributes)
+
+ , comm "make attribute nodes constructor filter for computed attribute values"
+ , code (map mkAttrType attributes)
+ , comm ""
+ , code (map mkAttrDef attributes)
+ , comm "make attribute nodes constructor filter for string attribute values"
+ , code (map mkSAttrType attributes)
+ , comm ""
+ , code (map mkSAttrDef attributes)
+
+ , comm ("end of module " ++ hsmodul)
+
+ ]
+ $ dt
+ where
+ code = txt . concatMap (++ "\n")
+
+ comm cm = code [ "", sepl, "--", "-- " ++ cm, ""] -- generate a headline comment
+
+ sepl = "-- ----------------------------------------"
+
+ nn = trInitial . concatMap nc -- normalize names
+
+ nc c
+ | c `elem` ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" = [c]
+ | c == ':' || c == '-' = "_"
+ | otherwise = ("_" ++) . show . fromEnum $ c
+
+ trInitial str
+ | null str = str
+ | underLn = '_' : str
+ | upperCs = toUpper (head str) : tail str
+ | otherwise = str
+
+ modname = reverse
+ . (\ n -> if '.' `elem` n -- remove extension
+ then drop 1 . dropWhile (/= '.') $ n
+ else n
+ )
+ . takeWhile (/= '/') -- remove dir path
+ . reverse
+
+ maxLen = maximum . (0 :) . map length
+
+ padd n x = take n (x ++ repeat ' ')
+
+ tagPrefix = "tag"
+ attrPrefix = "attr"
+ nsPrefix = "ns"
+
+ tagName n = tagPrefix ++ nn n
+ attName a = attrPrefix ++ nn a
+ nspName n = nsPrefix ++ nn n
+
+ constNameType ln prefix n
+ = prefix ++ padd ln (nn n) ++ " :: String"
+
+ constNameDef ln prefix n
+ = prefix ++ padd ln (nn n) ++ " = " ++ show n
+
+ isTagType n
+ = "is" ++ padd maxElemLen (nn n) ++ " :: XmlFilter"
+
+ isTagDef n
+ = "is" ++ padd maxElemLen (nn n) ++ " = " ++
+ ( either
+ (const ("X.isTag " ++ tagPrefix ++ nn n))
+ (\ (ns, pr, lp)
+ -> "X.isNsTag " ++ ( if null pr
+ then tagName n
+ else show lp
+ ) ++ " " ++ nspName ns
+ )
+ . quName
+ $ n
+ )
+
+ mkTagType n
+ = "t" ++ padd maxElemLen (nn n) ++ " :: XmlFilter"
+
+ mkTagDef n
+ = "t" ++ padd maxElemLen (nn n) ++ " = " ++
+ ( either
+ (const ("X.etag " ++ tagName n))
+ (\ (ns, _pr, _lp)
+ -> "X.mkXNsTag " ++ tagName n ++ " " ++ nspName ns ++ " X.none X.none"
+ )
+ . quName
+ $ n
+ )
+
+ hasAttrType n
+ = "has" ++ padd maxAttrLen (nn n) ++ " :: XmlFilter"
+
+ hasAttrDef n
+ = "has" ++ padd maxAttrLen (nn n) ++ " = " ++
+ ( either
+ (const ("X.hasAttr " ++ attName n))
+ (\ (ns, _pr, lp)
+ -> "X.hasNsAttr " ++ show lp ++ " " ++ nspName ns
+ )
+ . quNameAttr
+ $ n
+ )
+
+ mkAttrType n
+ = "af" ++ padd maxAttrLen (nn n) ++ " :: XmlFilter -> XmlFilter"
+
+ mkAttrDef n
+ = "af" ++ padd maxAttrLen (nn n) ++ " = " ++
+ ( either
+ (const ("X.mkXAttr " ++ attName n))
+ (\ (ns, _pr, _lp)
+ -> "X.mkXNsAttr " ++ attName n ++ " " ++ nspName ns
+ )
+ . quNameAttr
+ $ n
+ )
+
+ mkSAttrType n
+ = "a" ++ padd maxAttrLen (nn n) ++ " :: String -> XmlFilter"
+
+ mkSAttrDef n
+ = "a" ++ padd maxAttrLen (nn n) ++ " = \\ v -> " ++
+ ( either
+ (const ( "X.mkXAttr " ++ attName n ++ " (X.txt v)" ))
+ (\ (ns, _pr, _lp)
+ -> "X.mkXNsAttr " ++ attName n ++ " " ++ nspName ns ++ " (X.txt v)"
+ )
+ . quNameAttr
+ $ n
+ )
+
+ getValueType n
+ = "get" ++ padd maxAttrLen (nn n) ++ " :: XmlFilter"
+
+ getValueDef n
+ = "get" ++ padd maxAttrLen (nn n) ++ " = " ++
+ ( either
+ (const ("X.getValue " ++ attName n))
+ (\ (ns, _pr, lp)
+ -> "X.getNsValue " ++ show lp ++ " " ++ nspName ns
+ )
+ . quNameAttr
+ $ n
+ )
+
+ nsType n
+ = nsPrefix ++ padd maxNsLen (nn n) ++ " :: String"
+
+ nsDef n v
+ = nsPrefix ++ padd maxNsLen (nn n) ++ " = " ++ show v
+
+ source = xshow . getValue a_source $ t
+ modul = modname . xshow . getValue a_output_file $ t
+ root = xshow . (isDoctype .> getDTDValue a_name) $ dt
+ hsmodul
+ | null modul = "DTD" ++ nn root
+ | otherwise = modul
+
+ upperCs = satisfies (hasAttr uppercaseInitials) $ t
+ underLn = satisfies (hasAttr prefixUnderline) $ t
+ nsAware = satisfies (hasAttr namespaceAware) $ t
+
+ elements -- select all element names from dtd
+ = nub
+ . sort
+ . map ( xshow . this)
+ . (deep isElement .> getDTDValue a_name)
+ $ dt
+
+ maxElemLen = maxLen . map nn $ elements
+
+ attributes
+ = nub
+ . sort
+ . map ( xshow . this)
+ . (deep isAttlist .> getDTDValue a_value)
+ $ dt
+
+ maxAttrLen = maxLen . map nn $ attributes
+
+ nsName [] = root
+ nsName n = n
+
+ namespaces
+ = map (\ (n,v) -> (drop 6 n, v))
+ . map (\ t' -> (xshow . getDTDValue a_value $ t', xshow . getDTDValue a_default $ t'))
+ . isNSAttr
+ $ dt
+
+ nsPrefixes = map (nsName . fst) namespaces
+ nsUris = map snd namespaces
+
+ maxNsLen = maxLen . map nn $ nsPrefixes
+
+ quName :: String -> Either String (String, String, String)
+ quName n
+ | not nsAware = Left n
+ | null lp && isNothing defns = Left n
+ | null lp = Right (nsName "", "", pr)
+ | isNothing expns = Left n
+ | otherwise = Right (nsName pr, pr, tail lp)
+ where
+ (pr, lp) = span (/= ':') n
+ defns = lookup "" namespaces
+ expns = lookup pr namespaces
+
+ quNameAttr :: String -> Either String (String, String, String)
+ quNameAttr an
+ | ':' `elem` an = quName an
+ | otherwise = Left an
+
+ isNSAttr :: XmlFilter
+ isNSAttr
+ = deep isAttlist
+ .>
+ ( ( getDTDValue a_value
+ .>
+ isOfText (\ s' -> s' == "xmlns" || "xmlns:" `isPrefixOf` s')
+ )
+ `guards`
+ ( isFixedAttrKind `guards` this)
+ )
+
+-- ------------------------------------------------------------
+
+-- |
+-- the /real/ main program
+--
+-- get wellformed document, validates document, propagates and check namespaces
+-- and controls output
+
+getDocumentAndGenerateHaskellCode :: Attributes -> XmlStateFilter state
+getDocumentAndGenerateHaskellCode al
+ = parseDocument ( al
+ ++
+ [ (a_parse_html, v_0)
+ , (a_canonicalize, v_0)
+ , (a_remove_whitespace, v_0)
+ ]
+ )
+ .>>
+ traceMsg 1 "start processing"
+ .>>
+ liftMf generateHXmlToolboxAccessFuntions
+ .>>
+ traceMsg 1 "processing finished"
+ .>>
+ traceSource
+ .>>
+ traceTree
+ .>>
+ writeDocument [ (a_output_xml, v_0)
+ ]
+ .>>
+ checkStatus
+
+-- ------------------------------------------------------------
+--
+-- the boring option definition and evaluation part
+--
+-- see doc for System.Console.GetOpt
+
+progName :: String
+progName = "DTDtoHXml"
+
+options :: [OptDescr (String, String)]
+options
+ = selectOptions [ a_help
+ ] generalOptions
+ ++
+ selectOptions [ a_trace
+ , a_proxy
+ , a_use_curl
+ , a_options_curl
+ , a_encoding
+ , a_validate
+ , a_check_namespaces
+ ] inputOptions
+ ++
+ selectOptions [ a_output_file
+ ] outputOptions
+ ++
+ [ Option "u" [prefixUnderline] (NoArg (prefixUnderline, v_1)) "separate tag and attribute names with a '_'"
+ , Option "U" [uppercaseInitials] (NoArg (uppercaseInitials, v_1)) "transform the first char of tag and attribute names to uppercase"
+ , Option "N" [namespaceAware] (NoArg (namespaceAware, v_1)) "filter are namespace aware, if namespace attributes occur in the DTD"
+ ]
+ ++
+ showOptions
+
+usage :: [String] -> IO a
+usage errl
+ | null errl
+ = do
+ hPutStrLn stdout use
+ exitProg False
+ | otherwise
+ = do
+ hPutStrLn stderr (concat errl ++ "\n" ++ use)
+ exitProg True
+ where
+ header = "DTDtoHXml - Generation of access function for the Haskell XML Toolbox from a DTD\n" ++
+ "Usage: " ++ progName ++ " [OPTION...] [URI or FILE]"
+ use = usageInfo header options
+
+cmdlineOpts :: [String] -> IO (Attributes)
+cmdlineOpts argv
+ = case (getOpt Permute options argv) of
+ (ol,n,[] )
+ -> do
+ sa <- src n
+ help (lookup a_help ol)
+ return (ol ++ sa)
+ (_,_,errs)
+ -> usage errs
+ where
+ src [] = return [(a_source, "")]
+ src [uri] = return [(a_source, uri)]
+ src _ = usage ["only one input url or file allowed\n"]
+
+ help Nothing = return ()
+ help (Just _) = usage []
+
+-- ------------------------------------------------------------
diff --git a/examples/dtd2haskell/Makefile b/examples/dtd2haskell/Makefile
new file mode 100644
--- /dev/null
+++ b/examples/dtd2haskell/Makefile
@@ -0,0 +1,56 @@
+# $Id: Makefile,v 1.5 2005/04/14 12:52:51 hxml Exp $
+
+HXT_HOME = ../..
+PKGFLAGS =
+GHCFLAGS = -Wall -O2
+GHC = ghc $(GHCFLAGS) $(PKGFLAGS)
+
+prog = ./DTDtoHXT
+
+all : $(prog)
+
+$(prog) : $(prog).hs
+ $(GHC) --make -o $@ $<
+
+force :
+ $(GHC) --make -o $(prog) $(prog).hs
+
+test :
+ @echo "===> run a few generation examples"
+ $(MAKE) XHTML.o XHTML2.o XHTML3.o
+ @echo "===> the generated modules"
+ ls -l XHTML*.hs XHTML*.o
+
+EX1 = ../xhtml/xhtml.xml
+EX2 = ../photoalbum/photos.xml
+
+XHTML.o : $(prog) $(EX1)
+ @echo "===> generate a module for XHTML access function from the XHTML DTD with naming convention is, get, ..."
+ $(prog) --output-file XHTML.hs --uppercase-initials $(EX1)
+ $(GHC) -c XHTML.hs
+
+XHTML2.o : $(prog) $(EX1)
+ @echo "===> generate a module for XHTML access function from the XHTML DTD with naming convention is_, get_, ..."
+ $(prog) --output-file XHTML2.hs --prefix-underline $(EX1)
+ $(GHC) -c XHTML2.hs
+
+XHTML3.o : $(prog) $(EX1)
+ @echo "===> same as test2, but with namespace aware access functions, if xmlns is used in DTD"
+ $(prog) --output-file XHTML3.hs --prefix-underline --namespace-aware $(EX1)
+ $(GHC) -c XHTML3.hs
+
+Photo.hs : $(prog) $(EX2)
+ $(prog) --output-file $@ --uppercase-initials $(EX2)
+
+
+DIST = $(HXT_HOME)/dist/examples
+DIST_DIR = $(DIST)/dtd2haskell
+DIST_FILES = $(prog).hs Makefile
+
+dist :
+ [ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR)
+ cp $(DIST_FILES) $(DIST_DIR)
+
+clean :
+ rm -f $(prog) XHTML*.hs *.o *.hi
+
diff --git a/examples/hfilter/FilterExample.hs b/examples/hfilter/FilterExample.hs
new file mode 100644
--- /dev/null
+++ b/examples/hfilter/FilterExample.hs
@@ -0,0 +1,172 @@
+-- |
+-- HXPath - XPath Evaluator of the Haskell XML Toolbox
+--
+-- Author : Torben Kuseler, Uwe Schmidt
+--
+-- Version : $Id: FilterExample.hs,v 1.9 2004/09/02 19:11:50 hxml Exp $
+
+module Main(main)
+where
+
+import Text.XML.HXT.Parser -- import all stuff for parsing, validating, and transforming XML
+
+import System.IO -- import the IO and commandline option stuff
+import System.Environment
+import System.Console.GetOpt
+import System.Exit
+
+import Network.URI
+
+import Data.Maybe
+
+
+-- ------------------------------------------------------------
+
+-- |
+-- the main program of the Filter example
+
+main :: IO ()
+main
+ = do
+ argv <- getArgs
+ al <- cmdlineOpts argv
+ res <- run' $ filterEx al emptyRoot
+ exitProg (null res) -- set return code and terminate
+
+-- ------------------------------------------------------------
+
+exitProg :: Bool -> IO a
+exitProg True = exitWith (ExitFailure (-1))
+exitProg False = exitWith ExitSuccess
+
+-- ------------------------------------------------------------
+
+-- |
+-- the /real/ main program
+--
+-- runs in the trivial XmlState monad (with user state set to ())
+-- so IO and access to global options is possible
+
+filterEx :: Attributes -> XmlStateFilter state
+filterEx al
+ = parseDocument al
+ .>>
+ liftMf filterDocument
+ .>>
+ writeDocument []
+ .>>
+ checkStatus
+
+-- ------------------------------------------------------------
+--
+-- some simple selection and editing filter
+
+filterDocument :: XmlFilter -- the main processing filter
+filterDocument t
+ = processChildren (filterexamples xf) t
+ where
+ xf = xshow . getValue "filter" $ t
+
+filterexamples :: String -> XmlFilter
+filterexamples "all-text" = deep isXText
+filterexamples "all-body-text-without-whitespace" = getAllBodyText
+filterexamples "all-a-tags-with-href-attr" = getAllTagsWithAttr "a" "href"
+filterexamples "all-href-values-of-a-tags" = getAllAttrValues "a" "href"
+filterexamples "change-img-src-to-abs-uri" = changeToAbsolutURIs "http://localhost/images/" "img" "src"
+filterexamples f = cmt ("error: " ++ f ++ " not defined") +++ this
+
+getAllBodyText :: XmlFilter
+getAllBodyText
+ = isTag "html" .> getChildren .> isTag "body" .> getChildren .> deep (isOfText noWhiteSpace)
+ where
+ noWhiteSpace = not . all (`elem` " \t\n")
+
+getAllTagsWithAttr :: String -> String -> XmlFilter
+getAllTagsWithAttr tn an
+ = multi (isTag tn .> hasAttr an)
+
+getAllAttrValues :: String -> String -> XmlFilter
+getAllAttrValues tn an
+ = multi (isTag tn .> getValue an)
+
+changeToAbsolutURIs :: String -> String -> String -> XmlFilter
+changeToAbsolutURIs base tn an
+ = processTopDown (changeURI `when` isTag tn)
+ where
+ changeURI = modifyAttr an (toAbsURI base)
+
+toAbsURI :: String -> String -> String
+toAbsURI base uri
+ = fromMaybe "" $ expand
+ where
+ expand = do
+ base' <- parseURI base
+ uri' <- parseURI uri
+ abs' <- relativeTo uri' base'
+ return $ show abs'
+
+-- ------------------------------------------------------------
+--
+-- the options definition part
+-- see doc for System.Console.GetOpt
+
+progName :: String
+progName = "HXmlFilter"
+
+options :: [OptDescr (String, String)]
+options
+ = generalOptions
+ ++
+ inputOptions
+ ++
+ outputOptions
+ ++
+ [ Option "f" ["filter"] (ReqArg flt "FILTER") ( "filter to be applied, one of: " ++ nl ++
+ "\"all-text\"," ++ nl ++
+ "\"all-body-text-without-whitespace\"," ++ nl ++
+ "\"all-a-tags-with-href-attr\"," ++ nl ++
+ "\"all-href-values-of-a-tags\"," ++ nl ++
+ "\"change-img-src-to-abs-uri\"" )
+ ]
+ ++
+ showOptions
+ where
+ nl = "\n\t\t\t\t\t "
+ att n v = (n, v)
+ flt = att "filter"
+
+
+usage :: [String] -> IO a
+usage errl
+ | null errl
+ = do
+ hPutStrLn stdout use
+ exitProg False
+ | otherwise
+ = do
+ hPutStrLn stderr (concat errl ++ "\n" ++ use)
+ exitProg True
+ where
+ header = "FilterExamples - Examples for applying XML filter from the Haskell XML Toolbox\n" ++
+ "Usage: " ++ progName ++ " [OPTION...] [URI or FILE]"
+ use = usageInfo header options
+
+cmdlineOpts :: [String] -> IO (Attributes)
+cmdlineOpts argv
+ = case (getOpt Permute options argv) of
+ (ol,n,[] )
+ -> do
+ sa <- src n
+ help (lookup a_help ol)
+ return (ol ++ sa)
+ (_,_,errs)
+ -> usage errs
+ where
+ src [] = return [("source", "")]
+ src [uri] = return [("source", uri)]
+ src _ = usage ["only one input uri or file allowed\n"]
+
+ help Nothing = return ()
+ help (Just _) = usage []
+
+-- ------------------------------------------------------------
diff --git a/examples/hfilter/Makefile b/examples/hfilter/Makefile
new file mode 100644
--- /dev/null
+++ b/examples/hfilter/Makefile
@@ -0,0 +1,63 @@
+# $Id: Makefile,v 1.7 2005/04/14 12:52:51 hxml Exp $
+
+HXT_HOME = ../..
+PKGFLAGS =
+GHCFLAGS = -Wall -O2
+GHC = ghc $(GHCFLAGS) $(PKGFLAGS)
+
+prog = ./FilterExample
+opts = --parse-html --do-not-issue-warnings
+runprog = $(prog) $(opts)
+
+all : $(prog)
+
+force :
+ $(GHC) --make -o $(prog) $(prog).hs
+
+$(prog) : $(prog).hs
+ $(GHC) --make -o $@ $<
+
+EX = ./lousy.html
+
+test : $(prog)
+ @echo "===> Filter examples"
+ @echo ; echo "===> the filter parses a document and selects or modifies parts of it"
+ @echo ; echo "===> usage" ; echo
+ ./FilterExample --help
+ @echo ; sleep 2
+ @$(MAKE) test1 test2 test3 test4 test5
+
+test1 :
+ @sleep 2 ; echo ; echo "===> extract all a tags with a href attribute" ; echo ; sleep 2
+ $(runprog) --filter=all-a-tags-with-href-attr $(EX)
+ @echo
+
+test2 :
+ @sleep 2 ; echo ; echo "===> extract all href attribute values for a tags" ; echo ; sleep 2
+ $(runprog) --filter=all-href-values-of-a-tags $(EX)
+ @echo
+
+test3 :
+ @sleep 2 ; echo ; echo "===> change all src attribute values of img tags to absolut uris" ; echo ; sleep 2
+ $(runprog) --filter=change-img-src-to-abs-uri $(EX)
+ @echo
+
+test4 :
+ @sleep 2 ; echo ; echo "===> select all text" ; echo ; sleep 2
+ $(runprog) --filter=all-text $(EX)
+ @echo
+
+test5 :
+ @sleep 2 ; echo ; echo "===> select all text within body, but remove whitespace" ; echo ; sleep 2
+ $(runprog) --filter=all-body-text-without-whitespace $(EX)
+ @echo
+
+DIST = $(HXT_HOME)/dist/examples
+DIST_DIR = $(DIST)/hfilter
+
+dist :
+ [ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR)
+ cp $(EX) Makefile $(prog).hs $(DIST_DIR)
+
+clean :
+ rm -f $(prog) *.o *.hi
diff --git a/examples/hfilter/lousy.html b/examples/hfilter/lousy.html
new file mode 100644
--- /dev/null
+++ b/examples/hfilter/lousy.html
@@ -0,0 +1,26 @@
+
+
+
+ A HTML Documents with some Errors
+
+
+
+
HTML
+
html
+
some text and a &xxx;
+
more text
+
+
+
1
2
3
+
+
+
+
+ Uwe
+ Schmidt
+
+
+Last modified: Mon May 12 13:11:29 CEST 2003
+
+
diff --git a/examples/hparser/HXmlParser.hs b/examples/hparser/HXmlParser.hs
new file mode 100644
--- /dev/null
+++ b/examples/hparser/HXmlParser.hs
@@ -0,0 +1,136 @@
+-- |
+-- HXmlParser - Validating XML Parser of the Haskell XML Toolbox
+-- XML well-formed checker and validator.
+--
+-- Author : .\\artin Schmidt and Uwe Schmidt
+--
+-- Version : $Id: HXmlParser.hs,v 1.14 2005/04/14 12:52:51 hxml Exp $
+--
+-- this program may be used as example main program for the
+-- Haskell XML Toolbox
+
+module Main
+where
+
+import Text.XML.HXT.Parser -- import all stuff for parsing, validating, and transforming XML
+
+import System.IO -- import the IO and commandline option stuff
+import System.Environment
+import System.Console.GetOpt
+import System.Exit
+
+import Data.Maybe
+
+-- ------------------------------------------------------------
+
+-- |
+-- the main program of the Haskell XML Validating Parser
+
+main :: IO ()
+main
+ = do
+ argv <- getArgs -- get the commandline arguments
+ al <- cmdlineOpts argv -- and evaluate them, return a key-value list
+ res <- run' $ parser al emptyRoot -- build a XML root from the list and start parsing
+ exitProg (null res) -- set return code and terminate
+
+-- ------------------------------------------------------------
+
+exitProg :: Bool -> IO a
+exitProg True = exitWith (ExitFailure (-1))
+exitProg False = exitWith ExitSuccess
+
+-- ------------------------------------------------------------
+
+-- |
+-- the /real/ main program
+--
+-- get wellformed document, validates document, propagates and check namespaces
+-- and controls output
+
+parser :: Attributes -> XmlStateFilter state
+parser al
+ = parseDocument al -- read document
+ .>>
+ traceMsg 1 "start processing"
+ .>>
+ liftMf processDocument -- process document: in this case rather simple, just apply a pure filter
+ .>>
+ traceMsg 1 "processing finished"
+ .>>
+ traceSource
+ .>>
+ traceTree
+ .>>
+ ( writeDocument [] -- write result, all options already set with parseDocument
+ `whenNotM`
+ hasAttr "no-output"
+ )
+ .>>
+ checkStatus -- check status
+
+processDocument :: XmlFilter
+processDocument
+ = ( processChildren (deep isXText) -- process document, just select text when option \"show-text\" is set
+ `when`
+ hasAttr "show-text"
+ )
+
+-- ------------------------------------------------------------
+--
+-- the options definition part
+-- see doc for System.Console.GetOpt
+
+progName :: String
+progName = "HXmlParser"
+
+options :: [OptDescr (String, String)]
+options
+ = generalOptions
+ ++
+ inputOptions
+ ++
+ outputOptions
+ ++
+ [ Option "q" ["no-output"] (NoArg ("no-output", "1")) "no output of resulting document"
+ , Option "x" ["show-text"] (NoArg ("show-text", "1")) "output only the raw text, remove all markup"
+ ]
+ ++
+ showOptions
+
+usage :: [String] -> IO a
+usage errl
+ | null errl
+ = do
+ hPutStrLn stdout use
+ exitProg False
+ | otherwise
+ = do
+ hPutStrLn stderr (concat errl ++ "\n" ++ use)
+ exitProg True
+ where
+ header = "HXmlParser - Validating XML Parser of the Haskell XML Toolbox\n" ++
+ "XML well-formed checker and validator.\n\n" ++
+ "Usage: " ++ progName ++ " [OPTION...] [URI or FILE]"
+ use = usageInfo header options
+
+cmdlineOpts :: [String] -> IO (Attributes)
+cmdlineOpts argv
+ = case (getOpt Permute options argv) of
+ (ol,n,[])
+ -> do
+ sa <- src n
+ help (lookup a_help ol) sa
+ return (ol ++ sa)
+ (_,_,errs)
+ -> usage errs
+ where
+ src [] = return []
+ src [uri] = return [("source", uri)]
+ src _ = usage ["only one input uri or file allowed\n"]
+
+ help (Just _) _ = usage []
+ help Nothing [] = usage ["no input uri or file given\n"]
+ help Nothing _ = return ()
+
+-- ------------------------------------------------------------
diff --git a/examples/hparser/Makefile b/examples/hparser/Makefile
new file mode 100644
--- /dev/null
+++ b/examples/hparser/Makefile
@@ -0,0 +1,111 @@
+# $Id: Makefile,v 1.7 2005/04/14 12:52:51 hxml Exp $
+
+HXT_HOME = ../..
+PKGFLAGS =
+GHCFLAGS = -Wall -O2
+GHC = ghc $(GHCFLAGS) $(PKGFLAGS)
+
+prog = ./HXmlParser
+
+all : $(prog)
+
+HXmlParser : HXmlParser.hs
+ $(GHC) --make -o $@ $<
+
+force :
+ $(GHC) --make -o $(prog) $(prog).hs
+
+test :
+ @echo "===> run a few simple test cases with the validating parser"
+ @echo "===> first see all command line options"
+ ./HXmlParser --help
+ @echo
+ $(MAKE) test0 test1 test2 test3 test4
+
+EX1 = ./example1.xml
+EXi = ./invalid.xml
+EX2 = ../xhtml/xhtml.xml
+EX3 = ./namespace0.xml
+EX3a = ./namespace1.xml
+EX4 = ./lousy.html
+
+EX = $(EX1) $(EXi) $(EX3) $(EX3a) $(EX4)
+
+test0 : HXmlParser
+ @echo "===> a 1. simple valid document"
+ ./HXmlParser $(EX1)
+ @echo
+ @echo "===> the dom tree of the same document (without any redundant whitespace)"
+ ./HXmlParser --show-tree --remove-whitespace $(EX1)
+ @echo
+ @echo "===> the next test case contains validation erors, it must fail"
+ ./HXmlParser --verbose $(EXi) || true
+ @echo
+ @echo "===> same source, but only wellformed check"
+ ./HXmlParser --do-not-validate $(EXi) || true
+ @echo
+ @echo "===> only validation, no output of an XHTML source"
+ ./HXmlParser --verbose --no-output $(EX2)
+ @echo
+
+test1 : HXmlParser
+ @echo "===> the source of a very simple valid document" ; echo ; sleep 2
+ cat $(EX1)
+ @sleep 2 ; echo ; echo "===> parser will emit UTF-8" ; echo ; sleep 2
+ ./HXmlParser --output-encoding=UTF-8 $(EX1)
+ @echo
+ @sleep 2 ; echo ; echo "===> once again with ISO-8859-1 (latin1) output" ; echo ; sleep 2
+ ./HXmlParser --output-encoding=ISO-8859-1 $(EX1)
+ @echo
+ @sleep 2 ; echo ; echo "===> once again with US-ASCII output" ; echo ; sleep 2
+ ./HXmlParser --output-encoding=US-ASCII $(EX1)
+ @echo
+ @sleep 2 ; echo ; echo "===> once again with hdom tree output" ; echo ; sleep 2
+ ./HXmlParser --show-tree --output-encoding=ISO-8859-1 $(EX1)
+ @echo
+ @sleep 2 ; echo ; echo "===> once again, but without any markup" ; echo ; sleep 2
+ ./HXmlParser --show-text --output-encoding=ISO-8859-1 $(EX1)
+ @echo
+
+test2 : HXmlParser
+ @echo "===> the source of a xhtml document" ; echo ; sleep 2
+ cat $(EX2)
+ @echo "that document has" `cat $(EX2) | wc -l` "lines"
+ @sleep 2 ; echo ; echo "===> parser will validate this document and try to indent the output" ; echo ; sleep 2
+ ./HXmlParser --indent $(EX2)
+ @sleep 2 ; echo ; echo "===> once again, but remove all markup" ; echo ; sleep 2
+ ./HXmlParser --show-text --remove-whitespace $(EX2)
+ @sleep 2 ; echo ; echo "===> once again with hdom tree output" ; echo ; sleep 2
+ ./HXmlParser --show-tree --remove-whitespace $(EX2)
+
+test3 : HXmlParser
+ @echo "===> namespace processing examples" ; echo ; sleep 2
+ @echo "===> namespace propagation test" ; echo ; sleep 2
+ ./HXmlParser --verbose --check-namespaces --indent --output-encoding=ISO-8859-1 $(EX3)
+ @echo
+ @echo ; sleep 2 ; echo "===> namespace propagation test: tree output with attached namespaces" ; echo ; sleep 2
+ ./HXmlParser --verbose --check-namespaces --remove-whitespace --show-tree --output-encoding=ISO-8859-1 $(EX3)
+ @echo
+ @echo ; sleep 2 ; echo "===> namespace validation test: this test produces namespace errors" ; echo ; sleep 2
+ ./HXmlParser --verbose --do-not-validate --check-namespaces --indent --output-encoding=ISO-8859-1 $(EX3a) || true
+ @echo
+
+
+test4 : HXmlParser
+ @echo "===> HTML parsing examples" ; echo ; sleep 2
+ @echo "===> the source of a lousy html document" ; echo ; sleep 2
+ cat $(EX4)
+ @sleep 2 ; echo ; echo "===> parser accepts this document and tries to build a document tree" ; echo ; sleep 2
+ ./HXmlParser --indent --preserve-comment --parse-html $(EX4)
+ @echo
+
+DIST = $(HXT_HOME)/dist/examples
+DIST_DIR = $(DIST)/hparser
+
+dist :
+ [ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR)
+ cp $(EX) Makefile $(prog).hs $(DIST_DIR)
+
+clean :
+ rm -f $(prog) *.o *.hi
+
diff --git a/examples/hparser/example1.xml b/examples/hparser/example1.xml
new file mode 100644
--- /dev/null
+++ b/examples/hparser/example1.xml
@@ -0,0 +1,22 @@
+
+
+
+
+
+
+
+]>
+
+
+
+
+
+ hello world äöüß test
+
diff --git a/examples/hparser/invalid.xml b/examples/hparser/invalid.xml
new file mode 100644
--- /dev/null
+++ b/examples/hparser/invalid.xml
@@ -0,0 +1,13 @@
+
+
+
+
+
+
+]>
+
+
+
+ hello world
+
diff --git a/examples/hparser/lousy.html b/examples/hparser/lousy.html
new file mode 100644
--- /dev/null
+++ b/examples/hparser/lousy.html
@@ -0,0 +1,26 @@
+
+
+
+ A HTML Documents with some Errors
+
+
+
+
HTML
+
html
+
some text and a &xxx;
+
more text
+
+
+
1
2
3
+
+
+
+
+ Uwe
+ Schmidt
+
+
+Last modified: Mon May 12 13:11:29 CEST 2003
+
+
diff --git a/examples/hparser/namespace0.xml b/examples/hparser/namespace0.xml
new file mode 100644
--- /dev/null
+++ b/examples/hparser/namespace0.xml
@@ -0,0 +1,31 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+]>
+
+
+
+
+ hello world äöüß test
+
diff --git a/examples/hparser/namespace1.xml b/examples/hparser/namespace1.xml
new file mode 100644
--- /dev/null
+++ b/examples/hparser/namespace1.xml
@@ -0,0 +1,60 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+]>
+
+
+
+
+
+
+
+
+ <:tag/><:/><:::/>
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/examples/hsvg/.ghci b/examples/hsvg/.ghci
new file mode 100644
--- /dev/null
+++ b/examples/hsvg/.ghci
@@ -0,0 +1,11 @@
+:set -package-conf ../../lib/hxt/package.conf
+:set -package hxt
+:set -Wall
+
+:def ex0 (\ _ -> return ":set args --trace=1 --encoding=ISO-8859-1 --do-not-validate -o ISO-8859-1 example1.xml")
+
+:def x (\ _ -> return ":load TreeVisualisation\n:ex0\nmain")
+
+:x
+
+:module + IO Main
diff --git a/examples/hsvg/Makefile b/examples/hsvg/Makefile
new file mode 100644
--- /dev/null
+++ b/examples/hsvg/Makefile
@@ -0,0 +1,83 @@
+# $Id: Makefile,v 1.7 2006/06/01 15:03:21 hxml Exp $
+
+HXT_HOME = ../..
+PKGFLAGS =
+GHCFLAGS = -Wall -O2
+GHC = ghc $(GHCFLAGS) $(PKGFLAGS)
+
+prog = ./TreeVisualisation
+
+all : $(prog)
+
+force :
+ $(GHC) --make -o $(prog) $(prog).hs
+
+$(prog) : $(prog).hs
+ $(GHC) --make -o $@ $<
+
+# Tree Visualisation Examples
+
+proxy := $(shell if [ `hostname` = "si" ] ; then echo -n "--proxy=www-cache.fh-wedel.de:3128" ; else echo -n ; fi)
+
+HTV = $(prog) -t1 --use-curl --options-curl="-L" --encoding=ISO-8859-1 --parse-html --do-not-issue-warnings --remove-whitespace
+XTV = $(prog) -t1 --use-curl --do-not-validate --do-not-issue-warnings --remove-whitespace
+
+JPGS = index.html.jpg \
+ www.fh-wedel.de.index.html.jpg \
+ www.w3.org.index.html.jpg \
+ www.haskell.org.index.html.jpg
+
+vtree : $(prog) $(JPGS)
+
+index.html.svg : $(HXT_HOME)/doc/index.html
+ @echo "get Haskell XML Toolbox homepage"
+ $(HTV) --width=800 --height=400 \
+ $< > $@
+
+www.fh-wedel.de.index.html.svg :
+ @echo "get FH Wedel homepage"
+ $(HTV) --horizontalTree --horizontalLines --width=600 --height=800 --border 30 \
+ http://www.fh-wedel.de/ > $@
+
+www.w3.org.index.html.svg :
+ @echo "get www.w3.org"
+ $(XTV) --centricTree --withAttr --width=1000 --height=1000 $(proxy) \
+ http://www.w3.org/ > $@
+
+www.haskell.org.index.html.svg :
+ @echo "get www.haskell.org"
+ $(HTV) --horizontalLines --withAttr --width=600 --height=400 $(proxy) \
+ http://www.haskell.org/haskellwiki/Haskell > $@
+
+%.jpg : %.svg
+ svgtoraster -m image/jpeg -q 0.7 `pwd`/$<
+
+%.png : %.svg
+ svgtoraster -m image/png `pwd`/$<
+
+
+test :
+ $(MAKE) index.html.svg
+
+DIST = $(HXT_HOME)/dist/examples
+DIST_DIR = $(DIST)/hsvg
+DIST_FILES = $(prog).hs Makefile .ghci
+
+dist :
+ [ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR)
+ cp $(DIST_FILES) $(DIST_DIR)
+
+clean :
+ rm -f $(prog) *.o *.hi *.jpg *.png
+
+cleanvt :
+ rm -f \
+ index.html.jpg \
+ www.fh-wedel.de.index.html.jpg \
+ www.w3.org.index.html.jpg \
+ www.haskell.org.index.html.jpg \
+ index.html.svg \
+ www.fh-wedel.de.index.html.svg \
+ www.w3.org.index.html.svg \
+ www.haskell.org.index.html.svg
+
diff --git a/examples/hsvg/TreeVisualisation.hs b/examples/hsvg/TreeVisualisation.hs
new file mode 100644
--- /dev/null
+++ b/examples/hsvg/TreeVisualisation.hs
@@ -0,0 +1,449 @@
+-- |
+-- TreeVisualisation - A Haskell XML Toolbox application for
+-- a graphic representation of n-ary trees, e.g. XmlTrees
+-- with SGML. Input is a XML or HTML document, output a SGML document
+-- consisting of a graphical representation of the tree
+--
+-- Author: Uwe Schmidt uwe@fh-wedel.de
+--
+-- Version : $Id: TreeVisualisation.hs,v 1.9 2004/09/02 19:11:50 hxml Exp $
+
+module Main where
+
+import Text.XML.HXT.Parser
+
+import System.IO
+import System.Environment
+import System.Console.GetOpt
+
+import System.Exit
+
+import Data.Maybe
+
+-- ----------------------------------------------------------
+
+-- |
+-- compute a layout tree for a given NTree
+--
+-- the layout tree has a stucture isomophic to the input tree
+-- the layout is a pair of (x,y) coordinates. for every node
+-- a weight is computed, the space for a tree will be proprtional to
+-- the sum of the weight in the tree
+
+treeToWeightedTree :: (Num b) => (a -> b) -> NTree a -> NTree (b, b)
+treeToWeightedTree wf (NTree n cs)
+ = (NTree (wot, woc) cs')
+ where
+ cs' = map (treeToWeightedTree wf) cs
+ woc = sum . map (\ (NTree (sum', _) _) -> sum') $ cs'
+ wot = woc + wf n
+
+-- |
+-- auxiliary function called by 'horizontalLayout' for doint the hard work
+
+weightedTreeToHLayout :: (Fractional a) => a -> a -> NTree (a,a) -> NTree (a,a)
+weightedTreeToHLayout from to (NTree (_wot, woc) cs)
+ = NTree (from, to) cs'
+ where
+ len = to - from
+ cs' = layoutChildren (fromInteger 0) cs
+ layoutChildren _ []
+ = []
+ layoutChildren start (t1@(NTree (wot1, _woc1) _cs1) : ts)
+ = weightedTreeToHLayout from' to' t1 : layoutChildren start' ts
+ where
+ from' = (start / woc) * len + from
+ to' = (start' / woc) * len + from
+ start' = start + wot1
+
+-- |
+-- A horizontal layout for a tree generated with 'treeToWeightedTree'
+-- is computed. The nodes are positioned in the unit square ((0,0),(1,1))
+-- with the origin in the left upper corner. The root node is centered
+-- at the top of the square
+
+horizontalLayout :: (Fractional b) => (a -> b) -> NTree a -> NTree (b,b)
+horizontalLayout weightFct
+ = weightedTreeToHLayout (fromInteger 0) (fromInteger 1) . treeToWeightedTree weightFct
+
+-- |
+-- layout of a tree in a 1.0 x 1.0 square
+-- with the root node centered at the top and the
+-- deepest leaves at the bottom
+
+vTreeLayout :: (Fractional b) => (a -> b) -> NTree a -> NTree (b,b)
+vTreeLayout weightFct t
+ = vLayout (0::Int) . horizontalLayout weightFct $ t
+ where
+ d = (depthNTree t - 1) `max` 1
+ vLayout i (NTree (l,u) cs)
+ = NTree (x, y) cs'
+ where
+ x = (l + u) / fromInteger 2
+ y = fromInteger (toInteger i) / fromInteger (toInteger d)
+ cs' = map (vLayout (i + 1)) cs
+
+mirrorLayout :: NTree (a,a) -> NTree (a,a)
+mirrorLayout
+ = mapNTree (\ (x,y) -> (y, x))
+
+scaleLayout :: (RealFrac a) => Int -> Int -> Int -> NTree (a,a) -> NTree (Int,Int)
+scaleLayout border dx dy
+ = mapNTree scale
+ where
+ scale (x,y) = (truncate (x * dx') + border, truncate (y * dy') + border)
+ dx' = fromIntegral (dx - 2 * border)
+ dy' = fromIntegral (dy - 2 * border)
+
+centricLayout :: (Floating a) => NTree (a,a) -> NTree (a,a)
+centricLayout
+ = mapNTree center
+ where
+ center (x, y)
+ = ((x' + 1) /2, (y' + 1) /2)
+ where
+ phi = (2 * x - 0.5) * pi
+ r = y
+ x' = cos phi * r
+ y' = sin phi * r
+-- |
+-- map nodes of a NTree to SVG tags
+
+mapNodesToXml :: (a -> (Int, Int) -> XmlTrees) -> NTree a -> NTree (Int, Int) -> XmlTrees
+mapNodesToXml formatNode layoutTree orgTree
+ = concat . zipWith formatNode (nTreeToList layoutTree) $ (nTreeToList orgTree)
+
+mapNodesToSVG :: (a -> XmlFilter) -> NTree a -> NTree (Int, Int) -> XmlTrees
+mapNodesToSVG circleLayout
+ = mapNodesToXml drawNode
+ where
+ drawNode n (x,y)
+ = atag "circle" [ sattr "cx" (show x)
+ , sattr "cy" (show y)
+ , circleLayout n
+ ] $ undefined
+
+mapEdgesToSVG :: ((Int, Int) -> (Int, Int) -> XmlTrees) -> NTree (Int, Int) -> XmlTrees
+mapEdgesToSVG draw (NTree p1 cs)
+ = concatMap (\ t' -> mkLine t' ++ mapEdgesToSVG draw t') cs
+ where
+ mkLine (NTree p2 _) = draw p1 p2
+
+drawLine :: XmlFilter -> (Int, Int) -> (Int, Int) -> XmlTrees
+drawLine lineAttrl p1 p2
+ = drawLines lineAttrl [p1,p2]
+
+drawHPath :: XmlFilter -> (Int, Int) -> (Int, Int) -> XmlTrees
+drawHPath lineAttrl p1@(x1, y1) p2@(x2, y2)
+ = drawLines lineAttrl [p1, (x1,y12), (x2,y12), p2]
+ where
+ y12 = (y1 + y2) `div` 2
+
+drawVPath :: XmlFilter -> (Int, Int) -> (Int, Int) -> XmlTrees
+drawVPath lineAttrl p1@(x1, y1) p2@(x2, y2)
+ = drawLines lineAttrl [p1, (x12,y1), (x12,y2), p2]
+ where
+ x12 = (x1 + x2) `div` 2
+
+drawLines :: XmlFilter -> [(Int, Int)] -> XmlTrees
+drawLines attl ps
+ = concat . zipWith draw ps $ tail ps
+ where
+ draw (x1, y1) (x2, y2)
+ = atag "line" [ sattr "x1" (show x1)
+ , sattr "y1" (show y1)
+ , sattr "x2" (show x2)
+ , sattr "y2" (show y2)
+ , attl
+ ] $ undefined
+
+-- |
+-- filter for copying the attributes into the content part
+-- the result does not correspont to a wellformed XML document
+-- but for drawing the tree inclusive attributes this works fine
+
+moveAttrlToContent :: XmlFilter
+moveAttrlToContent
+ = processChildren
+ ( processBottomUp
+ ( substChildren (getAttrl +++ getChildren) `when` isXTag ) )
+
+-- |
+-- the main transformation filter
+
+xmlTreeToSVG :: XmlFilter
+xmlTreeToSVG t
+ = rootTag [ getAttrl ]
+ [ getChildren
+ .>
+ isXTag -- get the root tag
+ .>
+ cat [ dtd DOCTYPE [ sattr a_name "svg"
+ , sattr k_public "-//W3C//DTD SVG 1.1//EN"
+ , sattr k_system "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd"
+ ] []
+ , tag "svg"
+ [ sattr "width" (show widthInt)
+ , sattr "height" (show heightInt)
+ , sattr "version" "1.1"
+ , sattr "xmlns" "http://www.w3.org/2000/svg"
+ , sattr "xmlns:xlink" "http://www.w3.org/1999/xlink" -- currently not used
+ ]
+ [ stag "title" [ txt source]
+ , tag "text" [ sattr "x" "10" -- draw source uri
+ , sattr "y" "22"
+ , sattr "font-size" "12"
+ , sattr "fill" "grey"
+ ] [ txt ("source: " ++ source)
+ ]
+ , legend (10, heightInt - 5 * pixelPerLine - 10)
+ [ (tagColor, "tag")
+ , (textColor, "text")
+ , (attrColor, "attribute")
+ , (cmtColor, "comment")
+ , (defColor, "others")
+ ]
+ , nodesToSVG
+ . scaleLayout borderWidthInt widthInt heightInt
+ . layoutFct
+ . vTreeLayout nSize
+ ]
+ ]
+ ] .> addXmlPiToDoc $ t
+ where
+ t1 = head . (getChildren .> isXTag) $ t -- the root tag
+
+ pixelPerLine = 15
+
+ legend :: (Int, Int) -> [(String, String)] -> XmlFilter
+ legend (x1, y1) ls
+ = cat (zipWith legend1 ps ls)
+ where
+ ps = map (\ y' -> (x1, y1 + y' * pixelPerLine)) [0..]
+ legend1 (x', y') (color, text)
+ = cat [ atag "circle" [ sattr "cx" (show (x' + 5))
+ , sattr "cy" (show (y' + 10))
+ , sattr "r" "5"
+ , sattr "fill" color
+ , sattr "stroke-width" lineWidth
+ , sattr "stroke" lineColor
+ ]
+ , tag "text" [ sattr "x" (show (x' + pixelPerLine))
+ , sattr "y" (show (y' + pixelPerLine))
+ , sattr "font-size" "12"
+ , sattr "fill" "grey"
+ ] [ txt text
+ ]
+ ]
+
+ defValueOf attr' def' t'
+ | null res = def'
+ | otherwise = res
+ where
+ res = valueOf attr' t'
+
+ width = defValueOf "width" "800" t
+ height = defValueOf "height" "600" t
+ nodeScale = defValueOf "nodeSize" "1" t
+ borderWidth = defValueOf "borderWidth" "20" t
+ lineWidth = defValueOf "lineWidht" "1" t
+ lineColor = defValueOf "lineColor" "grey" t
+ textColor = defValueOf "textNodeColor" "blue" t
+ tagColor = defValueOf "tagNodeColor" "red" t
+ attrColor = defValueOf "attrNodeColor" "green" t
+ cmtColor = defValueOf "cmtNodeColor" "magenta" t
+ defColor = defValueOf "defaultNodeColor" "grey" t
+ layout = defValueOf "layout" "vertical" t
+ lineStyle = defValueOf "lineStyle" "line" t
+ source = valueOf a_source t
+
+ widthInt, heightInt, borderWidthInt :: Int
+
+ widthInt = read width `max` 100
+ heightInt = read height `max` 100
+ borderWidthInt= read borderWidth
+
+ nodesToSVG t' = mapEdgesToSVG (edgeLayoutFct edgeLayout) t'
+ ++
+ mapNodesToSVG nodeLayout t1 t'
+
+ nodeLayout n
+ = cat [ sattr "fill" nColor
+ , sattr "stroke" ( if r < 5 -- if circle too small
+ then nColor -- border is drawn in the same color as cirle
+ else lineColor
+ )
+ , sattr "stroke-width" lineWidth
+ , sattr "r" (show r)
+ ]
+ where
+ (nColor, nSz) = nLayout n
+ nSz1 = nSz * (read nodeScale)
+ r = (round (sqrt (fromInteger (toInteger nSz1))::Double))::Int
+
+ nSize :: XNode -> Double
+ nSize = fromInteger . toInteger . snd . nLayout
+
+ nLayout (XTag _tn _) = (tagColor, 9) -- constant size for tags
+ nLayout (XText tx) = (textColor, length tx)
+ nLayout (XAttr _an) = (attrColor, 4) -- attributes are smaller than tags
+ nLayout (XCmt c) = (cmtColor, length c)
+ nLayout _ = (defColor, 1) -- entities, PI's, dtd stuff, ...
+
+ layoutFct :: NTree (Double,Double) -> NTree (Double,Double)
+ layoutFct
+ = fromJust . lookup layout
+ $ [ ("vertical", id)
+ , ("horizontal", mirrorLayout )
+ , ("centric", centricLayout )
+ ]
+
+ edgeLayoutFct
+ = fromJust . lookup (layout, lineStyle)
+ $ [ (("vertical", "line"), drawLine )
+ , (("vertical", "fork"), drawHPath )
+ , (("horizontal", "line"), drawLine )
+ , (("horizontal", "fork"), drawVPath )
+ , (("centric", "line"), drawLine )
+ , (("centric", "fork"), drawLine )
+ ]
+
+ edgeLayout
+ = cat [ sattr "stroke" lineColor
+ , sattr "stroke-width" "1"
+ ]
+
+-- ----------------------------------------------------------
+
+-- |
+-- the main program of the Haskell XML Validating Parser
+
+main :: IO ()
+main
+ = do
+ argv <- getArgs
+ al <- cmdlineOpts argv
+ res <- run' (xmlToSVG al emptyRoot)
+ exitProg (null res) -- set return code and terminate
+
+-- ------------------------------------------------------------
+
+exitProg :: Bool -> IO a
+exitProg True = exitWith (ExitFailure (-1))
+exitProg False = exitWith ExitSuccess
+
+-- ------------------------------------------------------------
+
+-- |
+-- the /real/ main program
+--
+-- runs in the trivial XmlState monad (with user state set to ())
+-- so IO and access to global options is possible
+
+xmlToSVG :: Attributes -> XmlStateFilter state
+xmlToSVG al
+ = parseDocument al -- read document
+ .>>
+ traceMsg 1 "start processing"
+ .>>
+ liftMf
+ ( canonicalizeAllNodes
+ .>
+ ( moveAttrlToContent `when` hasAttr "withAttr" )
+ .>
+ xmlTreeToSVG
+ .>
+ indentDoc
+ )
+ .>>
+ traceMsg 1 "processing finished"
+ .>>
+ traceSource
+ .>>
+ traceTree
+ .>>
+ ( writeDocument [ (a_indent, v_1) ]
+ `whenM`
+ getChildren
+ )
+ .>>
+ checkStatus
+
+-- ------------------------------------------------------------
+--
+-- the options definition part
+-- see doc for System.Console.GetOpt
+
+progName :: String
+progName = "TreeVisualisation"
+
+options :: [OptDescr (String, String)]
+options
+ = generalOptions
+ ++
+ inputOptions
+ ++
+ outputOptions
+ ++
+ showOptions
+ ++
+ [ Option "" ["width"] (ReqArg (nat "width") "NUM") "SVG image width in pixel, default: 800"
+ , Option "" ["height"] (ReqArg (nat "height") "NUM") "SVG image height in pixel, default: 600"
+ , Option "" ["withAttr"] (NoArg (att "withAttr" "1")) "show tag attributes, default: no"
+ , Option "" ["nodeSize"] (ReqArg (nat "nodeSize") "NUM") "scale size of nodes, default: 1"
+ , Option "" ["lineWidth"] (ReqArg (nat "lineWidth") "NUM") "width of edges in pixel, default: 1\n"
+ , Option "" ["border"] (ReqArg (nat "borderWidth") "NUM") "border around tree in pixel, default: 20\n"
+
+ , Option "" ["verticalTree"] (NoArg (att "layout" "vertical")) "vertical tree layout, root centered at the top border"
+ , Option "" ["horizontalTree"] (NoArg (att "layout" "horizontal")) "horizontal tree layout, root centered at the left border"
+ , Option "" ["centricTree"] (NoArg (att "layout" "centric")) "layout with root in the center"
+ , Option "" ["directLines"] (NoArg (att "lineStyle" "line")) "edges are drawn as direct lines"
+ , Option "" ["horizontalLines"] (NoArg (att "lineStyle" "fork")) "edges are drawn as a path of horizontal and vertical lines\n"
+
+ , Option "" ["textNodeColor"] (ReqArg (att "textNodeColor") "COLOR") "text node: color name or RGB value in format \"#RRGGBB\""
+ , Option "" ["tagNodeColor"] (ReqArg (att "tagNodeColor") "COLOR") "tag node color"
+ , Option "" ["attrNodeColor"] (ReqArg (att "attrNodeColor") "COLOR") "attribute node color"
+ , Option "" ["cmtNodeColor"] (ReqArg (att "cmtNodeColor") "COLOR") "comment node color"
+ , Option "" ["defaultNodeColor"] (ReqArg (att "defNodeColor") "COLOR") "other node color"
+ ]
+ where
+ att n v = (n, v)
+ nat n v = (n, filter (`elem` "0123456789") v)
+
+usage :: [String] -> IO a
+usage errl
+ | null errl
+ = do
+ hPutStrLn stdout use
+ exitProg False
+ | otherwise
+ = do
+ hPutStrLn stderr (concat errl ++ "\n" ++ use)
+ exitProg True
+ where
+ header = "TreeVisualisation - An example application of the Haskell XML Toolbox\n" ++
+ "for the visualisation of the structure of a XML document with SVG\n" ++
+ "Usage: " ++ progName ++ " [OPTION...] [URI or FILE]"
+ use = usageInfo header options
+
+cmdlineOpts :: [String] -> IO (Attributes)
+cmdlineOpts argv
+ = case (getOpt Permute options argv) of
+ (ol,n,[] )
+ -> do
+ sa <- src n
+ help (lookup a_help ol)
+ return (ol ++ sa)
+ (_,_,errs)
+ -> usage errs
+ where
+ src [] = usage ["no input url or file given\n"]
+ src [url] = return [("source", url)]
+ src _ = usage ["only one input uri or file allowed\n"]
+
+ help Nothing = return ()
+ help (Just _) = usage []
+
+-- ------------------------------------------------------------
+
+
diff --git a/examples/hunit/HUnitExample.hs b/examples/hunit/HUnitExample.hs
new file mode 100644
--- /dev/null
+++ b/examples/hunit/HUnitExample.hs
@@ -0,0 +1,616 @@
+-- |
+-- HUnit - Haskell XML Toolbox examples and tests
+--
+-- Author: Uwe Schmidt uwe@fh-wedel.de
+--
+-- Version : $Id: HUnitExample.hs,v 1.8 2005/04/14 12:52:51 hxml Exp $
+
+module Main where
+
+import System
+import Test.HUnit
+import Text.XML.HXT.Parser
+import Data.Char
+
+aMinimalDoc :: XmlTree
+aMinimalDoc = mkRootTree [] (xtext "")
+
+aSimpleXHTMLDoc :: XmlTree
+aSimpleXHTMLDoc
+ = mkRootTree
+ ( xattr a_source "simple.xml" )
+ ( xtext
+ ( concatMap (++ "\n")
+ [ ""
+ , ""
+ , " A Simple XHTML Document"
+ , " "
+ , " "
+ , ""
+ ]
+ )
+ )
+
+mkMinimalDoc :: String -> XmlTree
+mkMinimalDoc cont
+ = mkRootTree [] (xtext cont)
+
+mkInputDoc :: String -> XmlTree
+mkInputDoc src
+ = mkRootTree ( xattr a_source src) []
+
+mkDoc :: String -> XmlTree
+mkDoc cont
+ = mkRootTree
+ ( xattr a_source "a test")
+ ( xtext ("\n" ++ cont) )
+
+-- |
+-- compare trees
+
+testEqualTrees :: XmlTrees -> XmlTrees -> Test
+testEqualTrees e1 e2
+ = TestCase $
+ assertEqual "" e1 e2
+
+-- |
+-- testDocFilter creates a test for the application of a pure
+-- functional filter to a XML tree. The result is converted into
+-- the external string representation and compared with the expected
+-- result.
+--
+-- see also: 'testStateFilter' and 'testEditFilter'
+
+testDocFilter :: String -> XmlFilter -> XmlTree -> Test
+testDocFilter expected xfilter doc
+ = TestCase $
+ assertEqual "" expected (xshow $ xfilter doc)
+
+-- |
+-- testStateFilter creates a test for monadic filters, doing IO and using
+-- the internal state, consisting of program options and status information
+-- The filter is applied to a XML tree, the result is converted to a string
+-- and this result is compared with the expected result.
+--
+-- see also: 'testEditFilter' for pure functional filters
+
+testStateFilter :: String -> XmlStateFilter () -> XmlTree -> Test
+testStateFilter expected xfilter input
+ = TestCase $
+ do
+ res <- run' $ xfilter input
+ assertEqual "" expected (xshow res)
+
+-- |
+-- The test bed for edit filter for external documents.
+-- The input tree must specify the external document to be read.
+-- This document is checked for wellformedness, canonicalized
+-- (char refs substituted, ...) and processed with the edit filter.
+-- The result is transformed into the string representation and compared
+-- with the expected string.
+
+testEditFilter :: String -> XmlFilter -> XmlTree -> Test
+testEditFilter expected xfilter input
+ = TestCase $
+ do
+ res <- run'
+ $ ( getWellformedDoc -- read the document
+ .>>
+ liftMf canonicalizeAllNodes -- normalize the document and remove decl
+ .>>
+ liftMf ( processChildren xfilter ) -- apply the editing filter only to the 'real' document
+ .>> -- nodes, not to nodes surrounding the document tag
+ putXmlTree -- just trace output
+ .>>
+ liftMf getChildren -- just for comparing the document contents
+ )
+ input
+ assertEqual "" expected (xshow res)
+
+
+-- |
+-- ausiliary function to make haskell string constants with quotes more readable
+
+singleToDoubleQuote :: String -> String
+singleToDoubleQuote
+ = map (\ c -> if c == '\'' then '"' else c)
+
+-- |
+-- the complete set of test cases
+
+allTests :: Test
+allTests
+ = TestList
+ [ constructionTests
+ , treeConstructionTests
+ , parseTests
+ , inputTests
+ , removeTests
+ , simpleSelectionTests
+ , namespaceTests
+ ]
+
+-- |
+-- tree versus filter construction tests
+-- documents may be constructed by tree operations
+-- or with the more flexible filter operations applied to an arbitray tree
+
+treeConstructionTests :: Test
+treeConstructionTests
+ = TestLabel "tree and filter construction tests" $
+ TestList $
+ map (\ (t, f) -> testEqualTrees t (f undefined) )
+ [ (xtext "xyz", txt "xyz" )
+ , (xcmt "cmt", cmt "cmt" )
+ , (xtag "img" [] [], tag "img" [] [] )
+ , (xtag "img" [] [], etag "img" )
+
+ , (xtag "img" (xattr "b" "13") [], tag "img" [sattr "b" "13"] [] )
+
+ , (xtag "img" (xattr "b" "13") [], atag "img" [sattr "b" "13"] )
+
+ , (xtag "t" (xattr "a" "42" ++ xattr "b" "id")
+ (xtext "abc"),
+ tag "t" [sattr "a" "42", sattr "b" "id"]
+ [txt "abc"] )
+ ]
+
+-- |
+-- construction tests are all applied to the empty document,
+-- no information is used from that document,
+-- but construction is lifted to the filter level.
+-- this is more general than explicit construction.
+-- in more complex examples some information may be extracted from
+-- the source, some can be constant.
+--
+-- see also: 'testDocFilter'
+
+constructionTests :: Test
+constructionTests
+ = TestLabel "document construction tests" $
+ TestList $
+ map (\ (res, f) -> testDocFilter res f undefined) -- undefined or something else, e.g. emptyRoot
+ [ ("" , mkXTag "x" none none )
+ , ("" , tag "x" [] [] ) -- syntactically more comfortable shortcut for mkXTag
+ , ("" , stag "x" [] ) -- shortcut for tags without attributes
+ , ("" , atag "x" [] ) -- shortcut for empty tags with attributes
+ , ("" , etag "x" ) -- shortcut for empty tags without attributes
+
+ , (""
+ , mkXTag "x" (mkXAttr "a" (mkXText "1")) none )
+ , ("42"
+ , mkXTag "x" (mkXAttr "a" (mkXText "1")) (mkXText "42") )
+ , ("42"
+ , tag "x" [ attr "a" $ txt "1" ] [ txt "42" ] )
+ , ("42"
+ , tag "x" [ sattr "a" "1" ] [ txt "42" ] )
+
+ , ("" , atag "x" [ sattr "a" "1" ] )
+
+ , ("4243"
+ , tag "x" [ sattr "a" "1"
+ , sattr "b" "2"
+ ] [ txt "42"
+ , etag "y"
+ , txt "43"
+ ] )
+ , (""
+ , mkXCmt $ txt " a comment " )
+ , (""
+ , cmt "a comment" ) -- short cut for uncomputed comment
+
+ , (""
+ , cmt " an illegal XML comment containing 2 -- in comment text " )
+
+ , ("*" , mkXCharRef 42 )
+ , ("<" , mkXEntityRef "lt" )
+ , ("]]>"
+ , mkXCdata $ txt "")
+ , ("]]>" -- short cut for uncomputed cdata content
+ , cdata "")
+ , ("" , mkXPi "abc" $ txt "xyz" )
+ , ("" , spi "abc" "xyz" ) -- short cut for an uncomputed pi content
+ ]
+
+-- |
+-- simple selection tests
+
+simpleSelectionTests :: Test
+simpleSelectionTests
+ = TestLabel "simple tree selection tests" $
+ TestList $
+ map (\ (res, f) -> testDocFilter (singleToDoubleQuote res) f simpleDoc)
+ [ (src , this )
+ , ("1" , getValue "a" )
+ , ("" , getValue "b" )
+ , (body1 , getChildren )
+
+ -- text selection
+ , ("xyz" , getChildren .> isXText )
+ , ("xyz" , getChildren .> isText "xyz" )
+ , ("" , getChildren .> isText "abc" )
+ , ("xyz" , getChildren .> isOfText (>="x") )
+ , ("" , getChildren .> isOfText (<"x") )
+ , ("" , getChildren .> isWhiteSpace )
+
+ -- tag selection
+ , ("abc"
+ , getChildren .> isXTag )
+
+ -- comment selection
+ , ("" , getChildren .> isXCmt )
+
+ -- text OR tag selection
+ , ("abcxyz"
+ , getChildren .> (isXTag +++ isXText) )
+
+ -- generalised OR
+ , ("abcxyz"
+ , getChildren .> cat [isXTag, isXText] )
+
+ , ("abc" , getChildren .> getChildren )
+
+ -- atribute value selection
+ , ("1" , getValue "a" )
+
+ , ("abc"
+ , getChildren .> isTag "t" )
+
+ -- attribute selection
+ , ("abc"
+ , getChildren .> hasAttr "a" )
+
+ , ("42" , getChildren .> getValue "a" )
+ , ("42" , getChildren .> hasValue "a" (all isDigit) )
+ , ("13" , getChildren .> hasValue "b" (all isDigit) )
+ , ("" , getChildren .> isTag "t" .> hasValue "b" (all isDigit) )
+ , ("42" , getChildren .> hasValue "a" (== "42") )
+ , ("" , getChildren .> hasValue "a" (== "43") )
+ , ("42" , getChildren .> hasValue "a" (\ str -> ((read str)::Int) > 40) )
+ , ("42" , getChildren .> hasValue "a" (not . null) )
+ , ("id13" , getChildren .> hasValue "b" (const True) )
+ , ("13" , getChildren .> isTag "img" .> hasValue "b" (const True) )
+ , ("" , getChildren .> hasValue "c" (const True) )
+
+ , (" a='42' b='id' b='13' x='0'"
+ , getChildren .> getAttrl )
+
+ , (" a='42' b='id'"
+ , getChildren .> isTag "t" .> getAttrl )
+
+ , ("42id" , getChildren .> isTag "t" .> getAttrl .> getChildren )
+
+ , (" b='id' b='13'"
+ , getChildren .> getAttrl .> isAttr "b" )
+
+ , (" b='13'" , getChildren .> isTag "img" .> getAttrl .> isAttr "b" )
+ , ("13" , getChildren .> isTag "img" .> getAttrl .> isAttr "b" .> getChildren )
+ , ("13" , getChildren .> isTag "img" .> getValue "b" )
+ , ("timgyz" , getChildren .> getName )
+ , ("t" , getChildren .> isTag "t" .> getName )
+ , ("abbx" , getChildren .> getAttrl .> getName )
+ , ("bb" , getChildren .> getAttrl .> isAttr "b" .> getName )
+ , ("ab" , getChildren .> isTag "t" .> getAttrl .> getName )
+ , ("b" , getChildren .> isTag "t" .> getAttrl .> isAttr "b" .> getName )
+
+ -- deep search for text or tags
+ , ("abcxyz" , deep isXText )
+ , ("abc" , deep (isTag "t") .> deep isXText )
+ ]
+ where
+ src = "" ++ body1 ++ ""
+ body1 = ""
+ ++ "abc"
+ ++ ""
+ ++ "xyz"
+ ++ ""
+ ++ ""
+
+ sDocFilter
+ = tag "r" [ sattr "a" "1" ]
+ [ cmt "cmt"
+ , tag "t" [ sattr "a" "42", sattr "b" "id" ]
+ [ txt "abc"
+ ]
+ , atag "img" [ sattr "b" "13" ]
+ , txt "xyz"
+ , atag "y" [ sattr "x" "0" ]
+ , etag "z"
+ ]
+ simpleDoc = head $ sDocFilter undefined
+
+-- |
+-- simple tests with namespaces
+
+namespaceTests :: Test
+namespaceTests
+ = TestLabel "namespace tests" $
+ TestList $
+ map (\ (res, f) -> testDocFilter (singleToDoubleQuote res) f simpleDoc)
+ [ (src , this )
+ -- select all "t" tags, even nested ones (multi) and extract the text from the body
+ , ("sssaaa" , multi (isTag "t" .> getChildren .> isXText) )
+
+ -- select all text within all tags of a specific namespace
+ , ("sssaaazzzeee" , multi (isXTag .> hasNamespace "dns" .> getChildren .> isXText) )
+ , ("bbb" , multi (isXTag .> hasNamespace "n1" .> getChildren .> isXText) )
+ , ("cccdddfffggg" , multi (isXTag .> hasNamespace "n2" .> getChildren .> isXText) )
+
+ -- select all text within all tags with a specific local name
+ , ("sssaaabbbcccdddzzz"
+ , multi (isXTag .> hasLocalPart "t" .> getChildren .> isXText) )
+ , ("eee" , multi (isXTag .> hasLocalPart "e" .> getChildren .> isXText) )
+
+ -- select all text within all tags with a specific prefix
+ , ("bbbddd" , multi (isXTag .> hasPrefix "x" .> getChildren .> isXText) )
+ , ("ccc" , multi (isXTag .> hasPrefix "y" .> getChildren .> isXText) )
+ , ("zzz" , multi (isXTag .> hasPrefix "z" .> getChildren .> isXText) )
+ , ("sssaaaeeefffggg"
+ , multi (isXTag .> hasPrefix "" .> getChildren .> isXText) )
+
+ -- select all attribute values of a specific namespace
+ -- !!! the default namespace is not propagated to attribute names
+ , ("z5" , multi (isXTag .> getAttrl .> hasNamespace "dns" .> getChildren) )
+ , ("2z4" , multi (isXTag .> getAttrl .> hasNamespace "n1" .> getChildren) )
+ , ("x3y3u4" , multi (isXTag .> getAttrl .> hasNamespace "n2" .> getChildren) )
+ , ("dnsn2" , multi (isXTag .> getAttrl .> hasLocalPart "xmlns" .> getChildren) )
+
+ -- select namespaces from all namespace declarations
+ , ("dnsn1n2dnsn2n2"
+ , multi (isXTag .> getAttrl .> isNamespaceDecl .> getChildren) )
+
+ -- all default namespace declarations
+ , ("dnsn2" , multi (isXTag .> getAttrl .> hasLocalPart "xmlns" .> getChildren) )
+
+ -- all none default namespace declarations
+ , ("n1n2dnsn2" , multi (isXTag .> getAttrl .> hasPrefix "xmlns" .> getChildren) )
+ , ("n1n2" , multi (isXTag .> getAttrl .> hasPrefix "xmlns" .> hasLocalPart "x" .> getChildren) )
+ , ("n2" , multi (isXTag .> getAttrl .> hasPrefix "xmlns" .> hasLocalPart "y" .> getChildren) )
+ , ("dns" , multi (isXTag .> getAttrl .> hasPrefix "xmlns" .> hasLocalPart "z" .> getChildren) )
+ ]
+ where
+ -- the text representation of the tree
+ -- with ' instead of " for readablility of the string constants
+ src = ""
+ ++ "sss"
+ ++ "aaa"
+ ++ "bbb"
+ ++ "ccc"
+ ++ "ddd"
+ ++ "zzz"
+ ++ "eee"
+ ++ "fffggg" ++
+ ""
+
+ -- the filter for generating the test document
+ sDocFilter
+ = tag "t" [ sattr "xmlns" "dns" -- 4 namespace declarations
+ , sattr "xmlns:x" "n1"
+ , sattr "xmlns:y" "n2"
+ , sattr "xmlns:z" "dns"
+ ]
+ [ txt "sss"
+ , tag "t" [ sattr "a" "1"
+ , sattr "x:a" "2" ]
+ [ txt "aaa"
+ ]
+ , tag "x:t" [ sattr "a" "x1"
+ , sattr "y:a" "x3"
+ ]
+ [ txt "bbb"
+ ]
+ , tag "y:t" [ sattr "a" "y1"
+ , sattr "y:a" "y3"
+ ]
+ [ txt "ccc"
+ ]
+ , tag "x:t" [ sattr "xmlns:x" "n2" -- redefinition of prefix x:
+ , sattr "x:a" "u4"
+ ]
+ [ txt "ddd"
+ ]
+ , tag "z:t" [ sattr "x:a" "z4"
+ , sattr "z:a" "z5"
+ ]
+ [ txt "zzz"
+ ]
+ , tag "e" [ sattr "b" "42" ]
+ [ txt "eee"
+ ]
+ , tag "f" [ sattr "xmlns" "n2" -- redefinition of default namespace
+ ]
+ [ txt "fff"
+ , tag "g" [ ]
+ [ txt "ggg" ]
+ ]
+ ]
+ -- create document and propagate namespaces
+ simpleDoc = head $ (sDocFilter .> propagateNamespaces) undefined
+
+-- |
+-- minimal tests for parsing data.
+--
+-- the tests are document trees with a root
+-- node containing a single text node with the document source.
+-- That tree is passed to the parser, which substitutes the text node with the parsed xml tree.
+-- In general this may be a list of trees containing also the
+-- surrounding parts like the xml declaraion, the document type definition
+-- possibly comments and processing instructions.
+--
+-- see also: 'testStateFilter'
+
+parseTests :: Test
+parseTests
+ = TestLabel "minimal parser tests" $
+ TestList
+ [ testStateFilter "" parseXmlDoc mini -- the tree inclusive root node
+ , testStateFilter "" (parseXmlDoc .>> liftMf getChildren) mini -- only the content
+ , testStateFilter "" (parseXmlDoc .>> liftMf getChildren) min2 -- same content
+ , testStateFilter "" (parseXmlDoc .>> liftMf getChildren) minErr -- syntax error: content empty
+ , testStateFilter errr (parseXmlDoc .>> liftMf (getValue a_status)) minErr -- syntax error reported in a_status
+ ]
+ where
+ errr = show c_err
+ mini = mkMinimalDoc ""
+ min2 = mkMinimalDoc ""
+ minErr = mkMinimalDoc ""
+
+
+-- |
+-- simple external file containing one tag
+
+mini1 :: XmlTree
+mini1 = newDocument "mini1.xml" -- test documents
+
+-- |
+-- simple external file containing one tag
+
+mini2 :: XmlTree
+mini2 = newDocument "mini2.xml"
+
+-- |
+-- simple not existing external file
+
+notThere :: XmlTree
+notThere = newDocument "notThere.xml" -- does not exist
+
+-- |
+-- These test check the access to external files
+-- and error reporting in case of input or parse errors
+-- Some test issue tree like trace output of the documents read
+-- to show the internal structure and nesting
+
+inputTests :: Test
+inputTests
+ = TestLabel "input tests" $
+ TestList
+ [ testStateFilter "mini1.xml"
+ ( putXmlTree .>>
+ liftMf (getValue a_source)
+ ) mini1
+ , testStateFilter ok ( liftMf (getValue a_status)
+ ) mini1
+ , testStateFilter "" ( liftMf getChildren
+ ) mini1
+ , testStateFilter "" ( getXmlContents .>>
+ putXmlTree .>>
+ liftMf getChildren
+ ) mini1
+ , testStateFilter ok ( getXmlContents .>>
+ liftMf (getValue a_status)
+ ) mini1
+ , testStateFilter "4" ( getXmlContents .>>
+ liftMf getContentLength .>>
+ putXmlTree .>>
+ liftMf (getValue a_contentLength)
+ ) mini1
+ , testStateFilter ok ( getXmlContents .>>
+ liftMf (getValue a_status)
+ ) mini2
+ , testStateFilter "" ( getXmlContents .>>
+ putXmlTree .>>
+ liftMf getChildren
+ ) notThere
+ , testStateFilter fat ( getXmlContents .>>
+ liftMf (getValue a_status)
+ ) notThere
+ ]
+ where
+ ok = show c_ok
+ fat = show c_fatal
+
+-- |
+-- A few tests for removing parts of a document tree.
+-- As input tree the document in file mini2.xml is used.
+
+removeTests :: Test
+removeTests
+ = TestLabel "document transformation tests" $
+ TestList
+ [ testEditFilter allText getAllText mini2
+ , testEditFilter allData (removeAllWhiteSpace .> getAllText) mini2
+ , testEditFilter allImp (removeIgnorableData .> getAllText) mini2
+ , testEditFilter allDat (removeMeta .> getAllText) mini2
+ ]
+ where
+ getAllText = deep isXText
+ containsUnknownOrIgnore = getChildren .> ( isText "unknown"
+ +++
+ isText "ignore"
+ )
+ removeIgnorableData = processTopDown ( none
+ `when`
+ ( isTag "data" .> containsUnknownOrIgnore )
+ )
+ removeMeta = processTopDown ( none
+ `when`
+ ( isTag "data" .> hasValue "class" ( == "meta" ) )
+ )
+ allText = " ignore unknown important important "
+ allData = "ignoreunknownimportantimportant"
+ allImp = " important important "
+ allDat = " ignore important "
+
+
+ys :: XmlTree
+ys = head $
+ tag "s:Envelope"
+ [ sattr "xmlns:s" "http://schemas.xmlsoap.org/soap/envelope/",
+ sattr "xmlns:xenc" "http://www.w3.org/2001/04/xmlenc#",
+ sattr "xmlns:eg" "http://example.org/paymentv2",
+ sattr "xmlns:wsse" "http://schemas.xmlsoap.org/ws/2002/12/secext"
+ ]
+ [ stag "s:Header"
+ [ stag "wsse:Security"
+ [ tag "wsse:BinarySecurityToken"
+ [ sattr "ValueType" "wsse:Kerberosv5ST",
+ sattr "EncodingType" "wsse:Base64Binary"
+ ]
+ [ txt "QMwcAG ..."
+ ]
+ ]
+ ],
+ stag "s:Body"
+ [ stag "eg:OrderCurrency"
+ [ stag "eg:Name"
+ [ txt "John Smith" ],
+ tag "eg:Amount"
+ [ sattr "Currency" "'USD'" ]
+ [ txt "1000" ],
+ tag "eg:CreditCard"
+ [ sattr "Limit" "'5000'",
+ sattr "Currency" "'GBP'"
+ ]
+ [ stag "xenc:EncryptedData"
+ [ atag "xenc:EncryptionMethod"
+ [ sattr "Algorithm" "http://www.w3.org/2001/04/xmlenc#tripledes-cbc" ]
+ ],
+ stag "xenc:CipherData"
+ [ stag "xenc:CipherValue"
+ [ txt "r5KipsDV ..." ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ .> propagateNamespaces
+ .> indentDoc
+ $ undefined
+
+
+main :: IO ()
+main
+ = do
+ c <- runTestTT allTests
+ putStrLn $ show c
+ let errs = errors c
+ fails = failures c
+ System.exitWith (codeGet errs fails)
+
+codeGet :: Int -> Int -> ExitCode
+codeGet errs fails
+ | fails > 0 = ExitFailure 2
+ | errs > 0 = ExitFailure 1
+ | otherwise = ExitSuccess
+
+-- ----------------------------------------------------------
diff --git a/examples/hunit/Makefile b/examples/hunit/Makefile
new file mode 100644
--- /dev/null
+++ b/examples/hunit/Makefile
@@ -0,0 +1,32 @@
+# $Id: Makefile,v 1.6 2005/04/14 12:52:51 hxml Exp $
+
+HXT_HOME = ../..
+PKGFLAGS =
+GHCFLAGS = -Wall -O2
+GHC = ghc $(GHCFLAGS) $(PKGFLAGS)
+
+prog = ./HUnitExample
+
+all : $(prog)
+
+force :
+ $(GHC) --make $(GHCPACKAGES) -o $(prog) $(prog).hs
+
+$(prog) : $(prog).hs
+ $(GHC) --make $(GHCPACKAGES) -o $@ $<
+
+test : $(prog)
+ @echo "===> run HUnit examples" ; echo ; sleep 2
+ $(prog)
+
+DIST = $(HXT_HOME)/dist/examples
+DIST_DIR = $(DIST)/hunit
+DIST_FILES = mini1.xml mini2.xml Makefile $(prog).hs
+
+dist :
+ [ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR)
+ cp $(DIST_FILES) $(DIST_DIR)
+
+clean :
+ rm -f $(prog) $(prog).o $(prog).hi
+
diff --git a/examples/hunit/mini1.xml b/examples/hunit/mini1.xml
new file mode 100644
--- /dev/null
+++ b/examples/hunit/mini1.xml
@@ -0,0 +1,1 @@
+
diff --git a/examples/hunit/mini2.xml b/examples/hunit/mini2.xml
new file mode 100644
--- /dev/null
+++ b/examples/hunit/mini2.xml
@@ -0,0 +1,1 @@
+ ignore unknown important important
diff --git a/examples/mini/Makefile b/examples/mini/Makefile
new file mode 100644
--- /dev/null
+++ b/examples/mini/Makefile
@@ -0,0 +1,34 @@
+# $Id: Makefile,v 1.5 2005/04/14 12:52:52 hxml Exp $
+
+HXT_HOME = ../..
+PKGFLAGS =
+GHCFLAGS = -Wall -O2
+GHC = ghc $(GHCFLAGS) $(PKGFLAGS)
+
+prog = ./ParseExample
+
+all : $(prog)
+
+force :
+ $(GHC) --make -o $(prog) $(prog).hs
+
+$(prog) : $(prog).hs
+ $(GHC) --make -o $@ $<
+
+test : $(prog)
+ @echo "===> a very simple test"
+ @echo "===> a xml source"
+ @cat example1.xml
+ @sleep 2; echo "===> parse, validate and normalise the document"
+ $(prog) example1.xml
+
+DIST = $(HXT_HOME)/dist/examples
+DIST_DIR = $(DIST)/mini
+
+dist :
+ [ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR)
+ cp example1.xml Makefile $(prog).hs $(DIST_DIR)
+
+clean :
+ rm -f $(prog) *.o *.hi
+
diff --git a/examples/mini/ParseExample.hs b/examples/mini/ParseExample.hs
new file mode 100644
--- /dev/null
+++ b/examples/mini/ParseExample.hs
@@ -0,0 +1,50 @@
+-- |
+-- This is a simple example for parsing and validating an XML file and printing the generated
+-- XmlTree to standard out.
+--
+-- Author : .\\artin Schmidt
+-- Version : $Id: ParseExample.hs,v 1.4 2004/09/02 19:11:53 hxml Exp $
+
+module Main(main)
+where
+
+import Text.XML.HXT.Parser
+
+import System.IO
+import System
+
+--
+-- call this program with a single parameter for the file or uri to be processed
+-- e.g. ParseExample example1.xml
+
+main :: IO ()
+main
+ = do
+ argv <- getArgs
+ -- take the first cmdline argument as source name
+ -- start the XState monad with the runParser command
+ res <- run' $ parser [(a_source, head argv)] emptyRoot
+ exitProg res
+
+-- run a command in the XState monad.
+-- this monad includes the IO monad, a system state for global options
+-- and a user definable state (type parameter state). This user state is
+-- set to () (the empty state) by the run' command.
+-- There are more general run commands: run, run0 in case of a proccessing
+-- function, that requires e.g. an environment
+
+parser :: Attributes -> XmlStateFilter ()
+parser al
+ = parseDocument al
+ .>>
+ writeDocument [(a_indent, v_1)] -- indent document and output to stdout
+ .>>
+ checkStatus -- check status
+
+-- ------------------------------------------------------------
+
+exitProg :: [a] -> IO ()
+exitProg [] = exitWith (ExitFailure (-1))
+exitProg _ = exitWith ExitSuccess
+
+-- ------------------------------------------------------------
diff --git a/examples/mini/example1.xml b/examples/mini/example1.xml
new file mode 100644
--- /dev/null
+++ b/examples/mini/example1.xml
@@ -0,0 +1,22 @@
+
+
+
+
+
+
+
+]>
+
+
+
+
+
+ hello world äöüß test
+
diff --git a/examples/xhtml/xhtml-lat1.ent b/examples/xhtml/xhtml-lat1.ent
new file mode 100644
--- /dev/null
+++ b/examples/xhtml/xhtml-lat1.ent
@@ -0,0 +1,196 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/examples/xhtml/xhtml-special.ent b/examples/xhtml/xhtml-special.ent
new file mode 100644
--- /dev/null
+++ b/examples/xhtml/xhtml-special.ent
@@ -0,0 +1,79 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/examples/xhtml/xhtml-symbol.ent b/examples/xhtml/xhtml-symbol.ent
new file mode 100644
--- /dev/null
+++ b/examples/xhtml/xhtml-symbol.ent
@@ -0,0 +1,242 @@
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/examples/xhtml/xhtml.xml b/examples/xhtml/xhtml.xml
new file mode 100644
--- /dev/null
+++ b/examples/xhtml/xhtml.xml
@@ -0,0 +1,1484 @@
+
+
+
+
+XHTML 1.0: The Extensible HyperText Markup
+Language
+
+
+
+
+
+
This specification defines XHTML 1.0, a reformulation of HTML 4
+as an XML 1.0 application, and three DTDs corresponding to
+the ones defined by HTML 4. The semantics of the elements and
+their attributes are defined in the W3C Recommendation for HTML 4.
+These semantics provide the foundation for future
+extensibility of XHTML. Compatibility with existing HTML user
+agents is possible by following a small set of guidelines.
+
+
Status of this document
+
+
This section describes the status of this document at the time
+of its publication. Other documents may supersede this document. The
+latest status of this document series is maintained at the W3C.
+
+
+This document has been reviewed by W3C Members and other
+interested parties and has been endorsed by the Director
+as a W3C Recommendation. It is a stable document and may be
+used as reference material or cited as a normative
+reference from another document. W3C's role in making the
+Recommendation is to draw attention to the specification and
+to promote its widespread deployment. This enhances the
+functionality and interoperability of the Web.
+
XHTML is a family of current and future document types and modules that
+reproduce, subset, and extend HTML 4 [HTML]. XHTML family document types are XML based,
+and ultimately are designed to work in conjunction with XML-based user agents.
+The details of this family and its evolution are
+discussed in more detail in the section on Future
+Directions.
+
+
XHTML 1.0 (this specification) is the first document type in the XHTML
+family. It is a reformulation of the three HTML 4 document types as
+applications of XML 1.0 [XML]. It is intended
+to be used as a language for content that is both XML-conforming and, if some
+simple guidelines are followed,
+operates in HTML 4 conforming user agents. Developers who migrate
+their content to XHTML 1.0 will realize the following benefits:
+
+
+
XHTML documents are XML conforming. As such, they are readily viewed,
+edited, and validated with standard XML tools.
+
XHTML documents can be written to
+to operate as well or better than they did before in existing
+HTML 4-conforming user agents as well as in new, XHTML 1.0 conforming user
+agents.
+
XHTML documents can utilize applications (e.g. scripts and applets) that rely
+upon either the HTML Document Object Model or the XML Document Object Model [DOM].
+
As the XHTML family evolves, documents conforming to XHTML 1.0 will be more
+likely to interoperate within and among various XHTML environments.
+
+
+
The XHTML family is the next step in the evolution of the Internet. By
+migrating to XHTML today, content developers can enter the XML world with all
+of its attendant benefits, while still remaining confident in their
+content's backward and future compatibility.
HTML 4 [HTML] is an SGML (Standard
+Generalized Markup Language) application conforming to
+International Standard ISO 8879, and is widely regarded as the
+standard publishing language of the World Wide Web.
+
+
SGML is a language for describing markup languages,
+particularly those used in electronic document exchange, document
+management, and document publishing. HTML is an example of a
+language defined in SGML.
+
+
SGML has been around since the middle 1980's and has remained
+quite stable. Much of this stability stems from the fact that the
+language is both feature-rich and flexible. This flexibility,
+however, comes at a price, and that price is a level of
+complexity that has inhibited its adoption in a diversity of
+environments, including the World Wide Web.
+
+
HTML, as originally conceived, was to be a language for the
+exchange of scientific and other technical documents, suitable
+for use by non-document specialists. HTML addressed the problem
+of SGML complexity by specifying a small set of structural and
+semantic tags suitable for authoring relatively simple documents.
+In addition to simplifying the document structure, HTML added
+support for hypertext. Multimedia capabilities were added
+later.
+
+
In a remarkably short space of time, HTML became wildly
+popular and rapidly outgrew its original purpose. Since HTML's
+inception, there has been rapid invention of new elements for use
+within HTML (as a standard) and for adapting HTML to vertical,
+highly specialized, markets. This plethora of new elements has
+led to compatibility problems for documents across different
+platforms.
+
+
As the heterogeneity of both software and platforms rapidly
+proliferate, it is clear that the suitability of 'classic' HTML 4
+for use on these platforms is somewhat limited.
XML™ is the shorthand for Extensible Markup
+Language, and is an acronym of Extensible Markup Language [XML].
+
+
XML was conceived as a means of regaining the power and
+flexibility of SGML without most of its complexity. Although a
+restricted form of SGML, XML nonetheless preserves most of SGML's
+power and richness, and yet still retains all of SGML's commonly
+used features.
+
+
While retaining these beneficial features, XML removes many of
+the more complex features of SGML that make the authoring and
+design of suitable software both difficult and costly.
The benefits of migrating to XHTML 1.0 are described above. Some of the
+benefits of migrating to XHTML in general are:
+
+
+
Document developers and user agent designers are constantly
+discovering new ways to express their ideas through new markup. In XML, it is
+relatively easy to introduce new elements or additional element
+attributes. The XHTML family is designed to accommodate these extensions
+through XHTML modules and techniques for developing new XHTML-conforming
+modules (described in the forthcoming XHTML Modularization specification).
+These modules will permit the combination of existing and
+new feature sets when developing content and when designing new user
+agents.
+
+
Alternate ways of accessing the Internet are constantly being
+introduced. Some estimates indicate that by the year 2002, 75% of
+Internet document viewing will be carried out on these alternate
+platforms. The XHTML family is designed with general user agent
+interoperability in mind. Through a new user agent and document profiling
+mechanism, servers, proxies, and user agents will be able to perform
+best effort content transformation. Ultimately, it will be possible to
+develop XHTML-conforming content that is usable by any XHTML-conforming
+user agent.
The following terms are used in this specification. These
+terms extend the definitions in
+[RFC2119] in ways based upon similar definitions in ISO/IEC
+9945-1:1990 [POSIX.1]:
+
+
+
Implementation-defined
+
+
A value or behavior is implementation-defined when it is left
+to the implementation to define [and document] the corresponding
+requirements for correct document construction.
+
+
May
+
+
With respect to implementations, the word "may" is to be
+interpreted as an optional feature that is not required in this
+specification but can be provided. With respect to Document Conformance, the word "may" means that
+the optional feature must not be used. The term "optional" has
+the same definition as "may".
+
+
Must
+
+
In this specification, the word "must" is to be interpreted
+as a mandatory requirement on the implementation or on Strictly
+Conforming XHTML Documents, depending upon the context. The term
+"shall" has the same definition as "must".
+
+
Reserved
+
+
A value or behavior is unspecified, but it is not allowed to
+be used by Conforming Documents nor to be supported by a
+Conforming User Agents.
+
+
Should
+
+
With respect to implementations, the word "should" is to be
+interpreted as an implementation recommendation, but not a
+requirement. With respect to documents, the word "should" is to
+be interpreted as recommended programming practice for documents
+and a requirement for Strictly Conforming XHTML Documents.
+
+
Supported
+
+
Certain facilities in this specification are optional. If a
+facility is supported, it behaves as specified by this
+specification.
+
+
Unspecified
+
+
When a value or behavior is unspecified, the specification
+defines no portability requirements for a facility on an
+implementation even when faced with a document that uses the
+facility. A document that requires specific behavior in such an
+instance, rather than tolerating any behavior when using that
+facility, is not a Strictly Conforming XHTML Document.
An attribute is a parameter to an element declared in the
+DTD. An attribute's type and value range, including a possible
+default value, are defined in the DTD.
+
+
DTD
+
+
A DTD, or document type definition, is a collection of XML
+declarations that, as a collection, defines the legal structure,
+elements, and
+attributes that are available for use in a document that
+complies to the DTD.
+
+
Document
+
+
A document is a stream of data that, after being combined
+with any other streams it references, is structured such that it
+holds information contained within
+elements that are organized as defined in the associated
+DTD. See Document
+Conformance for more information.
+
+
Element
+
+
An element is a document structuring unit declared in the
+DTD. The element's content model is
+defined in the DTD, and additional
+semantics may be defined in the prose description of the
+element.
Functionality includes elements,
+attributes, and the semantics
+associated with those elements and
+attributes. An implementation
+supporting that functionality is said to provide the necessary
+facilities.
+
+
Implementation
+
+
An implementation is a system that provides collection of
+facilities and services that supports
+this specification. See User Agent
+Conformance for more information.
+
+
Parsing
+
+
Parsing is the act whereby a
+document is scanned, and the information contained within
+the document is filtered into the
+context of the elements in which the
+information is structured.
+
+
Rendering
+
+
Rendering is the act whereby the information in a document is presented. This presentation is
+done in the form most appropriate to the environment (e.g.
+aurally, visually, in print).
+
+
User Agent
+
+
A user agent is an implementation
+that retrieves and processes XHTML documents. See User Agent Conformance for more information.
+
+
Validation
+
+
Validation is a process whereby
+documents are verified against the associated DTD, ensuring that the structure, use of elements, and use of
+attributes are consistent with the definitions in the
+DTD.
A document is well-formed when it
+is structured according to the rules defined in Section 2.1 of
+the XML 1.0 Recommendation [XML].
+Basically, this definition states that elements, delimited by
+their start and end tags, are nested properly within one
+another.
This version of XHTML provides a definition of strictly
+conforming XHTML documents, which are restricted to tags and
+attributes from the XHTML namespace. See Section 3.1.2 for information on using XHTML
+with other namespaces, for instance, to include metadata
+expressed in RDF within XHTML documents.
A Strictly Conforming XHTML Document is a document that
+requires only the facilities described as mandatory in this
+specification. Such a document must meet all of the following
+criteria:
+
+
+
+
It must validate against one of the three DTDs found in Appendix A.
+
+
+
+
The root element of the document must be
+<html>.
+
+
+
+
The root element of the document must designate the XHTML
+namespace using the xmlns attribute [XMLNAMES]. The namespace for XHTML is
+defined to be
+http://www.w3.org/1999/xhtml.
+
+
+
+
There must be a DOCTYPE declaration in the document prior to
+the root element. The public identifier included in
+the DOCTYPE declaration must reference one of the three DTDs
+found in Appendix A using the respective
+Formal Public Identifier. The system identifier may be changed to reflect
+local system conventions.
+
+
+<!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "DTD/xhtml1-strict.dtd">
+
+<!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
+ "DTD/xhtml1-transitional.dtd">
+
+<!DOCTYPE html
+ PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"
+ "DTD/xhtml1-frameset.dtd">
+
Note that in this example, the XML declaration is included. An XML
+declaration like the one above is
+not required in all XML documents. XHTML document authors are strongly encouraged to use XML declarations in all their documents. Such a declaration is required
+when the character encoding of the document is other than the default UTF-8 or
+UTF-16.
The XHTML namespace may be used with other XML namespaces
+as per [XMLNAMES], although such
+documents are not strictly conforming XHTML 1.0 documents as
+defined above. Future work by W3C will address ways to specify
+conformance for documents involving multiple namespaces.
+
+
The following example shows the way in which XHTML 1.0 could
+be used in conjunction with the MathML Recommendation:
The following example shows the way in which XHTML 1.0 markup
+could be incorporated into another XML namespace:
+
+
+
+<?xml version="1.0" encoding="UTF-8"?>
+<!-- initially, the default namespace is "books" -->
+<book xmlns='urn:loc.gov:books'
+ xmlns:isbn='urn:ISBN:0-395-36341-6' xml:lang="en" lang="en">
+ <title>Cheaper by the Dozen</title>
+ <isbn:number>1568491379</isbn:number>
+ <notes>
+ <!-- make HTML the default namespace for a hypertext commentary -->
+ <p xmlns='http://www.w3.org/1999/xhtml'>
+ This is also available <a href="http://www.w3.org/">online</a>.
+ </p>
+ </notes>
+</book>
+
A conforming user agent must meet all of the following
+criteria:
+
+
+
In order to be consistent with the XML 1.0 Recommendation [XML], the user agent must parse and evaluate
+an XHTML document for well-formedness. If the user agent claims
+to be a validating user agent, it must also validate documents
+against their referenced DTDs according to
+[XML].
+
+
When the user agent claims to support
+facilities defined within this specification or required by
+this specification through normative reference, it must do so in
+ways consistent with the facilities' definition.
+
+
When a user agent processes an XHTML document as generic XML,
+it shall only recognize attributes of type
+ID (e.g. the id attribute on most XHTML elements)
+as fragment identifiers.
+
+
If a user agent encounters an element it does not recognize,
+it must render the element's content.
+
+
If a user agent encounters an attribute it does not
+recognize, it must ignore the entire attribute specification
+(i.e., the attribute and its value).
+
+
If a user agent encounters an attribute value it doesn't
+recognize, it must use the default attribute value.
+
+
If it encounters an entity reference (other than one
+of the predefined entities) for which the User Agent has
+processed no declaration (which could happen if the declaration
+is in the external subset which the User Agent hasn't read), the entity
+reference should be rendered as the characters (starting
+with the ampersand and ending with the semi-colon) that
+make up the entity reference.
+
+
When rendering content, User Agents that encounter
+characters or character entity references that are recognized but not renderable should display the document in such a way that it is obvious to the user that normal rendering has not taken place.
+
+
+The following characters are defined in [XML] as whitespace characters:
+
+
+
Space ( )
+
Tab (	)
+
Carriage return (
)
+
Line feed (
)
+
+
+
+The XML processor normalizes different system's line end codes into one
+single line-feed character, that is passed up to the application. The XHTML
+user agent in addition, must treat the following characters as whitespace:
+
+
+
+
Form feed ()
+
Zero-width space (​)
+
+
+
+In elements where the 'xml:space' attribute is set to 'preserve', the user
+agent must leave all whitespace characters intact (with the exception of
+leading and trailing whitespace characters, which should be removed).
+Otherwise, whitespace
+is handled according to the following rules:
+
+
+
+
+All whitespace surrounding block elements should be removed.
+
+
+Comments are removed entirely and do not affect whitespace handling. One
+whitespace character on either side of a comment is treated as two white
+space characters.
+
+
+Leading and trailing whitespace inside a block element must be removed.
+
+
Line feed characters within a block element must be converted into a
+space (except when the 'xml:space' attribute is set to 'preserve').
+
+
+A sequence of white space characters must be reduced to a single space
+character (except when the 'xml:space' attribute is set to 'preserve').
+
+
+With regard to rendition,
+the User Agent should render the content in a
+manner appropriate to the language in which the content is written.
+In languages whose primary script is Latinate, the ASCII space
+character is typically used to encode both grammatical word boundaries and
+typographic whitespace; in languages whose script is related to Nagari
+(e.g., Sanskrit, Thai, etc.), grammatical boundaries may be encoded using
+the ZW 'space' character, but will not typically be represented by
+typographic whitespace in rendered output; languages using Arabiform scripts
+may encode typographic whitespace using a space character, but may also use
+the ZW space character to delimit 'internal' grammatical boundaries (what
+look like words in Arabic to an English eye frequently encode several words,
+e.g. 'kitAbuhum' = 'kitAbu-hum' = 'book them' == their book); and languages
+in the Chinese script tradition typically neither encode such delimiters nor
+use typographic whitespace in this way.
+
+
+
+
Whitespace in attribute values is processed according to [XML].
Well-formedness is a new concept
+introduced by [XML]. Essentially this
+means that all elements must either have closing tags or be
+written in a special form (as described below), and that all the
+elements must nest.
+
+
Although overlapping is illegal in SGML, it was widely
+tolerated in existing browsers.
XHTML documents must use lower case for all HTML element and
+attribute names. This difference is necessary because XML is
+case-sensitive e.g. <li> and <LI> are different
+tags.
In SGML-based HTML 4 certain elements were permitted to omit
+the end tag; with the elements that followed implying closure.
+This omission is not permitted in XML-based XHTML. All elements
+other than those declared in the DTD as EMPTY must
+have an end tag.
+
+
+
CORRECT: terminated elements
+
+
<p>here is a paragraph.</p><p>here is
+another paragraph.</p>
+
+
+
+
INCORRECT: unterminated elements
+
+
<p>here is a paragraph.<p>here is another
+paragraph.
XML does not support attribute minimization. Attribute-value
+pairs must be written in full. Attribute names such as
+compact and checked cannot occur in elements
+without their value being specified.
Empty elements must either have an end tag or the start tag must end with />. For instance,
+<br/> or <hr></hr>. See HTML Compatibility Guidelines for information on ways to
+ensure this is backward compatible with HTML 4 user agents.
In attribute values, user agents will strip leading and
+trailing whitespace from attribute values and map sequences
+of one or more whitespace characters (including line breaks) to
+a single inter-word space (an ASCII space character for western
+scripts). See
+Section 3.3.3 of [XML].
In XHTML, the script and style elements are declared as having
+#PCDATA content. As a result, < and
+& will be treated as the start of markup, and
+entities such as < and &
+will be recognized as entity references by the XML processor to
+< and & respectively. Wrapping
+the content of the script or style element within a
+CDATA marked section avoids the expansion of these
+entities.
CDATA sections are recognized by the XML
+processor and appear as nodes in the Document Object Model, see
+
+Section 1.3 of the DOM Level 1 Recommendation [DOM].
+
+
An alternative is to use external script and style
+documents.
SGML gives the writer of a DTD the ability to exclude specific
+elements from being contained within an element. Such
+prohibitions (called "exclusions") are not possible in XML.
+
+
For example, the HTML 4 Strict DTD forbids the nesting of an
+'a' element within another 'a' element
+to any descendant depth. It is not possible to spell out such
+prohibitions in XML. Even though these prohibitions cannot be
+defined in the DTD, certain elements should not be nested. A
+summary of such elements and the elements that should not be
+nested in them is found in the normative
+Appendix B.
HTML 4 defined the name attribute for the elements
+a,
+applet, form, frame,
+iframe, img, and map.
+HTML 4 also introduced
+the id attribute. Both of these attributes are designed to be
+used as fragment identifiers.
+
In XML, fragment identifiers are of type ID, and
+there can only be a single attribute of type ID per element.
+Therefore, in XHTML 1.0 the id
+attribute is defined to be of type ID. In order to
+ensure that XHTML 1.0 documents are well-structured XML documents, XHTML 1.0
+documents MUST use the id attribute when defining fragment
+identifiers, even on elements that historically have also had a
+name attribute.
+See the HTML Compatibility
+Guidelines for information on ensuring such anchors are backwards
+compatible when serving XHTML documents as media type text/html.
+
+
Note that in XHTML 1.0, the name attribute of these
+elements is formally deprecated, and will be removed in a
+subsequent version of XHTML.
Although there is no requirement for XHTML 1.0 documents to be
+compatible with existing user agents, in practice this is easy to
+accomplish. Guidelines for creating compatible documents can be
+found in Appendix C.
As of the publication of this recommendation, the general
+recommended MIME labeling for XML-based applications
+has yet to be resolved.
+
+
However, XHTML Documents which follow the guidelines set forth
+in Appendix C, "HTML Compatibility Guidelines" may be
+labeled with the Internet Media Type "text/html", as they
+are compatible with most HTML browsers. This document
+makes no recommendation about MIME labeling of other
+XHTML documents.
XHTML 1.0 provides the basis for a family of document types
+that will extend and subset XHTML, in order to support a wide
+range of new devices and applications, by defining modules and
+specifying a mechanism for combining these modules. This
+mechanism will enable the extension and sub-setting of XHTML 1.0
+in a uniform way through the definition of new modules.
As the use of XHTML moves from the traditional desktop user
+agents to other platforms, it is clear that not all of the XHTML
+elements will be required on all platforms. For example a hand
+held device or a cell-phone may only support a subset of XHTML
+elements.
+
+
The process of modularization breaks XHTML up into a series of
+smaller element sets. These elements can then be recombined to
+meet the needs of different communities.
+
+
These modules will be defined in a later W3C document.
A document profile specifies the syntax and semantics of a set
+of documents. Conformance to a document profile provides a basis
+for interoperability guarantees. The document profile specifies
+the facilities required to process documents of that type, e.g.
+which image formats can be used, levels of scripting, style sheet
+support, and so on.
+
+
For product designers this enables various groups to define
+their own standard profile.
+
+
For authors this will obviate the need to write several
+different versions of documents for different clients.
+
+
For special groups such as chemists, medical doctors, or
+mathematicians this allows a special profile to be built using
+standard HTML elements plus a group of elements geared to the
+specialist's needs.
These DTDs and entity sets form a normative part of this
+specification. The complete set of DTD files together with an XML
+declaration and SGML Open Catalog is included in the zip file for this specification.
These DTDs approximate the HTML 4 DTDs. It is likely that
+when the DTDs are modularized, a method of DTD construction will
+be employed that corresponds more closely to HTML 4.
The XHTML entity sets are the same as for HTML 4, but have
+been modified to be valid XML 1.0 entity declarations. Note the
+entity for the Euro currency sign (€ or
+€ or €) is defined
+as part of the special characters.
The following elements have prohibitions on which elements
+they can contain (see Section 4.9). This
+prohibition applies to all depths of nesting, i.e. it contains
+all the descendant elements.
+
+
a
+
+cannot contain other a elements.
+
pre
+
cannot contain the img, object,
+big, small, sub, or
+sup elements.
+
+
button
+
cannot contain the input, select,
+textarea, label, button,
+form, fieldset, iframe or
+isindex elements.
This appendix summarizes design guidelines for authors who
+wish their XHTML documents to render on existing HTML user
+agents.
+
+
C.1 Processing Instructions
+
Be aware that processing instructions are rendered on some
+user agents. However, also note that when the XML declaration is not included
+in a document, the document can only use the default character encodings UTF-8
+or UTF-16.
+
+
C.2 Empty Elements
+
Include a space before the trailing / and
+> of empty elements, e.g.
+<br />,
+<hr /> and <img
+src="karen.jpg" alt="Karen" />. Also, use the
+minimized tag syntax for empty elements, e.g. <br />, as the alternative syntax <br></br> allowed by XML
+gives uncertain results in many existing user agents.
+
+
C.3 Element Minimization and Empty Element Content
+
Given an empty instance of an element whose content model is
+not EMPTY (for example, an empty title or paragraph)
+do not use the minimized form (e.g. use
+<p> </p> and not
+<p />).
+
+
C.4 Embedded Style Sheets and Scripts
+
Use external style sheets if your style sheet uses
+< or & or ]]> or --. Use
+external scripts if your script uses < or
+& or ]]> or --. Note that XML parsers
+are permitted to silently remove the contents of comments. Therefore, the historical
+practice of "hiding" scripts and style sheets within comments to make the
+documents backward compatible is likely to not work as expected in XML-based
+implementations.
+
+
C.5 Line Breaks within Attribute Values
+
Avoid line breaks and multiple whitespace characters within
+attribute values. These are handled inconsistently by user
+agents.
+
+
C.6 Isindex
+
Don't include more than one isindex element in
+the document head. The isindex element
+is deprecated in favor of the input element.
+
+
C.7 The lang and xml:lang Attributes
+
Use both the lang and xml:lang
+attributes when specifying the language of an element. The value
+of the xml:lang attribute takes precedence.
+
+
C.8 Fragment Identifiers
+
In XML, URIs [RFC2396] that end with fragment identifiers of the form
+"#foo" do not refer to elements with an attribute
+name="foo"; rather, they refer to elements with an
+attribute defined to be of type ID, e.g., the
+id attribute in HTML 4. Many existing HTML clients don't
+support the use of ID-type attributes in this way,
+so identical values may be supplied for both of these attributes to ensure
+maximum forward and backward compatibility (e.g., <a id="foo" name="foo">...</a>).
+
+
Further, since the set of
+legal values for attributes of type ID is much smaller than
+for those of type CDATA, the type of the name
+attribute has been changed to NMTOKEN. This attribute is
+constrained such that it can only have the same values as type
+ID, or as the Name production in XML 1.0 Section
+2.5, production 5. Unfortunately, this constraint cannot be expressed in the
+XHTML 1.0 DTDs. Because of this change, care must be taken when
+converting existing HTML documents. The values of these attributes
+must be unique within the document, valid, and any references to these
+fragment identifiers (both
+internal and external) must be updated should the values be changed during
+conversion.
+
Finally, note that XHTML 1.0 has deprecated the
+name attribute of the a, applet, form, frame, iframe, img, and map
+elements, and it will be
+removed from XHTML in subsequent versions.
+
+
C.9 Character Encoding
+
To specify a character encoding in the document, use both the
+encoding attribute specification on the xml declaration (e.g.
+<?xml version="1.0"
+encoding="EUC-JP"?>) and a meta http-equiv statement
+(e.g. <meta http-equiv="Content-type"
+content='text/html; charset="EUC-JP"' />). The
+value of the encoding attribute of the xml processing instruction
+takes precedence.
+
+
C.10 Boolean Attributes
+
Some HTML user agents are unable to interpret boolean
+attributes when these appear in their full (non-minimized) form,
+as required by XML 1.0. Note this problem doesn't affect user
+agents compliant with HTML 4. The following attributes are
+involved: compact, nowrap,
+ismap, declare, noshade,
+checked, disabled, readonly,
+multiple, selected,
+noresize, defer.
+
+
C.11 Document Object Model and XHTML
+
+The Document Object Model level 1 Recommendation [DOM]
+defines document object model interfaces for XML and HTML 4. The HTML 4
+document object model specifies that HTML element and attribute names are
+returned in upper-case. The XML document object model specifies that
+element and attribute names are returned in the case they are specified. In
+XHTML 1.0, elements and attributes are specified in lower-case. This apparent difference can be
+addressed in two ways:
+
+
+
Applications that access XHTML documents served as Internet media type
+text/html
+via the DOM can use the HTML DOM,
+and can rely upon element and attribute names being returned in
+upper-case from those interfaces.
+
Applications that access XHTML documents served as Internet media types
+text/xml or application/xml
+can also use the XML DOM. Elements and attributes will be returned in lower-case.
+Also, some XHTML elements may or may
+not appear
+in the object tree because they are optional in the content model
+(e.g. the tbody element within
+table). This occurs because in HTML 4 some elements were
+permitted to be minimized such that their start and end tags are both omitted
+(an SGML feature).
+This is not possible in XML. Rather than require document authors to insert
+extraneous elements, XHTML has made the elements optional.
+Applications need to adapt to this
+accordingly.
+
+
+
C.12 Using Ampersands in Attribute Values
+
+When an attribute value contains an ampersand, it must be expressed as a character
+entity reference
+(e.g. "&"). For example, when the
+href attribute
+of the a element refers to a
+CGI script that takes parameters, it must be expressed as
+http://my.site.dom/cgi-bin/myscript.pl?class=guest&name=user
+rather than as
+http://my.site.dom/cgi-bin/myscript.pl?class=guest&name=user.
+
+
+
C.13 Cascading Style Sheets (CSS) and XHTML
+
+
The Cascading Style Sheets level 2 Recommendation [CSS2] defines style
+properties which are applied to the parse tree of the HTML or XML
+document. Differences in parsing will produce different visual or
+aural results, depending on the selectors used. The following hints
+will reduce this effect for documents which are served without
+modification as both media types:
+
+
+
+CSS style sheets for XHTML should use lower case element and
+attribute names.
+
+
+
In tables, the tbody element will be inferred by the parser of an
+HTML user agent, but not by the parser of an XML user agent. Therefore
+you should always explicitly add a tbody element if it is referred to
+in a CSS selector.
+
+
Within the XHTML name space, user agents are expected to
+recognize the "id" attribute as an attribute of type ID.
+Therefore, style sheets should be able to continue using the
+shorthand "#" selector syntax even if the user agent does not read
+the DTD.
+
+
Within the XHTML name space, user agents are expected to
+recognize the "class" attribute. Therefore, style sheets should be
+able to continue using the shorthand "." selector syntax.
+
+
+CSS defines different conformance rules for HTML and XML documents;
+be aware that the HTML rules apply to XHTML documents delivered as
+HTML and the XML rules apply to XHTML documents delivered as XML.
This specification was written with the participation of the
+members of the W3C HTML working group:
+
+
+
Steven Pemberton, CWI (HTML Working Group Chair)
+Murray Altheim, Sun Microsystems
+Daniel Austin, AskJeeves (CNET: The Computer Network through July 1999)
+Frank Boumphrey, HTML Writers Guild
+John Burger, Mitre
+Andrew W. Donoho, IBM
+Sam Dooley, IBM
+Klaus Hofrichter, GMD
+Philipp Hoschka, W3C
+Masayasu Ishikawa, W3C
+Warner ten Kate, Philips Electronics
+Peter King, Phone.com
+Paula Klante, JetForm
+Shin'ichi Matsui, Panasonic (W3C visiting engineer through September 1999)
+Shane McCarron, Applied Testing and Technology (The Open Group through August
+1999)
+Ann Navarro, HTML Writers Guild
+Zach Nies, Quark
+Dave Raggett, W3C/HP (W3C lead for HTML)
+Patrick Schmitz, Microsoft
+Sebastian Schnitzenbaumer, Stack Overflow
+Peter Stark, Phone.com
+Chris Wilson, Microsoft
+Ted Wugofski, Gateway 2000
+Dan Zigmond, WebTV Networks
"ISO/IEC 9945-1:1990 Information Technology - Portable
+Operating System Interface (POSIX) - Part 1: System Application
+Program Interface (API) [C Language]", Institute of Electrical
+and Electronics Engineers, Inc, 1990.
"Namespaces in XML", T. Bray, D. Hollander, A. Layman, 14
+January 1999.
+XML namespaces provide a simple method for qualifying names used
+in XML documents by associating them with namespaces identified
+by URI.
+Latest version available at:
+http://www.w3.org/TR/REC-xml-names
Instances