Real pickling is then done with xpString.
+>Real pickling is then done with xpText.
One of the most often used pimitive picklers. Applicable for all
types which are instances of Read
Real pickling is then done with xpString.
+>Real pickling is then done with xpText.
One of the most often used pimitive picklers. Applicable for all
types which are instances of Read
convenient op for adding attributes or children to a node
-
usage: tf += cf
-
the tf arrow computes an element node, and all trees computed by cf are
- added to this node, if a tree is an attribute, it is inserted in the attribute list
- else it is appended to the content list.
-
attention: do not build long content list this way because += is implemented by ++
-
and results in the XML fragment: <a href="page.html" name="here">look here</a>
-
advantage of the += operator is, that attributes and content can be added
- any time step by step.
- if tf computes a whole list of trees, e.g. a list of "td" or "tr" elements,
- the attributes or content is added to all trees. useful for adding "class" or "style" attributes
- to table elements.
-
These are separated, because they are not needed for document processing,
-only when processing the DTD, e.g. for generating access funtions for the toolbox
-from a DTD (se example DTDtoHaskell in the examples directory)
-
convenient op for adding attributes or children to a node
+
usage: tf += cf
+
the tf arrow computes an element node, and all trees computed by cf are
+ added to this node, if a tree is an attribute, it is inserted in the attribute list
+ else it is appended to the content list.
+
attention: do not build long content list this way because += is implemented by ++
+
and results in the XML fragment: <a href="page.html" name="here">look here</a>
+
advantage of the += operator is, that attributes and content can be added
+ any time step by step.
+ if tf computes a whole list of trees, e.g. a list of "td" or "tr" elements,
+ the attributes or content is added to all trees. useful for adding "class" or "style" attributes
+ to table elements.
+
These are separated, because they are not needed for document processing,
+only when processing the DTD, e.g. for generating access funtions for the toolbox
+from a DTD (se example DTDtoHaskell in the examples directory)
+
A state is needed for global processing options,
-like encoding options, document base URI, trace levels
-and error message handling
+ like encoding options, document base URI, trace levels
+ and error message handling
The state is separated into a user defined state
-and a system state. The system state contains variables
-for error message handling, for tracing, for the document base
-for accessing XML documents with relative references, e.g. DTDs,
-and a global key value store. This assoc list has strings as keys
-and lists of XmlTrees as values. It is used to store arbitrary
-XML and text values, e.g. user defined global options.
+ and a system state. The system state contains variables
+ for error message handling, for tracing, for the document base
+ for accessing XML documents with relative references, e.g. DTDs,
+ and a global key value store. This assoc list has strings as keys
+ and lists of XmlTrees as values. It is used to store arbitrary
+ XML and text values, e.g. user defined global options.
The user defined part of the store is in the default case empty, defined as ().
-It can be extended with an arbitray data type
+ It can be extended with an arbitray data type
The expession is build up from simple arrows acting as predicate (mkPrimA) for
+ an XmlTree and of the usual cobinators for sequence (mkSeq), repetition
+ (mkStar, mkRep', mkRng) and choice (mkAlt, mkOpt)
+
a first part matching the regex and a rest,
+ if a prefix of the input sequence does not match the regex, the arrow fails
+ else the pair containing the result lists is returned
+
scan the input sequence with a regex and give the result as a list of lists of trees back
+ the regex must at least match one input tree, so the empty sequence should not match the regex
+
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.
-
Type for the namespace association list, used when propagating namespaces by
- modifying the QName values in a tree
+ modifying the QName values in a tree
Interface for XmlArrow to basic data types NTree and XmlTree
+
If this module must be used in code working with arrows,
+ it should be imported qualified e.g. as XN, to prevent name clashes.
+
For code working on the "node and tree level" this module
+ is the interface for writing code without using the
+ constructor functions of XNode and NTree directly
+
error message handler for collecting all error messages
- all messages are stored under attribute a_error_log
+ all messages are stored under attribute a_error_log
they can be read with getSysParamTree a_error_log or by
@@ -2128,7 +2498,10 @@
>
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
+>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
setStatus :: Int -> String -> XmlFilter :: Int -> String -> XmlFilter
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
+ to the attributes of a document root node and remove the children when level is greater or equal to c_err
check whether tree is a document root and the status attribute has a value less than c_err
+>check whether tree is a document root and the status attribute has a value less than c_err
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
-
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
+
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.
+
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.
+
This module provides functions for checking special IDIDREFIDREFS 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.
+
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.
+
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
+
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,
+ and attributes a_status and a_module for error level and the module,
where the error occured.
parses a text node with parseXmlDoc, processes the DTD and general entities
+>parses a text node with parseXmlDoc, processes the DTD and general entities
and transforms all char references into characters
a_remove_whitespace : remove all whitespace, used for document indentation, else skip this step (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_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_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_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
+> a_collect_errors : all error messages are collected during processing and appended to the result document
for further processing within the calling modules
a_proxy : proxy for http access, e.g. www-cache:3128
+> 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_use_curl : for http access via external programm curl, default is native HTTP access
a_options_curl : more options for external program curl
+> a_options_curl : more options for external program curl
a_source : the document source url
+> a_source : the document source url
reads document "test.xml" without validation and default encoding isoLatin1
+>reads document "test.xml" without validation and default encoding isoLatin1
a_indent : indent document for readability, (default: no indentation)
+> a_indent : indent document for readability, (default: no indentation)
a_remove_whitespace : remove all redundant whitespace for shorten text (default: no removal)
+> 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_file : destination file for document, default is "-" for stdout
a_output_encoding : encoding of document, default is a_encoding or utf8
+> a_output_encoding : encoding of document, default is a_encoding or utf8
a_output_xml : (default) issue XML: quote special XML chars >,<,",',&
+> a_output_xml : (default) issue XML: quote special XML chars >,<,",',&
add XML processing instruction
- and encode document with respect to a_output_encoding,
+ 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_tree : show tree representation of document (for debugging)
a_show_haskell : show Haskell representaion of document (for debugging)
+> a_show_haskell : show Haskell representaion of document (for debugging)
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
+ 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 module contains the core-functions of the XPath function library.
- All functions are implemented as XFct. Each XFct contains the evaluation context,
- the variable environment and the function arguments.
+ All functions are implemented as XFct. Each XFct contains the evaluation context,
+ the variable environment and the function arguments.
hxt-8.0.0: A collection of tools for processing XML with Haskell.
The Haskell XML Toolbox bases on the ideas of HaXml and HXML, but introduces a more general approach for processing XML with Haskell. The Haskell XML Toolbox uses a generic data model for representing XML documents, including the DTD subset and the document subset, in Haskell. It contains a validating XML parser, a HTML parser, namespace support, an XPath expression evaluator, an XSLT library, a RelaxNG schema validator and funtions for serialization and deserialization of user defined data. The libraray make extensive use of the arrow approach for processing XML.
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Control.Arrow.ArrowIO
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id: ArrowIO.hs,v 1.6 2005/09/02 17:09:39 hxml Exp $
+
+Lifting of IO actions to arrows
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleControl.Arrow.ArrowIO
+(ArrowIO(..)
+,ArrowIOIf(..)
+)
+where
+
+importControl.Arrow
+
+-- | the interface for converting an IO action into an arrow
+
+classArrowa=>ArrowIOawhere
+
+-- | construct an arrow from an IO action
+arrIO::(b->IOc)->abc
+
+-- | construct an arrow from an IO action without any parameter
+arrIO0::IOc->abc
+arrIO0f=arrIO(constf)
+
+-- | construction of a 2 argument arrow from a binary IO action
+-- |
+-- | example: @ a1 &&& a2 >>> arr2 f @
+
+arrIO2::(b1->b2->IOc)->a(b1,b2)c
+arrIO2f=arrIO(\~(x1,x2)->fx1x2)
+
+-- | construction of a 3 argument arrow from a 3-ary IO action
+-- |
+-- | example: @ a1 &&& a2 &&& a3 >>> arr3 f @
+
+arrIO3::(b1->b2->b3->IOc)->a(b1,(b2,b3))c
+arrIO3f=arrIO(\~(x1,~(x2,x3))->fx1x2x3)
+
+-- | construction of a 4 argument arrow from a 4-ary IO action
+-- |
+-- | example: @ a1 &&& a2 &&& a3 &&& a4 >>> arr4 f @
+
+arrIO4::(b1->b2->b3->b4->IOc)->a(b1,(b2,(b3,b4)))c
+arrIO4f=arrIO(\~(x1,~(x2,~(x3,x4)))->fx1x2x3x4)
+
+
+-- | the interface for converting an IO predicate into a list arrow
+
+class(Arrowa,ArrowIOa)=>ArrowIOIfawhere
+
+-- | builds an arrow from an IO predicate
+--
+-- if the predicate holds, the single list containing the input is returned, else the empty list,
+-- similar to 'Control.Arrow.ArrowList.isA'
+
+isIOA::(b->IOBool)->abb
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Control.Arrow.ArrowIf
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id: ArrowIf.hs,v 1.8 2006/05/04 14:17:53 hxml Exp $
+
+Conditionals for List Arrows
+
+This module defines conditional combinators for list arrows.
+
+The empty list as result represents False, none empty lists True.
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleControl.Arrow.ArrowIf
+(moduleControl.Arrow.ArrowIf
+)
+where
+
+importControl.Arrow
+importControl.Arrow.ArrowList
+
+importData.List
+(partition)
+
+-- ------------------------------------------------------------
+
+-- | The interface for arrows as conditionals.
+--
+-- Requires list arrows because False is represented as empty list, True as none empty lists.
+--
+-- Only 'ifA' and 'orElse' don't have default implementations
+
+classArrowLista=>ArrowIfawhere
+
+-- | if lifted to arrows
+
+ifA::abc->abd->abd->abd
+
+-- | shortcut: @ ifP p = ifA (isA p) @
+
+ifP::(b->Bool)->abd->abd->abd
+ifPp=ifA(isAp)
+
+-- | negation: @ neg f = ifA f none this @
+
+neg::abc->abb
+negf=ifAfnonethis
+
+-- | @ f \`when\` g @ : when the predicate g holds, f is applied, else the identity filter this
+
+when::abb->abc->abb
+f`when`g=ifAgfthis
+
+-- | shortcut: @ f \`whenP\` p = f \`when\` (isA p) @
+
+whenP::abb->(b->Bool)->abb
+f`whenP`g=ifPgfthis
+
+-- | @ f \`whenNot\` g @ : when the predicate g does not hold, f is applied, else the identity filter this
+
+whenNot::abb->abc->abb
+f`whenNot`g=ifAgthisf
+
+-- | like 'whenP'
+
+whenNotP::abb->(b->Bool)->abb
+f`whenNotP`g=ifPgthisf
+
+-- | @ g \`guards\` f @ : when the predicate g holds, f is applied, else none
+
+guards::abc->abd->abd
+f`guards`g=ifAfgnone
+
+-- | like 'whenP'
+
+guardsP::(b->Bool)->abd->abd
+f`guardsP`g=ifPfgnone
+
+-- | shortcut for @ f `guards` this @
+
+filterA::abc->abb
+filterAf=ifAfthisnone
+
+-- | @ f \`containing\` g @ : keep only those results from f for which g holds
+--
+-- definition: @ f \`containing\` g = f >>> g \`guards\` this @
+
+containing::abc->acd->abc
+f`containing`g=f>>>g`guards`this
+
+-- | @ f \`notContaining\` g @ : keep only those results from f for which g does not hold
+--
+-- definition: @ f \`notContaining\` g = f >>> ifA g none this @
+
+notContaining::abc->acd->abc
+f`notContaining`g=f>>>ifAgnonethis
+
+-- | @ f \`orElse\` g @ : directional choice: if f succeeds, the result of f is the result, else g is applied
+orElse::abc->abc->abc
+
+-- | generalisation of 'orElse' for multi way branches like in case expressions.
+--
+-- An auxiliary data type 'IfThen' with an infix constructor ':->' is used for writing multi way branches
+--
+-- example: @ choiceA [ p1 :-> e1, p2 :-> e2, this :-> default ] @
+choiceA::[IfThen(abc)(abd)]->abd
+choiceA=foldrifA'none
+where
+ifA'(g:->f)=ifAgf
+
+
+-- | tag a value with Left or Right, if arrow has success, input is tagged with Left, else with Right
+tagA::abc->ab(Eitherbb)
+tagAp=ifAp(arrLeft)(arrRight)
+
+
+-- | split a list value with an arrow and returns a pair of lists.
+-- This is the arrow version of 'span'. The arrow is deterministic.
+--
+-- example: @ runLA (spanA (isA (\/= \'-\'))) \"abc-def\" @ gives @ [(\"abc\",\"-def\")] @ as result
+
+spanA::abb->a[b]([b],[b])
+spanAp=ifA(arrL(take1)>>>p)
+(arrhead&&&(arrtail>>>spanAp)
+>>>
+arr(\~(x,~(xs,ys))->(x:xs,ys))
+)
+(arr(\l->([],l)))
+
+-- | partition a list of values into a pair of lists
+--
+-- This is the arrow Version of 'Data.List.partition'
+
+partitionA::abb->a[b]([b],[b])
+partitionAp=listA(arrLid>>>tagAp)
+>>^
+((\~(l1,l2)->(unTagl1,unTagl2)).partition(isLeft))
+where
+isLeft(Left_)=True
+isLeft_=False
+unTag=map(eitheridid)
+
+-- ------------------------------------------------------------
+
+-- | an auxiliary data type for 'choiceA'
+
+dataIfThenab=a:->b
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Control.Arrow.ArrowList
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id: ArrowList.hs,v 1.11 2006/06/01 12:59:04 hxml Exp $
+
+The List Arrow Class
+
+This module defines the interface for list arrows.
+
+A list arrow is a function, that gives a list of results
+for a given argument. A single element result represents a normal function.
+An empty list oven indicates, the function is undefined for the given argument.
+The empty list may also represent False, none empty lists True.
+A list with more than one element gives all results for a nondeterministic function.
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleControl.Arrow.ArrowList
+(ArrowList(..)
+)
+where
+
+importControl.Arrow
+
+infixl8>>.,>.
+
+infixl2$<,$<<,$<<<,$<<<<
+infixl2$<$
+
+-- ------------------------------------------------------------
+
+-- | The interface for list arrows
+--
+-- Only 'mkA', 'arr2A', 'isA' '(>>.)' don't have default implementations
+
+class(Arrowa,ArrowPlusa,ArrowZeroa,ArrowApplya)=>ArrowListawhere
+
+-- | construction of a 2 argument arrow from a binary function
+-- |
+-- | example: @ a1 &&& a2 >>> arr2 f @
+
+arr2::(b1->b2->c)->a(b1,b2)c
+arr2=arr.uncurry
+
+-- | construction of a 3 argument arrow from a 3-ary function
+-- |
+-- | example: @ a1 &&& a2 &&& a3 >>> arr3 f @
+
+arr3::(b1->b2->b3->c)->a(b1,(b2,b3))c
+arr3f=arr(\~(x1,~(x2,x3))->fx1x2x3)
+
+-- | construction of a 4 argument arrow from a 4-ary function
+-- |
+-- | example: @ a1 &&& a2 &&& a3 &&& a4 >>> arr4 f @
+
+arr4::(b1->b2->b3->b4->c)->a(b1,(b2,(b3,b4)))c
+arr4f=arr(\~(x1,~(x2,~(x3,x4)))->fx1x2x3x4)
+
+-- | construction of a 2 argument arrow from a singe argument arrow
+
+arr2A::(b->acd)->a(b,c)d
+
+-- | constructor for a list arrow from a function with a list as result
+
+arrL::(b->[c])->abc
+
+-- | constructor for a list arrow with 2 arguments
+
+arr2L::(b->c->[d])->a(b,c)d
+arr2L=arrL.uncurry
+
+-- | constructor for a const arrow: @ constA = arr . const @
+
+constA::c->abc
+constA=arr.const
+
+-- | constructor for a const arrow: @ constL = arrL . const @
+
+constL::[c]->abc
+constL=arrL.const
+
+-- | builds an arrow from a predicate.
+-- If the predicate holds, the single list containing the input is returned, else the empty list
+
+isA::(b->Bool)->abb
+
+-- | combinator for converting the result of a list arrow into another list
+--
+-- example: @ foo >>. reverse @ reverses the the result of foo
+--
+-- example: @ foo >>. take 1 @ constructs a deterministic version of foo by deleting all further results
+
+(>>.)::abc->([c]->[d])->abd
+
+-- | combinator for converting the result of an arrow into a single element result
+
+(>.)::abc->([c]->d)->abd
+af>.f=af>>.((:[]).f)
+
+-- | combinator for converting an arrow into a determinstic version with all results collected in a single element list
+--
+-- @ listA af = af >>. (:[]) @
+--
+-- this is useful when the list of results computed by an arrow must be manipulated (e.g. sorted)
+--
+-- example for sorting the results of a filter
+--
+-- > collectAndSort :: a b c -> a b c
+-- >
+-- > collectAndSort collect = listA collect >>> arrL sort
+
+listA::abc->ab[c]
+listAaf=af>>.(:[])
+
+-- | the inverse of 'listA'
+--
+-- @ listA af >>> unlistA = af @
+--
+-- unlistA is defined as @ arrL id @
+
+unlistA::a[b]b
+unlistA=arrLid
+
+-- | the identity arrow, alias for returnA
+
+this::abb
+this=returnA
+
+-- | the zero arrow, alias for zeroArrow
+
+none::abc
+none=zeroArrow
+
+-- | converts an arrow, that may fail, into an arrow that always succeeds
+--
+-- example: @ withDefault none \"abc\" @ is equivalent to @ constA \"abc\" @
+
+withDefault::abc->c->abc
+withDefaultad=a>>.\x->ifnullxthen[d]elsex
+
+-- | makes a list arrow deterministic, the number of results is at most 1
+--
+-- definition
+--
+-- > single f = f >>. take 1
+--
+-- examples with strings:
+--
+-- > runLA ( single none ) "x" == []
+-- > runLA ( single this ) "x" == ["x"]
+-- > runLA ( single
+-- > (constA "y"
+-- > <+> this ) ) "x" == ["y"]
+
+single::abc->abc
+singlef=f>>.take1
+
+-- | compute an arrow from the input and apply the arrow to this input
+--
+-- definition: @ (f &&& this) >>> app @
+--
+-- in a point free style, there is no way to use an argument in 2 places,
+-- this is a combinator for simulating this. first the argument is used to compute an arrow,
+-- then this new arrow is applied to the input
+--
+-- applyA coresponds to: @ apply f x = let g = f x in g x @
+--
+-- see also: '$<', '$<<', '$<<<', '$<<<<', '$<$'
+
+applyA::ab(abc)->abc
+applyAf=(f&&&this)>>>app
+
+-- | compute the parameter for an arrow with extra parameters from the input
+-- and apply the arrow for all parameter values to the input
+--
+-- a kind of \"function call\" for arrows, useful for joining arrows
+--
+-- > infixl 2 ($<)
+--
+-- definition:
+--
+-- > g $< f = applyA (f >>> arr g)
+--
+-- if @f@ fails, the whole arrow fails, e.g. @ g \$\< none == none @
+--
+-- if @f@ computes n values and @g@ is deterministic, the whole arrow computes n values
+--
+-- examples with simple list arrows with strings
+--
+-- > prefixString :: String -> a String String
+-- > prefixString s = arr (s++)
+-- >
+-- > runLA ( prefixString $< none ) "x" == []
+-- > runLA ( prefixString $< constA "y" ) "x" == ["yx"]
+-- > runLA ( prefixString $< this ) "x" == ["xx"]
+-- > runLA ( prefixString $< constA "y"
+-- > <+> constA "z" ) "x" == ["yx","zx"]
+-- > runLA ( prefixString $< constA "y"
+-- > <+> this
+-- > <+> constA "z" ) "x" == ["yx","xx","zx"]
+--
+-- see also: 'applyA', '$<<', '$<<<', '$<<<<', '$<$'
+
+($<)::(c->abd)->abc->abd
+g$<f=applyA(f>>>arrg)
+
+-- | binary version of '$<'
+--
+-- example with simple list arrows with strings
+--
+-- > infixString :: String -> String -> a String String
+-- > infixString s1 s2
+-- > = arr (\ s -> s1 ++ s ++ s2)
+-- >
+-- > runLA ( infixString $<< constA "y" &&& constA "z" ) "x" = ["yxz"]
+-- > runLA ( infixString $<< this &&& this ) "x" = ["xxx"]
+-- > runLA ( infixString $<< constA "y"
+-- > &&& (constA "z" <+> this) ) "x" = ["yxz", "yxx"]
+
+($<<)::(c1->c2->abd)->ab(c1,c2)->abd
+f$<<g=applyA(g>>>arr2f)
+
+-- | version of '$<' for arrows with 3 extra parameters
+--
+-- typical usage
+--
+-- > f $<<< g1 &&& g2 &&& g3
+
+($<<<)::(c1->c2->c3->abd)->ab(c1,(c2,c3))->abd
+f$<<<g=applyA(g>>>arr3f)
+
+-- | version of '$<' for arrows with 4 extra parameters
+--
+-- typical usage
+--
+-- > f $<<<< g1 &&& g2 &&& g3 &&& g4
+
+($<<<<)::(c1->c2->c3->c4->abd)->ab(c1,(c2,(c3,c4)))->abd
+f$<<<<g=applyA(g>>>arr4f)
+
+-- | compute the parameter for an arrow @f@ with an extra parameter by an arrow @g@
+-- and apply all the results from @g@ sequentially to the input
+--
+-- > infixl 2 ($<$)
+--
+-- typical usage:
+--
+-- > g :: a b c
+-- > g = ...
+-- >
+-- > f :: c -> a b b
+-- > f x = ... x ...
+-- >
+-- > f $<$ g
+--
+-- @f@ computes the extra parameters for @g@ from the input of type @b@ and @g@ is applied with this
+-- parameter to the input. This allows programming in a point wise style in @g@, which becomes
+-- neccessary, when a value is needed more than once.
+--
+-- this combinator is useful, when transforming a single value (document) step by step,
+-- with @g@ for collecting the data for all steps, and @f@ for transforming the input step by step
+--
+-- if @g@ is deterministic (computes exactly one result),
+-- @ g $\<$ f == g $\< f @ holds
+--
+-- if @g@ fails, @ f $<$ g == this @
+--
+-- if @g@ computes more than one result, @f@ is applied sequentially to the input for every result from @g@
+--
+-- examples with simple list arrows with strings
+--
+-- > prefixString :: String -> a String String
+-- > prefixString s = arr (s++)
+-- >
+-- > runLA ( prefixString $<$ none ) "x" == ["x"]
+-- > runLA ( prefixString $<$ constA "y" ) "x" == ["yx"]
+-- > runLA ( prefixString $<$ constA "y" <+> constA "z" ) "x" == ["zyx"]
+-- > runLA ( prefixString $<$ constA "y" <+> this
+-- > <+> constA "z" ) "x" == ["zxyx"]
+--
+-- example with two extra parameter
+--
+-- > g1 :: a b c1
+-- > g2 :: a b c2
+-- >
+-- > f :: (c1, c2) -> a b b
+-- > f (x1, x2) = ... x1 ... x2 ...
+-- >
+-- > f $<$ g1 &&& g2
+--
+-- see also: 'applyA', '$<'
+
+($<$)::(c->(abb))->abc->abb
+g$<$f=applyA(listA(f>>>arrg)>>>arrseqA)
+
+-- | merge the result pairs of an arrow with type @a a1 (b1, b2)@
+-- by combining the tuple components with the @op@ arrow
+--
+-- examples with simple list arrows working on strings and XmlTrees
+--
+-- > a1 :: a String (XmlTree, XmlTree)
+-- > a1 = selem "foo" [this >>> mkText]
+-- > &&&
+-- > selem "bar" [arr (++"0") >>> mkText]
+-- >
+-- > runLA (a1 >>> mergeA (<+>) >>> xshow this) "42" == ["<foo>42</foo>","<bar>420</bar>"]
+-- > runLA (a1 >>> mergeA (+=) >>> xshow this) "42" == ["<foo>42<bar>420</bar></foo>"]
+--
+-- see also: 'applyA', '$<' and '+=' in class 'Text.XML.HXT.Arrow.ArrowXml'
+
+mergeA::(a(a1,b1)a1->a(a1,b1)b1->a(a1,b1)c)->
+a(a1,b1)c
+mergeAop=(\x->arrfst`op`constA(sndx))$<this
+
+-- | useful only for arrows with side effects: perform applies an arrow to the input
+-- ignores the result and returns the input
+--
+-- example: @ ... >>> perform someTraceArrow >>> ... @
+
+perform::abc->abb
+performf=listAf&&&this>>>arrsnd
+
+-- | generalization of arrow combinator '<+>'
+--
+-- definition: @ catA = foldl (<+>) none @
+
+catA::[abc]->abc
+catA=foldl(<+>)none
+
+-- | generalization of arrow combinator '>>>'
+--
+-- definition: @ seqA = foldl (>>>) this @
+
+seqA::[abb]->abb
+seqA=foldl(>>>)this
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Control.Arrow.ArrowState
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id: ArrowState.hs,v 1.5 2005/09/02 17:09:39 hxml Exp $
+
+ Arrows for managing an explicit state
+
+ State arrows work similar to state monads.
+ A state value is threaded through the application of arrows.
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleControl.Arrow.ArrowState
+(ArrowState(..)
+)
+where
+
+importControl.Arrow
+
+-- | The interface for accessing and changing the state component.
+--
+-- Multi parameter classes and functional dependencies are required.
+
+classArrowa=>ArrowStatesa|a->swhere
+
+-- | change the state of a state arrow by applying a function
+-- for computing a new state from the old and the arrow input.
+-- Result is the arrow input
+
+changeState::(s->b->s)->abb
+
+-- | access the state with a function using the arrow input
+-- as data for selecting state components.
+
+accessState::(s->b->c)->abc
+
+-- | read the complete state, ignore arrow input
+--
+-- definition: @ getState = accessState (\\ s x -> s) @
+
+getState::abs
+getState=accessState(\s_x->s)
+
+-- | overwrite the old state
+--
+-- definition: @ setState = changeState (\\ s x -> x) @
+setState::ass
+setState=changeState(\_sx->x)-- changeState (const id)
+
+-- | change state (and ignore input) and return new state
+--
+-- convenience function,
+-- usefull for generating e.g. unique identifiers:
+--
+-- example with SLA state list arrows
+--
+-- > newId :: SLA Int b String
+-- > newId = nextState (+1)
+-- > >>>
+-- > arr (('#':) . show)
+-- >
+-- > runSLA 0 (newId <+> newId <+> newId) undefined
+-- > = ["#1", "#2", "#3"]
+
+nextState::(s->s)->abs
+nextStatesf=changeState(\s->const(sfs))
+>>>
+getState
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Control.Arrow.ArrowStrict
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id$
+
+ Arrows for complete evaluation of result
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleControl.Arrow.ArrowStrict
+where
+
+importControl.Arrow
+importControl.Strategies.DeepSeq
+
+-- |
+-- complete evaluation of an arrow result using 'Control.Strategies.DeepSeq.deepSeq'
+-- and 'Control.Strategies.DeepSeq.strict'
+--
+-- this is sometimes useful for preventing space leaks, especially after reading
+-- and validation of a document, all DTD stuff is not longer in use and can be
+-- recycled by the GC.
+
+strictA::(Arrowa,DeepSeqb)=>abb
+strictA=arrstrict
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Control.Arrow.ArrowTree
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id: ArrowTree.hs,v 1.12 2006/11/30 16:05:24 hxml Exp $
+
+List arrows for tree processing.
+
+Trees that implement the "Data.Tree.Class" interface, can be processed
+with these arrows.
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleControl.Arrow.ArrowTree
+(ArrowTree(..)
+,Tree
+)
+where
+
+importData.Tree.Class(Tree)
+importqualifiedData.Tree.ClassasThiding(Tree)
+
+importControl.Arrow
+importControl.Arrow.ArrowList
+importControl.Arrow.ArrowIf
+
+infixl5/>,</
+
+-- ------------------------------------------------------------
+
+-- | The interface for tree arrows
+--
+-- all functions have default implementations
+
+class(ArrowPlusa,ArrowIfa)=>ArrowTreeawhere
+
+-- | select the children of the root of a tree
+
+getChildren::Treet=>a(tb)(tb)
+getChildren=arrLT.getChildren
+
+-- | select the attribute of the root of a tree
+
+getNode::Treet=>a(tb)b
+getNode=arrT.getNode
+
+-- | substitute the children of the root of a tree
+
+setChildren::Treet=>[tb]->a(tb)(tb)
+setChildrencs=arr(T.setChildrencs)
+
+-- | substitute the attribute of the root of a tree
+
+setNode::Treet=>b->a(tb)(tb)
+setNoden=arr(T.setNoden)
+
+-- | edit the children of the root of a tree
+
+changeChildren::Treet=>([tb]->[tb])->a(tb)(tb)
+changeChildrencsf=arr(T.changeChildrencsf)
+
+-- | edit the attribute of the root of a tree
+
+changeNode::Treet=>(b->b)->a(tb)(tb)
+changeNodenf=arr(T.changeNodenf)
+
+-- compound arrows
+
+-- | apply an arrow element wise to all children of the root of a tree
+-- collect these results and substitute the children with this result
+--
+-- example: @ processChildren isText @ deletes all subtrees, for which isText does not hold
+--
+-- example: @ processChildren (none \`when\` isCmt) @ removes all children, for which isCmt holds
+
+processChildren::Treet=>a(tb)(tb)->a(tb)(tb)
+processChildrenf=arrT.getNode
+&&&
+listA(arrLT.getChildren>>>f)-- new children, deterministic filter: single element result
+>>>
+arr2T.mkTree
+
+-- | similar to processChildren, but the new children are computed by processing
+-- the whole input tree
+--
+-- example: @ replaceChildren (deep isText) @ selects all subtrees for which isText holds
+-- and substitutes the children component of the root node with this list
+
+replaceChildren::Treet=>a(tb)(tb)->a(tb)(tb)
+replaceChildrenf=arrT.getNode
+&&&
+listAf-- compute new children
+>>>
+arr2T.mkTree
+
+-- |
+-- pronounced \"slash\", meaning g inside f
+--
+-- defined as @ f \/> g = f >>> getChildren >>> g @
+--
+-- example: @ hasName \"html\" \/> hasName \"body\" \/> hasName \"h1\" @
+--
+-- This expression selects
+-- all \"h1\" elements in the \"body\" element of an \"html\" element, an expression, that
+-- corresponds 1-1 to the XPath selection path \"html\/body\/h1\"
+
+(/>)::Treet=>a(tb)(tb)->a(tb)(tb)->a(tb)(tb)
+f/>g=f>>>getChildren>>>g
+
+
+-- |
+-- pronounced \"outside\" meaning f containing g
+--
+-- defined as @ f \<\/ g = f \`containing\` (getChildren >>> g) @
+
+(</)::Treet=>a(tb)(tb)->a(tb)(tb)->a(tb)(tb)
+f</g=f`containing`(getChildren>>>g)
+
+
+-- | recursively searches a whole tree for subtrees, for which a predicate holds.
+-- The search is performed top down. When a tree is found, this becomes an element of the result
+-- list. The tree found is not further examined for any subtress, for which the predicate also could hold.
+-- See 'multi' for this kind of search.
+--
+-- example: @ deep isHtmlTable @ selects all top level table elements in a document
+-- (with an appropriate definition for isHtmlTable) but no tables occuring within a table cell.
+
+deep::Treet=>a(tb)(tb)->a(tb)(tb)
+deepf=f-- success when applying f
+`orElse`
+(getChildren>>>deepf)-- seach children
+
+
+-- | recursively searches a whole tree for subrees, for which a predicate holds.
+-- The search is performed bottom up.
+--
+-- example: @ deepest isHtmlTable @ selects all innermost table elements in a document
+-- but no table elements containing tables. See 'deep' and 'multi' for other search strategies.
+
+deepest::Treet=>a(tb)(tb)->a(tb)(tb)
+deepestf=(getChildren>>>deepestf)-- seach children
+`orElse`
+f-- no success: apply f to root
+
+
+-- | recursively searches a whole tree for subtrees, for which a predicate holds.
+-- The search is performed top down. All nodes of the tree are searched, even within the
+-- subtrees of trees for which the predicate holds.
+--
+-- example: @ multy isHtmlTable @ selects all table elements, even nested ones.
+
+multi::Treet=>a(tb)c->a(tb)c
+multif=f-- combine result for root
+<+>
+(getChildren>>>multif)-- with result for all descendants
+
+-- | recursively transforms a whole tree by applying an arrow to all subtrees,
+-- this is done bottom up depth first, leaves first, root as last tree
+--
+-- example: @ processBottomUp (getChildren \`when\` isHtmlFont) @ removes all font tags in a HTML document, even nested ones
+-- (with an appropriate definition of isHtmlFont)
+
+processBottomUp::Treet=>a(tb)(tb)->a(tb)(tb)
+processBottomUpf=processChildren(processBottomUpf)-- process all descendants first
+>>>
+f-- then process root
+
+-- | similar to 'processBottomUp', but recursively transforms a whole tree by applying an arrow to all subtrees
+-- with a top down depth first traversal strategie. In many cases 'processBottomUp' and 'processTopDown'
+-- give same results.
+
+processTopDown::Treet=>a(tb)(tb)->a(tb)(tb)
+processTopDownf=f-- first process root
+>>>
+processChildren(processTopDownf)-- then process all descendants of new root
+
+
+-- | recursively transforms a whole tree by applying an arrow to all subtrees,
+-- but transformation stops when a predicte does not hold for a subtree,
+-- leaves are transformed first
+
+processBottomUpWhenNot
+::Treet=>a(tb)(tb)->a(tb)(tb)->a(tb)(tb)
+processBottomUpWhenNotfp
+=(processChildren(processBottomUpWhenNotfp)
+>>>
+f
+)`whenNot`p
+
+-- | recursively transforms a whole tree by applying an arrow to all subtrees,
+-- but transformation stops when a tree is successfully transformed.
+-- the transformation is done top down
+--
+-- example: @ processTopDownUntil (isHtmlTable \`guards\` tranformTable) @
+-- transforms all top level table elements into something else, but inner tables remain unchanged
+
+processTopDownUntil::Treet=>a(tb)(tb)->a(tb)(tb)
+processTopDownUntilf
+=f
+`orElse`
+processChildren(processTopDownUntilf)
+
+-- | computes a list of trees by applying an arrow to the input
+-- and inserts this list in front of index i in the list of children
+--
+-- example: @ insertChildrenAt 0 (deep isCmt) @ selects all subtrees for which isCmt holds
+-- and copies theses in front of the existing children
+
+insertChildrenAt::Treet=>Int->a(tb)(tb)->a(tb)(tb)
+insertChildrenAtif
+=listAf&&&this>>>arr2insertAt
+where
+insertAtnewcs
+=T.changeChildren(\cs->let
+(cs1,cs2)=splitAtics
+in
+cs1++newcs++cs2
+)
+
+-- | similar to 'insertChildrenAt', but the insertion position is searched with a predicate
+
+insertChildrenAfter::Treet=>a(tb)(tb)->a(tb)(tb)->a(tb)(tb)
+insertChildrenAfterpf
+=replaceChildren
+(((listAgetChildren
+>>>
+spanAp
+)
+&&&
+listAf
+)
+>>>arr2L(\(xs1,xs2)xs->xs1++xs++xs2)
+)
+
+-- | an arrow for inserting a whole subtree with some holes in it (a template)
+-- into a document. The holes can be filled with contents from the input.
+--
+-- Example
+--
+-- > insertTreeTemplateTest :: ArrowXml a => a b XmlTree
+-- > insertTreeTemplateTest
+-- > = doc
+-- > >>>
+-- > insertTemplate template pattern
+-- > where
+-- > doc -- the input data
+-- > = constA "<x><y>The Title</y><z>The content</z></x>"
+-- > >>> xread
+-- > template -- the output template with 2 holes: xxx and yyy
+-- > = constA "<html><head><title>xxx</title></head><body><h1>yyy</h1></body></html>"
+-- > >>> xread
+-- > pattern
+-- > = [ hasText (== "xxx") -- fill the xxx hole with the input contents from element "x/y"
+-- > :-> ( getChildren >>> hasName "y" >>> deep isText )
+-- >
+-- > , hasText (== "yyy") -- fill the yyy hole with the input contents from element "x/z"
+-- > :-> ( getChildren >>> hasName "z" >>> getChildren )
+-- > ]
+--
+-- computes the XML tree for the following document
+--
+-- > "<html><head><title>The Title</title></head><body><h1>The content</h1></body></html>"
+
+insertTreeTemplate::Treet=>
+a(tb)(tb)->-- the the template
+[IfThen(a(tb)c)(a(tb)(tb))]->-- the list of nodes in the template to be substituted
+a(tb)(tb)
+insertTreeTemplatetemplatechoices
+=insertTree$<this
+where
+insertTreet
+=template-- swap input and template
+>>>
+processTemplate
+where
+processTemplate
+=choiceAchoices'-- check whether node is a "hole" within the template
+`orElse`
+processChildrenprocessTemplate-- else descent into template tree
+choices'
+=mapfeedTreechoices-- modify choices, such that the input is feed into the action arrows
+feedTree(cond:->action)
+=cond:->(constAt>>>action)-- the real input becomes the input at the holes
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Control.Arrow.IOStateListArrow
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id: IOStateListArrow.hs,v 1.7 2005/09/02 17:09:39 hxml Exp $
+
+ Implementation of arrows with IO and a state
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleControl.Arrow.IOStateListArrow
+(IOSLA(..)
+,liftSt
+,runSt
+)
+where
+
+importControl.Arrow
+importControl.Arrow.ArrowList
+importControl.Arrow.ArrowIf
+importControl.Arrow.ArrowTree
+importControl.Arrow.ArrowState
+importControl.Arrow.ArrowIO
+
+-- ------------------------------------------------------------
+
+-- | list arrow combined with a state and the IO monad
+
+newtypeIOSLAsab=IOSLA{runIOSLA::s->a->IO(s,[b])}
+
+instanceArrow(IOSLAs)where
+arrf=IOSLA$\sx->return(s,[fx])
+
+IOSLAf>>>IOSLAg=IOSLA$\sx->do
+(s1,ys)<-fsx
+sequence's1ys
+where
+sequence's'[]=return(s',[])
+sequence's'(x':xs')=do
+(s1',ys')<-gs'x'
+(s2',zs')<-sequence's1'xs'
+return(s2',ys'++zs')
+
+first(IOSLAf)=IOSLA$\s(x1,x2)->do
+(s',ys1)<-fsx1
+return(s',[(y1,x2)|y1<-ys1])
+
+-- just for efficiency
+second(IOSLAg)=IOSLA$\s(x1,x2)->do
+(s',ys2)<-gsx2
+return(s',[(x1,y2)|y2<-ys2])
+
+-- just for efficiency
+IOSLAf***IOSLAg=IOSLA$\s(x1,x2)->do
+(s1,ys1)<-fsx1
+(s2,ys2)<-gs1x2
+return(s2,[(y1,y2)|y1<-ys1,y2<-ys2])
+
+-- just for efficiency
+IOSLAf&&&IOSLAg=IOSLA$\sx->do
+(s1,ys1)<-fsx
+(s2,ys2)<-gs1x
+return(s2,[(y1,y2)|y1<-ys1,y2<-ys2])
+
+
+
+instanceArrowZero(IOSLAs)where
+zeroArrow=IOSLA$\s->const(return(s,[]))
+
+
+instanceArrowPlus(IOSLAs)where
+IOSLAf<+>IOSLAg=IOSLA$\sx->do
+(s1,rs1)<-fsx
+(s2,rs2)<-gs1x
+return(s2,rs1++rs2)
+
+instanceArrowChoice(IOSLAs)where
+left(IOSLAf)=IOSLA$\s->either
+(\x->do
+(s1,y)<-fsx
+return(s1,mapLefty)
+)
+(\x->return(s,[Rightx]))
+
+right(IOSLAf)=IOSLA$\s->either
+(\x->return(s,[Leftx]))
+(\x->do
+(s1,y)<-fsx
+return(s1,mapRighty)
+)
+
+instanceArrowApply(IOSLAs)where
+app=IOSLA$\s(IOSLAf,x)->fsx
+
+instanceArrowList(IOSLAs)where
+arrLf=IOSLA$\sx->return(s,(fx))
+arr2Af=IOSLA$\s(x,y)->runIOSLA(fx)sy
+constAc=IOSLA$\s->const(return(s,[c]))
+isAp=IOSLA$\sx->return(s,ifpxthen[x]else[])
+IOSLAf>>.g=IOSLA$\sx->do
+(s1,ys)<-fsx
+return(s1,gys)
+-- just for efficency
+perform(IOSLAf)=IOSLA$\sx->do
+(s1,_ys)<-fsx
+return(s1,[x])
+
+instanceArrowIf(IOSLAs)where
+ifA(IOSLAp)taea=IOSLA$\sx->do
+(s1,res)<-psx
+runIOSLA(ifnullres
+thenea
+elseta
+)s1x
+
+(IOSLAf)`orElse`g
+=IOSLA$\sx->do
+r@(s1,res)<-fsx
+ifnullres
+thenrunIOSLAgs1x
+elsereturnr
+
+
+instanceArrowIO(IOSLAs)where
+arrIOcmd=IOSLA$\sx->do
+res<-cmdx
+return(s,[res])
+
+instanceArrowIOIf(IOSLAs)where
+isIOAp=IOSLA$\sx->do
+res<-px
+return(s,ifresthen[x]else[])
+
+instanceArrowStates(IOSLAs)where
+changeStatecf=IOSLA$\sx->lets'=cfsxinreturn(seqs's',[x])
+accessStateaf=IOSLA$\sx->return(s,[afsx])
+
+-- ------------------------------------------------------------
+
+-- |
+-- lift the state of an IOSLA arrow to a state with an additional component.
+--
+-- This is uesful, when running predefined IO arrows, e.g. for document input,
+-- in a context with a more complex state component.
+
+liftSt::IOSLAs1bc->IOSLA(s1,s2)bc
+liftSt(IOSLAf)
+=IOSLA$\(s1,s2)x->do
+(s1',ys)<-fs1x
+return((s1',s2),ys)
+
+
+-- |
+-- run an arrow with augmented state in the context of a simple state arrow.
+-- An initial value for the new state component is needed.
+--
+-- This is useful, when running an arrow with an extra environment component, e.g.
+-- for namespace handling in XML.
+
+runSt::s2->IOSLA(s1,s2)bc->IOSLAs1bc
+runSts2(IOSLAf)
+=IOSLA$\s1x->do
+((s1',_s2'),ys)<-f(s1,s2)x
+return(s1',ys)
+
+-- ------------------------------------------------------------
+
+instanceArrowTree(IOSLAs)
+
+
+-- ------------------------------------------------------------
+
-- |
+-- general usefull state monad for a local state and IO
+--
+-- Version : $Id: MonadStateIO.hs,v 1.1 2004/09/02 19:11:55 hxml Exp $
+
+
+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
+
+
+-- ------------------------------------------------------------
+
{- |
+
+stolen from comp.lang.functional from Dean Herington
+
+DeepSeq.lhs -- deep strict evaluation support
+
+The `DeepSeq` class provides a method `deepSeq` that is similar to
+`seq` except that it forces deep evaluation of its first argument
+before returning its second argument.
+
+Instances of `DeepSeq` are provided for Prelude types. Other
+instances must be supplied by users of this module.
+
+$Id: DeepSeq.lhs,v 1.5 2002/04/01 20:58:24 heringto Exp $
+-}
+
+moduleControl.Strategies.DeepSeq
+where
+
+classDeepSeqawhere
+deepSeq::a->b->b
+deepSeq=seq
+
+infixr0`deepSeq`,$!!
+
+($!!)::(DeepSeqa)=>(a->b)->a->b
+
+f$!!x=x`deepSeq`fx
+
+strict::DeepSeqa=>a->a
+strictx
+=x`deepSeq`x
+
+instanceDeepSeq()
+instanceDeepSeqBool
+instanceDeepSeqChar
+instanceDeepSeqOrdering
+instanceDeepSeqInt
+instanceDeepSeqInteger
+instanceDeepSeqFloat
+instanceDeepSeqDouble
+instanceDeepSeq(a->b)
+instanceDeepSeq(IOa)
+
+instance(DeepSeqa)=>DeepSeq(Maybea)where
+deepSeqNothingy=y
+deepSeq(Justx)y=deepSeqxy
+
+instance(DeepSeqa,DeepSeqb)=>DeepSeq(Eitherab)where
+deepSeq(Lefta)y=deepSeqay
+deepSeq(Rightb)y=deepSeqby
+
+instance(DeepSeqa)=>DeepSeq[a]where
+deepSeq[]y=y
+deepSeq(x:xs)y=deepSeqx$deepSeqxsy
+
+instance(DeepSeqa,DeepSeqb)=>DeepSeq(a,b)where
+deepSeq(a,b)y=deepSeqa$deepSeqby
+
+instance(DeepSeqa,DeepSeqb,DeepSeqc)=>DeepSeq(a,b,c)where
+deepSeq(a,b,c)y=deepSeqa$deepSeqb$deepSeqcy
+
+instance(DeepSeqa,DeepSeqb,DeepSeqc,DeepSeqd)=>DeepSeq(a,b,c,d)where
+deepSeq(a,b,c,d)y=deepSeqa$deepSeqb$deepSeqc$deepSeqdy
+
+instance(DeepSeqa,DeepSeqb,DeepSeqc,DeepSeqd,DeepSeqe)=>DeepSeq(a,b,c,d,e)where
+deepSeq(a,b,c,d,e)y=deepSeqa$deepSeqb$deepSeqc$deepSeqd$deepSeqey
+
+instance(DeepSeqa,DeepSeqb,DeepSeqc,DeepSeqd,DeepSeqe,DeepSeqf)=>DeepSeq(a,b,c,d,e,f)where
+deepSeq(a,b,c,d,e,f)y=deepSeqa$deepSeqb$deepSeqc$deepSeqd$deepSeqe$deepSeqfy
+
+instance(DeepSeqa,DeepSeqb,DeepSeqc,DeepSeqd,DeepSeqe,DeepSeqf,DeepSeqg)=>DeepSeq(a,b,c,d,e,f,g)where
+deepSeq(a,b,c,d,e,f,g)y=deepSeqa$deepSeqb$deepSeqc$deepSeqd$deepSeqe$deepSeqf$deepSeqgy
+
-- |
+-- simple key value assocciation list
+-- implemented as unordered list of pairs
+--
+-- Version : $Id: AssocList.hs,v 1.2 2005/05/27 13:15:23 hxml Exp $
+
+moduleData.AssocList
+(moduleData.AssocList
+)
+where
+
+importData.Maybe
+
+typeAssocListkv=[(k,v)]
+
+-- lookup = lookup from Prelude
+
+-- | lookup with default value
+
+lookupDef::Eqk=>v->k->AssocListkv->v
+lookupDefdk=fromMaybed.lookupk
+
+-- | lookup with empty list (empty string) as default value
+
+lookup1::Eqk=>k->AssocListk[e]->[e]
+lookup1k=fromMaybe[].lookupk
+
+-- | test for existence of a key
+
+hasEntry::Eqk=>k->AssocListkv->Bool
+hasEntryk=isJust.lookupk
+
+-- | add an entry, remove an existing entry before adding the new one at the top of the list, addEntry is strict
+
+addEntry::Eqk=>k->v->AssocListkv->AssocListkv
+addEntrykvl=((k,v):)$!delEntrykl
+
+-- let l' = delEntry k l in seq l' ((k, v) : l')
+
+-- | add a whole list of entries with 'addEntry'
+
+addEntries::Eqk=>AssocListkv->AssocListkv->AssocListkv
+addEntries=foldr(.)id.map(uncurryaddEntry).reverse
+
+-- | delete an entry, delEntry is strict
+delEntry::Eqk=>k->AssocListkv->AssocListkv
+delEntry_[]=[]
+delEntryk(x@(k1,_):rest)
+|k==k1=rest
+|otherwise=(x:)$!delEntrykrest
+
+-- delEntry k = filter ((/= k) . fst)
+
+-- | delete a list of entries with 'delEntry'
+
+delEntries::Eqk=>[k]->AssocListkv->AssocListkv
+delEntries=foldl(.)id.mapdelEntry
+
+-- -----------------------------------------------------------------------------
+
+
+
{-
+
+Copyright (c) 2002, members of the Haskell Internationalisation Working
+Group All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice,
+ this list of conditions and the following disclaimer.
+* Redistributions in binary form must reproduce the above copyright notice,
+ this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+* Neither the name of the Haskell Internationalisation Working Group nor
+ the names of its contributors may be used to endorse or promote products
+ derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+This module provides lazy stream encoding/decoding facilities for UTF-8,
+the Unicode Transformation Format with 8-bit words.
+
+2002-09-02 Sven Moritz Hallberg <pesco@gmx.de>
+
+-}
+
+{-
+
+2007-04-30 Henning Thielemann:
+Slight changes to make decode lazy.
+The calls of 'reverse' in the original version have broken laziness
+and thus had memory leaks.
+
+-}
+
+moduleData.Char.UTF8
+(encode,decode,
+decodeEmbedErrors,
+encodeOne,decodeOne,
+Error,-- Haddock does not want to document signatures with private types
+-- these functions should be moved to a utility module
+)where
+
+importData.Char(ord,chr)
+importData.Word(Word8,Word16,Word32)
+importData.Bits(Bits,shiftL,shiftR,(.&.),(.|.))
+
+importData.List(unfoldr)
+
+importText.XML.HXT.DOM.Util(partitionEither,swap,toMaybe)
+
+
+
+-- - UTF-8 in General -
+
+-- Adapted from the Unicode standard, version 3.2,
+-- Table 3.1 "UTF-8 Bit Distribution" (excluded are UTF-16 encodings):
+
+-- Scalar 1st Byte 2nd Byte 3rd Byte 4th Byte
+-- 000000000xxxxxxx 0xxxxxxx
+-- 00000yyyyyxxxxxx 110yyyyy 10xxxxxx
+-- zzzzyyyyyyxxxxxx 1110zzzz 10yyyyyy 10xxxxxx
+-- 000uuuzzzzzzyyyyyyxxxxxx 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx
+
+-- Also from the Unicode standard, version 3.2,
+-- Table 3.1B "Legal UTF-8 Byte Sequences":
+
+-- Code Points 1st Byte 2nd Byte 3rd Byte 4th Byte
+-- U+0000..U+007F 00..7F
+-- U+0080..U+07FF C2..DF 80..BF
+-- U+0800..U+0FFF E0 A0..BF 80..BF
+-- U+1000..U+CFFF E1..EC 80..BF 80..BF
+-- U+D000..U+D7FF ED 80..9F 80..BF
+-- U+D800..U+DFFF ill-formed
+-- U+E000..U+FFFF EE..EF 80..BF 80..BF
+-- U+10000..U+3FFFF F0 90..BF 80..BF 80..BF
+-- U+40000..U+FFFFF F1..F3 80..BF 80..BF 80..BF
+-- U+100000..U+10FFFF F4 80..8F 80..BF 80..BF
+
+
+
+-- - Encoding Functions -
+
+-- Must the encoder ensure that no illegal byte sequences are output or
+-- can we trust the Haskell system to supply only legal values?
+-- For now I include error case for the surrogate values U+D800..U+DFFF and
+-- out-of-range scalars.
+
+-- The function is pretty much a transscript of table 3.1B with error checks.
+-- It dispatches the actual encoding to functions specific to the number of
+-- required bytes.
+
+encodeOne::Char->[Word8]
+encodeOnec
+-- The report guarantees in (6.1.2) that this won't happen:
+-- | n < 0 = error "encodeUTF8: ord returned a negative value"
+|n<0x0080=encodeOne_onebyten8
+|n<0x0800=encodeOne_twobyten16
+|n<0xD800=encodeOne_threebyten16
+|n<0xE000=error"encodeUTF8: ord returned a surrogate value"
+|n<0x10000=encodeOne_threebyten16
+-- Haskell 98 only talks about 16 bit characters, but ghc handles 20.1.
+|n<0x10FFFF=encodeOne_fourbyten32
+|otherwise=error"encodeUTF8: ord returned a value above 0x10FFFF"
+where
+n=ordc::Int
+n8=fromIntegraln::Word8
+n16=fromIntegraln::Word16
+n32=fromIntegraln::Word32
+
+
+-- With the above, a stream decoder is trivial:
+
+encode::[Char]->[Word8]
+encode=concatMapencodeOne
+
+
+-- Now follow the individual encoders for certain numbers of bytes...
+-- _
+-- / | __ ___ __ __
+-- / ^| // /__/ // //
+-- /.==| \\ //_ // //
+-- It's // || // \_/_//_//_ and it's here to stay!
+
+encodeOne_onebyte::Word8->[Word8]
+encodeOne_onebytecp=[cp]
+
+
+-- 00000yyyyyxxxxxx -> 110yyyyy 10xxxxxx
+
+encodeOne_twobyte::Word16->[Word8]
+encodeOne_twobytecp=[(0xC0.|.ys),(0x80.|.xs)]
+where
+xs,ys::Word8
+ys=fromIntegral(shiftRcp6)
+xs=(fromIntegralcp).&.0x3F
+
+
+-- zzzzyyyyyyxxxxxx -> 1110zzzz 10yyyyyy 10xxxxxx
+
+encodeOne_threebyte::Word16->[Word8]
+encodeOne_threebytecp=[(0xE0.|.zs),(0x80.|.ys),(0x80.|.xs)]
+where
+xs,ys,zs::Word8
+xs=(fromIntegralcp).&.0x3F
+ys=(fromIntegral(shiftRcp6)).&.0x3F
+zs=fromIntegral(shiftRcp12)
+
+
+-- 000uuuzzzzzzyyyyyyxxxxxx -> 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx
+
+encodeOne_fourbyte::Word32->[Word8]
+encodeOne_fourbytecp=[0xF0.|.us,0x80.|.zs,0x80.|.ys,0x80.|.xs]
+where
+xs,ys,zs,us::Word8
+xs=(fromIntegralcp).&.0x3F
+ys=(fromIntegral(shiftRcp6)).&.0x3F
+zs=(fromIntegral(shiftRcp12)).&.0x3F
+us=fromIntegral(shiftRcp18)
+
+
+
+-- - Decoding -
+
+-- The decoding is a bit more involved. The byte sequence could contain all
+-- sorts of corruptions. The user must be able to either notice or ignore these
+-- errors.
+
+-- I will first look at the decoding of a single character. The process
+-- consumes a certain number of bytes from the input. It returns the
+-- remaining input and either an error and the index of its occurance in the
+-- byte sequence or the decoded character.
+
+dataError
+
+-- The first byte in a sequence starts with either zero, two, three, or four
+-- ones and one zero to indicate the length of the sequence. If it doesn't,
+-- it is invalid. It is dropped and the next byte interpreted as the start
+-- of a new sequence.
+
+=InvalidFirstByte
+
+-- All bytes in the sequence except the first match the bit pattern 10xxxxxx.
+-- If one doesn't, it is invalid. The sequence up to that point is dropped
+-- and the "invalid" byte interpreted as the start of a new sequence. The error
+-- includes the length of the partial sequence and the number of expected bytes.
+
+|InvalidLaterByteInt-- the byte at relative index n was invalid
+
+-- If a sequence ends prematurely, it has been truncated. It dropped and
+-- decoding stops. The error reports the actual and expected lengths of the
+-- sequence.
+
+|TruncatedIntInt-- only n of m expected bytes were present
+
+-- Some sequences would represent code points which would be encoded as a
+-- shorter sequence by a conformant encoder. Such non-shortest sequences are
+-- considered erroneous and dropped. The error reports the actual and
+-- expected number of bytes used.
+
+|NonShortestIntInt-- n instead of m bytes were used
+
+-- Unicode code points are in the range of [0..0x10FFFF]. Any values outside
+-- of those bounds are simply invalid.
+
+|ValueOutOfBounds
+
+-- There is no such thing as "surrogate pairs" any more in UTF-8. The
+-- corresponding code points now form illegal byte sequences.
+
+|Surrogate
+deriving(Show,Eq)
+
+
+-- Second, third, and fourth bytes share the common requirement to start
+-- with the bit sequence 10. So, here's the function to check that property.
+
+first_bits_not_10::Word8->Bool
+first_bits_not_10b
+|(b.&.0xC0)/=0x80=True
+|otherwise=False
+
+
+-- Erm, OK, the single-character decoding function's return type is a bit
+-- longish. It is a tripel:
+
+-- - The first component contains the decoded character or an error
+-- if the byte sequence was erroneous.
+-- - The second component contains the number of bytes that were consumed
+-- from the input.
+-- - The third component contains the remaining bytes of input.
+
+decodeOne::[Word8]->(EitherErrorChar,Int,[Word8])
+decodeOnebs@(b1:rest)
+|b1<0x80=decodeOne_onebytebs
+|b1<0xC0=(LeftInvalidFirstByte,1,rest)
+|b1<0xE0=decodeOne_twobytebs
+|b1<0xF0=decodeOne_threebytebs
+|b1<0xF5=decodeOne_fourbytebs
+|otherwise=(LeftValueOutOfBounds,1,rest)
+decodeOne[]=error"UTF8.decodeOne: No input"
+
+
+-- 0xxxxxxx -> 000000000xxxxxxx
+
+decodeOne_onebyte::[Word8]->(EitherErrorChar,Int,[Word8])
+decodeOne_onebyte(b:bs)=(Right(cpToCharb),1,bs)
+decodeOne_onebyte[]=error"UTF8.decodeOne_onebyte: No input (can't happen)"
+
+cpToChar::Integrala=>a->Char
+cpToChar=chr.fromIntegral
+
+
+-- 110yyyyy 10xxxxxx -> 00000yyyyyxxxxxx
+
+decodeOne_twobyte::[Word8]->(EitherErrorChar,Int,[Word8])
+decodeOne_twobyte(_:[])
+=(Left(Truncated12),1,[])
+decodeOne_twobyte(b1:b2:bs)
+|b1<0xC2=(Left(NonShortest21),2,bs)
+|first_bits_not_10b2=(Left(InvalidLaterByte1),1,(b2:bs))
+|otherwise=(Right(cpToCharresult),2,bs)
+where
+xs,ys,result::Word32
+xs=fromIntegral(b2.&.0x3F)
+ys=fromIntegral(b1.&.0x1F)
+result=shiftLys6.|.xs
+decodeOne_twobyte[]=error"UTF8.decodeOne_twobyte: No input (can't happen)"
+
+
+-- 1110zzzz 10yyyyyy 10xxxxxx -> zzzzyyyyyyxxxxxx
+
+decodeOne_threebyte::[Word8]->(EitherErrorChar,Int,[Word8])
+decodeOne_threebyte(_:[])=threebyte_truncated1
+decodeOne_threebyte(_:_:[])=threebyte_truncated2
+decodeOne_threebytebs@(b1:b2:b3:rest)
+|first_bits_not_10b2
+=(Left(InvalidLaterByte1),1,drop1bs)
+|first_bits_not_10b3
+=(Left(InvalidLaterByte2),2,drop2bs)
+|result<0x0080
+=(Left(NonShortest31),3,rest)
+|result<0x0800
+=(Left(NonShortest32),3,rest)
+|result>=0xD800&&result<0xE000
+=(LeftSurrogate,3,rest)
+|otherwise
+=(Right(cpToCharresult),3,rest)
+where
+xs,ys,zs,result::Word32
+xs=fromIntegral(b3.&.0x3F)
+ys=fromIntegral(b2.&.0x3F)
+zs=fromIntegral(b1.&.0x0F)
+result=shiftLzs12.|.shiftLys6.|.xs
+decodeOne_threebyte[]
+=error"UTF8.decodeOne_threebyte: No input (can't happen)"
+
+threebyte_truncated::Int->(EitherErrorChar,Int,[Word8])
+threebyte_truncatedn=(Left(Truncatedn3),n,[])
+
+
+-- 11110uuu 10zzzzzz 10yyyyyy 10xxxxxx -> 000uuuzzzzzzyyyyyyxxxxxx
+
+decodeOne_fourbyte::[Word8]->(EitherErrorChar,Int,[Word8])
+decodeOne_fourbyte(_:[])=fourbyte_truncated1
+decodeOne_fourbyte(_:_:[])=fourbyte_truncated2
+decodeOne_fourbyte(_:_:_:[])=fourbyte_truncated3
+decodeOne_fourbytebs@(b1:b2:b3:b4:rest)
+|first_bits_not_10b2
+=(Left(InvalidLaterByte1),1,drop1bs)
+|first_bits_not_10b3
+=(Left(InvalidLaterByte2),2,drop2bs)
+|first_bits_not_10b4
+=(Left(InvalidLaterByte3),3,drop3bs)
+|result<0x0080
+=(Left(NonShortest41),4,rest)
+|result<0x0800
+=(Left(NonShortest42),4,rest)
+|result<0x10000
+=(Left(NonShortest43),4,rest)
+|result>0x10FFFF
+=(LeftValueOutOfBounds,4,rest)
+|otherwise
+=(Right(cpToCharresult),4,rest)
+where
+xs,ys,zs,us,result::Word32
+xs=fromIntegral(b4.&.0x3F)
+ys=fromIntegral(b3.&.0x3F)
+zs=fromIntegral(b2.&.0x3F)
+us=fromIntegral(b1.&.0x07)
+result=xs.|.shiftLys6.|.shiftLzs12.|.shiftLus18
+decodeOne_fourbyte[]
+=error"UTF8.decodeOne_fourbyte: No input (can't happen)"
+
+fourbyte_truncated::Int->(EitherErrorChar,Int,[Word8])
+fourbyte_truncatedn=(Left(Truncatedn4),n,[])
+
+
+-- The decoder examines all input, recording decoded characters as well as
+-- error-index pairs along the way.
+
+decode::[Word8]->([Char],[(Error,Int)])
+decode=swap.partitionEither.decodeEmbedErrors
+
+decodeEmbedErrors::[Word8]->[Either(Error,Int)Char]
+decodeEmbedErrors=
+unfoldr(\(pos,xs)->
+toMaybe
+(not$nullxs)
+(let(c,n,rest)=decodeOnexs
+in(either(\err->Left(err,pos))Rightc,
+(pos+n,rest)))).
+(,)0
+
-- |
+-- Navigable tree structure which allow a program to traverse
+-- up the tree as well as down.
+-- copied and modified from HXML (<http://www.flightlab.com/~joe/hxml/>)
+--
+
+moduleData.NavTree
+(moduleData.NavTree
+,moduleData.Tree.NTree.TypeDefs
+)
+where
+
+importData.Tree.NTree.TypeDefs
+importData.Maybe
+
+-- -----------------------------------------------------------------------------
+
+-- NavTree
+--
+-- | navigable tree with nodes of type node
+--
+-- a navigable tree consists of a n-ary tree for the current fragment tree,
+-- a navigable tree for all ancestors, and two n-ary trees for
+-- the previous- and following siblings
+
+dataNavTreea=NT
+(NTreea)-- self
+[NavTreea]-- ancestors
+[NTreea]-- previous siblings (in reverse order)
+[NTreea]-- following siblings
+deriving(Show,Eq,Ord)
+
+
+-- -----------------------------------------------------------------------------
+
+
+-- |
+-- converts a n-ary tree in a navigable tree
+
+ntree::NTreea->NavTreea
+ntreend
+=NTnd[][][]
+
+-- |
+-- converts a navigable tree in a n-ary tree
+
+subtreeNT::NavTreea->NTreea
+subtreeNT(NTnd___)
+=nd
+
+
+-- |
+-- function for selecting the value of the current fragment tree
+
+dataNT::NavTreea->a
+dataNT(NT(NTreea_)___)
+=a
+
+
+-- -----------------------------------------------------------------------------
+
+-- functions for traversing up, down, left and right in a navigable tree
+
+upNT
+,downNT
+,leftNT
+,rightNT::NavTreea->Maybe(NavTreea)
+
+upNT(NT_(p:_)__)=Justp
+upNT(NT_[]__)=Nothing
+downNTt@(NT(NTree_(c:cs))u__)=Just(NTc(t:u)[]cs)
+downNT(NT(NTree_[])___)=Nothing
+leftNT(NTsu(l:ls)r)=Just(NTluls(s:r))
+leftNT(NT__[]_)=Nothing
+rightNT(NTsul(r:rs))=Just(NTru(s:l)rs)
+rightNT(NT___[])=Nothing
+
+
+-- preorderNT t = t : concatMap preorderNT (children t)
+-- where children = maybe [] (maybeStar rightNT) . downNT
+
+preorderNT::NavTreea->[NavTreea]
+preorderNT
+=visit[]
+where
+visitkt=t:maybek(visit'k)(downNTt)
+visit'kt=visit(maybek(visit'k)(rightNTt))t
+
+revPreorderNT::NavTreea->[NavTreea]
+revPreorderNTt
+=t:concatMaprevPreorderNT(reverse(childrent))
+where
+children=maybe[](maybeStarrightNT).downNT
+
+getChildrenNT::NavTreea->[NavTreea]
+getChildrenNTnode
+=maybe[]follow(downNTnode)
+where
+follown=n:maybe[]follow(rightNTn)
+
+-- -----------------------------------------------------------------------------
+-- Miscellaneous useful combinators
+
+-- |
+-- Kleisli composition:
+
+o'::(Monadm)=>(b->mc)->(a->mb)->(a->mc)
+f`o'`g=\x->gx>>=f
+
+
+-- Some useful anamorphisms:
+
+maybeStar,maybePlus::(a->Maybea)->a->[a]
+maybeStarfa=a:maybe[](maybeStarf)(fa)
+maybePlusfa=maybe[](maybeStarf)(fa)
+
+-- -----------------------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Data.Tree.Class
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ Interface definition for trees
+-}
+
+-- ------------------------------------------------------------
+
+moduleData.Tree.Class
+(moduleData.Tree.Class)
+where
+
+-- | The interface for trees
+
+classTreetwhere
+-- | tree construction: a new tree is constructed by a node attribute and a list of children
+mkTree::a->[ta]->ta
+
+-- | leaf construction: leafs don't have any children
+--
+-- definition: @ mkLeaf n = mkTree n [] @
+
+mkLeaf::a->ta
+mkLeafn=mkTreen[]
+
+-- | leaf test: list of children empty?
+
+isLeaf::ta->Bool
+isLeaf=null.getChildren
+
+-- | innner node test: @ not . isLeaf @
+
+isInner::ta->Bool
+isInner=not.isLeaf
+
+-- | select node attribute
+
+getNode::ta->a
+
+-- | select children
+
+getChildren::ta->[ta]
+
+-- | edit node attribute
+
+changeNode::(a->a)->ta->ta
+
+-- | edit children
+
+changeChildren::([ta]->[ta])->ta->ta
+
+-- | substitute node: @ setNode n = changeNode (const n) @
+
+setNode::a->ta->ta
+setNoden=changeNode(constn)
+
+-- | substitute children: @ setChildren cl = changeChildren (const cl) @
+
+setChildren::[ta]->ta->ta
+setChildrencl=changeChildren(constcl)
+
+-- | fold for trees
+
+foldTree::(a->[b]->b)->ta->b
+
+-- | all nodes of a tree
+
+nodesTree::ta->[a]
+
+-- | depth of a tree
+
+depthTree::ta->Int
+
+-- | number of nodes in a tree
+
+cardTree::ta->Int
+
+-- | format tree for readable trace output
+--
+-- a /graphical/ representation of the tree in text format
+
+formatTree::(a->String)->ta->String
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Data.Tree.NTree.Filter
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe\@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id: Filter.hs,v 1.6 2006/11/12 14:52:59 hxml Exp $
+
+Filter for n-ary tree structure with filter combinators
+copied and modified from HxXml (<http://www.cs.york.ac.uk/fp/HaXml/>)
+
+Similar but more flexible functions for tree processing are defined in the
+arrow classes "Control.Arrow.ArrowList", "Control.Arrow.ArrowIf", "Control.Arrow.ArrowTree" and "Control.Arrow.ArrowState".
+For new applications, especially for XML processing, it's recommended to use the arrow interface
+"Text.XML.HXT.Arrow" instead of this filter approach as part of the api "Text.XML.HXT.Parser"
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleData.Tree.NTree.Filter
+(moduleData.Tree.NTree.TypeDefs
+,TFilter
+,TSFilter
+,satisfies
+
+-- * Filter
+,none-- simple filter
+,this
+
+,isOf
+,isOfNode-- predicate filter
+
+,mkNTree-- contructor filter
+
+,replaceNode-- simple editing
+,replaceChildren
+
+,modifyNode
+,modifyNode0
+,modifyChildren
+,substChildren
+,processChildren-- filter combinators
+
+,o
+,(.>)
+,seqF
+,(..>)
+,(+++)
+,cat
+
+,orElse-- choices
+,iff-- if then else filter
+,choice
+,IfThen(..)
+,when
+,whenNot
+,guards
+,neg-- negation
+,containing-- previous: with, but with is keyword in haskell extensions
+,notContaining-- previous: without
+
+,(/>)-- selectors
+,(</)
+,deep-- recursive search
+,deepest
+,multi
+,processBottomUp-- recursive editing
+,processBottomUpIfNot
+,processTopDown
+,processTopDownUntil
+,insertChildrenAt
+,insertChildrenAfter
+
+-- * Monadic Filter
+,thisM-- monadic filter
+,noneM
+,(.>>)-- monadic composition
+,seqM-- generalisation of .>>
+,(+++>>)-- monadic parallel combination, monadic +++
+,catM-- monadic form of cat
+,ifM-- monadic if then else
+,choiceM-- monadic choice
+,whenM-- special monadic ifs
+,whenNotM
+,guardsM
+,containingM
+,processChildrenM-- monadic versions of recursive editing
+,processTopDownM
+,processBottomUpM
+,liftMf-- lift a normal filter to a monadic filter
+,($$)-- apply a filter to a list
+,($$<)-- apply a monad filter to a list
+,performAction-- run a command within a filter
+)
+
+where
+
+
+importData.Tree.NTree.TypeDefs
+
+infixl6`containing`,`notContaining`,`containingM`
+infixr5`o`,+++,+++>>
+infixl5/>,</,`orElse`,.>,..>,.>>
+infixr4`when`,`whenNot`,`guards`,`whenM`,`whenNotM`,`guardsM`
+infixr3:->
+infixr0$$,$$<
+
+-- |
+-- tree filter type: a function mapping a tree onto a list of trees
+--
+-- filter can be used in various ways, as predicates, selectors, transformers, ...
+
+typeTFilternode=NTreenode->NTreesnode
+
+-- |
+-- a filter for sequences
+
+typeTSFilternode=NTreesnode->NTreesnode
+
+-- ------------------------------------------------------------
+
+-- |
+-- satisfies converts a result of a predicate filter into a boolean
+--
+-- is a shortcut for not . null
+--
+-- typical use in guards or ifs: @if (satisfies f) t then ... else ... @
+--
+-- * 1.parameter f : the predicate filter
+--
+-- - 2.parameter t : the tree to be tested
+--
+-- - returns : @b = not (null (f t))@
+
+satisfies::(a->[b])->a->Bool
+satisfiesf=not.null.f
+
+-- ------------------------------------------------------------
+--
+-- simple filter
+
+-- |
+-- the null filter, returns the empty list
+
+none::a->[b]
+none_=[]
+
+-- |
+-- the unit filter, returns the single element list containing the argument
+
+this::a->[a]
+thisn=[n]
+
+-- ------------------------------------------------------------
+--
+-- selecting filter
+
+-- |
+-- conversion from predicate function to filter
+--
+-- * 1.parameter p : the predicate for testing the tree
+--
+-- - returns : 'this' or 'none' depending on the predicate
+
+isOf::(a->Bool)->(a->[a])
+isOfpt
+=ifptthen[t]else[]
+
+-- |
+-- select filter, selects trees with node values with a specific property
+--
+-- * 1.parameter p : the predicate for testing the node value
+--
+-- - returns : @[]@ or @[t]@ depending on @p t@
+--
+-- a special case of 'isOf' filter
+
+isOfNode::(node->Bool)->TFilternode
+isOfNodep=isOf(p.getNode)
+
+-- ------------------------------------------------------------
+--
+-- simple editing filters
+
+-- |
+-- filter for substituting an arbitray tree by a constant
+--
+-- * 1.parameter t : the result tree, the input tree is ignored
+--
+-- - returns : the filter
+
+mkNTree::NTreenode->TFilternode
+mkNTreet=const[t]
+
+-- |
+-- filter for replacing the node
+--
+-- * 1.parameter n : the new node
+--
+-- - returns : the editing filter
+
+replaceNode::node->TFilternode
+replaceNoden(NTree_cs)
+=[NTreencs]
+
+-- |
+-- filter for replacing the children
+--
+-- * 1.parameter cs : cs the list of children
+--
+-- - returns : the filter
+
+replaceChildren::NTreesnode->TFilternode
+replaceChildrencs(NTreen_)
+=[NTreencs]
+
+modifyNode::(node->Maybenode)->TFilternode
+modifyNodetf(NTreencs)
+=maybe[](\n'->[NTreen'cs])(tfn)
+
+-- |
+-- filter for editing the node
+--
+-- * 1.parameter nf : the XNode editing funtion
+--
+-- - returns : the filter
+
+modifyNode0::(node->node)->TFilternode
+modifyNode0tf=modifyNode(Just.tf)
+
+-- |
+-- filter for editing the children
+--
+-- all children are processed with a filter mapping lists to lists,
+-- this enables not only elementwise editing by lifting a normal
+-- filter to a list filter with @(f $$)@ (see '($$)') but also manipulation
+-- of the order of the elements, e.g. "reverse" is an appropriate childen
+-- editing function.
+--
+-- * 1.parameter csf : the children editing function
+--
+-- - returns : the filter
+--
+-- see also : 'processChildren'
+
+modifyChildren::TSFilternode->TFilternode
+modifyChildrenf-- (NTree n cs)
+-- = [NTree n (f cs)]
+=substChildren(f.getChildren)
+
+-- |
+-- filter for substituting the children of a tree by
+-- a new list of childen computed by applying a filter to the input tree.
+-- 'modifyChildren' can be expressed by 'substChildren':
+-- @modifyChildren f t@ is equal to @substChildren (f . getChildren)@
+
+substChildren::TFilternode->TFilternode
+substChildrenft@(NTreen_cs)
+=[NTreen(ft)]
+
+-- ------------------------------------------------------------
+--
+-- combinators (copied from HaXml)
+--
+
+-- |
+-- sequential composition of filters, usually written in infix notation f2 `o` f1.
+--
+-- for predicate filter the logical AND
+--
+-- * 1.parameter f2 : the 2. filter
+--
+-- - 2.parameter f1 : the 1. filter
+--
+-- - returns : the fiter applying first f1 to n and then f2 to the result (like function composition)
+
+o::(a->[b])->(c->[a])->(c->[b])
+f`o`g=concatMapf.g
+
+-- |
+-- pronounced \"followed by\", defined as: @f .> g = g \`o\` f@.
+--
+-- allows filter composition in a more readable way from left to right
+--
+-- * 1.parameter f1 : the 1. filter
+--
+-- - 2.parameter f2 : the 2. filter
+--
+-- - returns : the composition of f1 and f2
+--
+-- see also : 'o', '(..>)'
+
+(.>)::(a->[b])->(b->[c])->(a->[c])
+f.>g=g`o`f
+
+-- |
+-- apply a list of filters sequentially with '(.>)', for predicate filters the generalized AND
+--
+-- see also : '(.>)'
+
+seqF::[a->[a]]->(a->[a])
+seqF=foldl(.>)this
+
+-- |
+-- binary parallel composition, the logical OR for predicate filter
+--
+-- * 1.parameter f1 : the 1. filter
+--
+-- - 2.parameter f2 : the 2. filter
+--
+-- - returns : the filter for applying f1 and f2 both to an argument tree and concatenating the results
+
+(+++)::(a->[b])->(a->[b])->(a->[b])
+f+++g=\t->ft++gt
+
+-- |
+-- special sequential composition.
+--
+-- filter f is applied to an argument t.
+-- then filter g is applied to all elements of the result list,
+-- but the argument t is also passed as extra parameter to g.
+--
+-- This allows for step by step transformations of a tree
+-- with access to the original tree in every
+-- transformation step.
+--
+-- see also : '(.>)', 'o'
+
+(..>)::(a->[b])->(a->b->[d])->(a->[d])
+f..>g=\t->(gt`o`f)t
+
+-- |
+-- apply a list of filters, a \"union\" for lists, for predicate filters the generalized OR
+--
+-- * 1.parameter fs : the list of filters
+--
+-- - returns : the composing filter
+
+cat::[a->[b]]->(a->[b])
+catfst
+=concat[ft|f<-fs]
+
+-- |
+-- Filter for editing the children of a tree element wise
+--
+-- * 1.parameter cf : the filter applied to the children
+--
+-- - returns : the editing filter
+--
+-- see also : 'modifyChildren'
+
+processChildren::TFilternode->TFilternode
+processChildrenft(NTreencs)
+=[NTreen(ft$$cs)]
+
+-- |
+-- infix operator for applying a filter to a list of trees
+--
+-- * 1.parameter f : the filter
+--
+-- - 2.parameter ts : the list of trees
+--
+-- - returns : the concatenated list of results
+
+($$)::(a->[b])->[a]->[b]
+f$$l
+=concatMapfl
+
+-- ------------------------------------------------------------
+--
+-- choices
+--
+
+-- |
+-- directional choice, usually written in infix notation as f `orElse` g
+--
+-- * 1.parameter f : the 1. filter
+--
+-- - 2.parameter g : the 2. filter
+--
+-- - 3.parameter t : the tree
+--
+-- - returns : the filter, that applies f to t, if the result is not the empty list, the result is found, else g t is the result
+
+orElse::(a->[b])->(a->[b])->(a->[b])
+f`orElse`g
+=\t->let
+res=ft
+in
+ifnullres
+thengt
+elseres
+
+-- |
+-- if then else lifted to filters
+--
+-- * 1.parameter p : the predicate filter
+--
+-- - 2.parameter t : the \"then\" filter
+--
+-- - 3.parameter e : the \"else\" filter
+--
+-- - returns : the resulting conditional filter
+
+iff::(a->[c])->(a->[b])->(a->[b])->(a->[b])
+iffpfg=\c->if(satisfiesp)cthenfcelsegc
+
+-- |
+-- when the predicate p holds, f is applied, else the identity filter this
+--
+-- * 1.parameter f : the conditinally applied filter
+--
+-- - 2.parameter p : the predicate
+--
+-- - returns : the conditional filter
+--
+-- see also : 'iff', 'whenNot', 'guards', 'whenM'
+
+when::(a->[a])->(a->[a])->(a->[a])
+f`when`g=iffgfthis
+
+-- |
+-- the complementary filter of when
+--
+-- shortcut for f `when` neg g
+--
+-- see also : 'iff', 'when', 'whenNotM', 'neg'
+
+whenNot::(a->[a])->(a->[a])->(a->[a])
+f`whenNot`g=iffgthisf
+
+-- |
+-- when the predicate p holds, f is applied, else the null filter none
+--
+-- * 1.parameter p : the predicate filter
+--
+-- - 2.parameter f : the conditionally applied filter
+--
+-- - returns : the conditional filter
+--
+-- see also : 'iff', 'when', 'guardsM'
+
+guards::(a->[b])->(a->[b])->(a->[b])
+g`guards`f=iffgfnone
+
+
+-- |
+-- negation lifted to filters
+--
+-- * 1.parameter f : the predicate filter
+--
+-- - returns : the filter, that succeeds, when f failed
+
+neg::(a->[c])->a->[a]
+negf=ifffnonethis
+
+-- |
+-- auxiliary datatype for cases within choice filter
+
+dataIfThenab=a:->b
+
+-- |
+-- multiway branch. The list of cases @f :-> g@ is processed sequentially,
+-- in the first case for that f holds g is applied, if no case matches, 'none' is
+-- applied.
+-- This filter can be used like a case expression: @choice [ p1 :-> f1, p2 :-> f2, ... , this :-> defaultFilter]@
+--
+-- see also : 'iff', 'choiceM'
+
+choice::[IfThen(a->[c])(a->[b])]->(a->[b])
+choice[]
+=none
+
+choice((g:->f):cs)
+=iffgf(choicecs)
+
+-- |
+-- pruning: keep only those results from f for which g holds, usually written in infix notation as f `containing` g
+--
+-- * 1.parameter f : the processing filter
+--
+-- - 2.parameter g : the predicate filter
+--
+-- - 3.parameter t : the tree
+--
+-- - returns : all trees r from f t, for which g r holds (is not the empty list)
+--
+-- see also : 'notContaining'
+
+containing::(a->[b])->(b->[c])->a->[b]
+f`containing`g
+=filter(satisfiesg).f
+
+-- |
+-- pruning: keep only those results from f for which g does not hold
+--
+-- see also : 'containing'
+
+notContaining::(a->[b])->(b->[c])->a->[b]
+f`notContaining`g
+=filter(null.g).f
+
+-- |
+-- pruning: monadic version of containing, usually written in infix notation as f `containingM` g
+--
+-- * 1.parameter f : the monadic processing filter
+--
+-- - 2.parameter g : the predicate filter
+--
+-- - 3.parameter t : the tree
+--
+-- - returns : all trees r from f t, for which g r holds (is not the empty list)
+--
+-- see also : 'notContaining'
+
+containingM::Monadm=>(a->m[b])->(b->[c])->a->m[b]
+f`containingM`g
+=\t->do
+res<-ft
+return$filter(satisfiesg)res
+
+-- |
+-- pronounced \"slash\", meaning g inside f
+
+(/>)::TFilternode->TFilternode->TFilternode
+f/>g
+=g`o`getChildren`o`f
+
+-- |
+-- pronounced \"outside\" meaning f containing g
+
+(</)::TFilternode->TFilternode->TFilternode
+f</g
+=f`containing`(g`o`getChildren)
+
+-- ------------------------------------------------------------
+--
+-- recursive search filters
+
+-- |
+-- top down search.
+--
+-- search terminates, when filter f succeeds
+-- can e.g. be used for finding all outermost tag node of a specific kind
+
+deep::TFilternode->TFilternode
+deepf
+=f`orElse`(deepf`o`getChildren)
+
+-- |
+-- bottom up search.
+--
+-- first the children are processed,
+-- if this does not succeed, the node itself is processed
+-- can e.g. be used for finding all innermost tag nodes of a specific kind
+
+deepest::TFilternode->TFilternode
+deepestf
+=(getChildren.>deepestf)`orElse`f
+
+-- |
+-- process all nodes of the whole tree.
+--
+-- can e.g. be used for finding all nodes of a specific kind
+
+multi::TFilternode->TFilternode
+multif
+=f+++(getChildren.>multif)
+
+-- ------------------------------------------------------------
+--
+-- recursive transformation filters
+--
+
+-- |
+-- bottom up transformation
+--
+-- * 1.parameter f : the /simple/ transforming filter
+--
+-- - returns : the filter that applies f to all subtrees and the tree itself in a deepth first left to right manner
+--
+-- see also : 'processTopDown', 'processBottomUpIfNot'
+
+processBottomUp::TFilternode->TFilternode
+processBottomUpf
+=processChildren(processBottomUpf).>f
+
+-- |
+-- top down transformation
+--
+-- * 1.parameter f : the /simple/ transforming filter
+--
+-- - returns : the filter that applies f first to the tree and then recursively to all subtrees of the result
+--
+-- see also : 'processBottomUp'
+
+processTopDown::TFilternode->TFilternode
+processTopDownf
+=f.>processChildren(processTopDownf)
+
+-- |
+-- guarded bottom up transformation, stops at subtrees for which a predicate p holds
+--
+-- * 1.parameter f : the transforming filter
+--
+-- - 2.parameter p : the predicate filter for the guard
+--
+-- - returns : the filter for processing all (sub-)trees
+--
+-- see also : 'processBottomUp'
+
+processBottomUpIfNot::TFilternode->TFilternode->TFilternode
+processBottomUpIfNotfp
+=(processChildren(processBottomUpIfNotfp).>f)`whenNot`p
+
+-- |
+-- top down transformation until a node to be transformed is found
+--
+-- * 1.parameter f : the /simple/ transforming filter
+--
+-- - returns : the filter that applies f first to the tree and, if the filter does not succeed,
+-- recursively to all children of the input tree.
+--
+-- Example:
+--
+-- @processTopDownUntil none@
+--
+-- is the identity filter (maybe a bit more inefficient).
+--
+-- Example:
+--
+-- @processTopDownUntil (add1Attr \"border\" \"2\" \`containing\` isTag \"table\")@
+--
+-- is a filter for adding an attribute border=\"2\" in all top level table tags.
+-- The content of table tags will remain unchanged.
+--
+-- see also : 'processTopDown', 'processBottomUp'
+
+processTopDownUntil::TFilternode->TFilternode
+processTopDownUntilft
+|nullres
+=processChildren(processTopDownUntilf)t
+|otherwise
+=res
+where
+res=ft
+
+-- ------------------------------------------------------------
+--
+
+-- |
+-- insertion of trees into the list of children at a given position
+--
+-- useful for inserting something into the list of children at a given position
+-- the list of children is split with the @splitAt@ function
+-- the nodes are inserted between these two sublists.
+--
+-- examples: @insertChildrenAt 0 ins t@ inserts all elements computed with @ins t@ in front
+-- of the childen of @t@, @insertChildrenAt 1 ins t@ behind the first child
+--
+-- see also: 'insertChildrenAfter'
+
+
+insertChildrenAt::Int->TFilternode->TFilternode
+insertChildrenAtiinst
+=replaceChildren(cl1++inst++cl2)t
+where
+(cl1,cl2)=splitAti$getChildrent
+
+-- |
+-- insertion of trees into the list of children after specific elements
+--
+-- useful for inserting something into the list of children of a node
+-- the list of children is split with the @span@ function and the filter p as predicate
+-- the nodes are inserted between these two sublists
+--
+-- examples: @insertChildrenAfter none ins t@ inserts all elements computed with @ins t@ in front
+-- of the childen of @t@, @insertChildrenAfter this ins t@ appends the elements to the children
+--
+-- see also: 'insertChildrenAt'
+
+insertChildrenAfter::TFilternode->TFilternode->TFilternode
+insertChildrenAfterpinst
+=replaceChildren(cl1++inst++cl2)t
+where
+(cl1,cl2)=span(not.null.p)$getChildrent
+
+-- ------------------------------------------------------------
+--
+-- monadic filter
+
+-- |
+-- the monadic version of the identity filter this.
+--
+-- see also : 'this'
+
+thisM::Monadm=>(a->m[a])
+thisM=liftMfthis
+
+-- |
+-- the monadic version of the null filter none.
+--
+-- see also : 'none'
+
+noneM::Monadm=>(a->m[b])
+noneM=liftMfnone
+
+-- |
+-- sequential composition of monadic filters, monadic version of \".>\".
+--
+-- * 1.parameter f1 : the 1. monadic filter
+--
+-- - 2.parameter f2 : the 2. monadic filter
+--
+-- - returns : the monadic fiter applying first f1 to n and then f2 to the result (like function composition)
+--
+-- see also : '(.>)'
+
+(.>>)::Monadm=>(a->m[b])->(b->m[c])->(a->m[c])
+cmd1.>>cmd2
+=\t->
+do
+r1<-cmd1t
+r2<-mapMcmd2r1
+return(concatr2)
+
+-- |
+-- generalized sequential composition of monadic filters
+
+seqM::Monadm=>[a->m[a]]->(a->m[a])
+seqM
+=foldr(.>>)thisM
+
+-- |
+-- binary parallel composition, the logical OR for predicate filter
+--
+-- * 1.parameter f1 : the 1. filter
+--
+-- - 2.parameter f2 : the 2. filter
+--
+-- - returns : the filter for applying f1 and f2 both to an argument tree and concatenating the results
+-- see also: 'cat', '+++', 'catM'
+
+(+++>>)::Monadm=>(a->m[b])->(a->m[b])->(a->m[b])
+f+++>>g=\t->do
+r1<-ft
+r2<-gt
+return(r1++r2)
+
+-- |
+-- apply a list of monadic filters
+--
+-- * 1.parameter fs : the list of filters
+--
+-- - returns : the composing filter
+-- see also: 'cat', '+++', '+++>>'
+
+catM::Monadm=>[a->m[b]]->(a->m[b])
+catMfst
+=do
+res<-sequence(map($t)fs)
+return$concatres
+
+-- |
+-- monadic if-then-else.
+--
+-- * 1.parameter p : the predicate
+--
+-- - 2.parameter thenP : the then part: the monadic filter, that is applied if p holds for the input tree
+--
+-- - 3.parameter elseP : the else part
+--
+-- - returns : the monadic filter for the conditional
+
+ifM::Monadm=>(a->[b])->(a->m[c])->(a->m[c])->(a->m[c])
+ifMpthenPartelsePart
+=\t->
+if(satisfiesp)t
+thenthenPartt
+elseelsePartt
+
+-- |
+-- monadic version of multiway branch. The list of cases @f :-> g@ is processed sequentially,
+-- in the first case for that f holds g is applied, if no case matches, 'noneM' is
+-- applied.
+-- This filter can be used like a case expression: @choiceM [ p1 :-> f1, p2 :-> f2, ... , thisM :-> defaultFilter]@
+--
+-- see also : 'choice', 'ifM'
+
+choiceM::Monadm=>[IfThen(a->[c])(a->m[b])]->(a->m[b])
+choiceM[]
+=noneM
+
+choiceM((g:->f):cs)
+=ifMgf(choiceMcs)
+
+
+-- |
+-- when the predicate p holds, the monadic filter f is applied, else the identity filter.
+--
+-- * 1.parameter f : the conditinally applied monadic filter
+--
+-- - 2.parameter p : the simple predicate
+--
+-- - returns : the conditional filter
+--
+-- see also : 'ifM', 'when', 'guardsM', 'whenNotM'
+
+whenM::Monadm=>(a->m[a])->(a->[b])->(a->m[a])
+f`whenM`g=ifMgfthisM
+
+-- |
+-- the complementary filter of whenM.
+--
+-- see also : 'ifM', 'whenM', 'whenNot'
+
+whenNotM::Monadm=>(a->m[a])->(a->[b])->(a->m[a])
+f`whenNotM`g=ifMgthisMf
+
+-- |
+-- when the predicate p holds, the monadic filter f is applied, else the null filter.
+--
+-- * 1.parameter p : the simple predicate filter
+--
+-- - 2.parameter f : the conditionally applied monadic filter
+--
+-- - returns : the conditional filter
+--
+-- see also : 'ifM', 'guards', 'whenM'
+
+guardsM::Monadm=>(a->[b])->(a->m[c])->(a->m[c])
+g`guardsM`f=ifMgfnoneM
+
+-- |
+-- Filter for editing the children of a tree with a monadic filter
+--
+-- * 1.parameter cf : the monadic filter applied to the children
+--
+-- - returns : the monadic editing filter
+--
+-- see also : 'processChildren'
+
+processChildrenM::Monadm=>(NTreenode->m[NTreenode])->(NTreenode->m[NTreenode])
+processChildrenMft(NTreencs)
+=do
+res<-ft$$<cs
+return[NTreenres]
+
+-- |
+-- monadic variant of 'processTopDown'
+
+processTopDownM::Monadm=>(NTreenode->m[NTreenode])->(NTreenode->m[NTreenode])
+processTopDownMf
+=f.>>processChildrenM(processTopDownMf)
+
+-- |
+-- monadic variant of 'processBottomUp'
+
+processBottomUpM::Monadm=>(NTreenode->m[NTreenode])->(NTreenode->m[NTreenode])
+processBottomUpMf
+=processChildrenM(processBottomUpMf).>>f
+
+-- |
+-- infix operator for applying a monadic filter to a list of trees,
+-- typically used in do-notation for processing of intermediate results.
+--
+-- * 1.parameter f : the monadic filter
+--
+-- - 2.parameter ts : the list of trees
+--
+-- - returns : the concatenated list of results
+--
+-- see also : '($$)'
+
+($$<)::Monadm=>(a->m[b])->[a]->m[b]
+cmd$$<l
+=do
+r<-mapMcmdl
+return(concatr)
+
+-- |
+-- lift a filter to a monadic filter
+--
+-- * 1.parameter f : the /simple/ filter
+--
+-- - returns : the lifted monadic version
+
+liftMf::Monadm=>(a->[b])->a->m[b]
+liftMfft
+=return(ft)
+
+-- |
+-- run an arbitray command on a tree t and return the tree,
+-- used for inserting arbitray commands in a filter pipeline
+--
+-- * 1.parameter cmd : the command
+--
+-- - 2.parameter t : the argument tree
+--
+-- - returns : the unchanged tree as a single element list
+
+performAction::Monadm=>(a->mb)->a->m[a]
+performActioncmdt
+=do
+cmdt
+return[t]
+
+-- eof ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.Arrow.DocumentInput
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id$
+
+ State arrows for document input
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.Arrow.DocumentInput
+(getURIContents
+,getXmlContents
+,getXmlEntityContents
+,getEncoding
+,decodeDocument
+)
+where
+
+importControl.Arrow-- arrow classes
+importControl.Arrow.ArrowList
+importControl.Arrow.ArrowIf
+importControl.Arrow.ArrowTree
+importControl.Arrow.ArrowIO
+
+importText.XML.HXT.DOM.Unicode
+(getDecodingFct
+,guessEncoding
+,normalizeNL
+)
+
+importqualifiedText.XML.HXT.IO.GetFILEasFILE
+importqualifiedText.XML.HXT.IO.GetHTTPNativeasHTTP
+importqualifiedText.XML.HXT.IO.GetHTTPCurlasCURL
+
+importText.XML.HXT.DOM.Interface
+importText.XML.HXT.Arrow.XmlArrow
+importText.XML.HXT.Arrow.XmlIOStateArrow
+
+importText.XML.HXT.Arrow.ParserInterface
+(parseXmlDocEncodingSpec
+,parseXmlEntityEncodingSpec
+,removeEncodingSpec
+)
+
+importData.List
+(isPrefixOf
+)
+
+importData.Char
+(toLower
+)
+
+importData.Maybe
+
+-- ----------------------------------------------------------
+
+protocolHandlers::AssocListString(IOStateArrowsXmlTreeXmlTree)
+protocolHandlers
+=[("file",getFileContents)
+,("http",getHttpContents)
+,("stdin",getStdinContents)
+]
+
+getProtocolHandler::IOStateArrowsString(IOStateArrowsXmlTreeXmlTree)
+getProtocolHandler
+=arr(\s->lookupDefgetUnsupportedsprotocolHandlers)
+
+getUnsupported::IOStateArrowsXmlTreeXmlTree
+getUnsupported
+=perform(getAttrValuea_source
+>>>
+arr(("unsupported protocol in URI "++).show)
+>>>
+applyA(arrissueFatal)
+)
+>>>
+setDocumentStatusFromSystemState"accessing documents"
+
+getStringContents::IOStateArrowsXmlTreeXmlTree
+getStringContents
+=setCont$<getAttrValuea_source
+>>>
+addAttrtransferMessage"OK"
+>>>
+addAttrtransferStatus"200"
+where
+setContcontents
+=replaceChildren(txtcontents')
+>>>
+addAttrtransferURI(take7contents)-- the "string:" prefix is stored, this is required by setBaseURIFromDoc
+>>>
+addAttra_source(show.prefix48$contents')-- a quoted prefix of the content, max 48 chars is taken as source name
+where
+contents'=drop(lengthstringProtocol)contents
+prefixls
+|lengths'>l=take(l-3)s'++"..."
+|otherwise=s'
+where
+s'=take(l+1)s
+
+getFileContents::IOStateArrowsXmlTreeXmlTree
+getFileContents
+=applyA(getAttrValuetransferURI
+>>>
+getPathFromURI
+>>>
+arrIOFILE.getCont
+>>>
+(arraddError-- io error occured
+|||
+arraddTxtContent-- content read
+)
+)
+
+getStdinContents::IOStateArrowsXmlTreeXmlTree
+getStdinContents
+=applyA(arrIO(\_->FILE.getStdinCont)
+>>>
+(arraddError-- io error occured
+|||
+arraddTxtContent-- content read
+)
+)
+
+addError::String->IOStateArrowsXmlTreeXmlTree
+addErrore
+=issueFatale
+>>>
+setDocumentStatusFromSystemState"accessing documents"
+
+addTxtContent::String->IOStateArrowsXmlTreeXmlTree
+addTxtContentc
+=replaceChildren(txtc)
+>>>
+addAttrtransferMessage"OK"
+>>>
+addAttrtransferStatus"200"
+
+getHttpContents::IOStateArrowsXmlTreeXmlTree
+getHttpContents
+=getCont$<<<<(getAttrValuetransferURI
+&&&
+getOpta_proxy
+&&&
+getOpta_use_curl
+&&&
+getOpta_options_curl
+)
+where
+getOptopt
+=getAttrValue0opt
+`orElse`
+getParamStringopt
+
+getConturiproxycurlcurlOpt
+=applyA((ifcurl==v_1
+then(traceMsg2("get HTTP via "
+++show("curl "
+++(ifnullproxythen""else"--proxy "++proxy)
+++(ifnullcurlOptthen""else" "++curlOpt)
+++" "++uri
+)
+)
+>>>
+arrIO0(CURL.getContcurlOpturiproxy)
+)
+elsearrIO0(HTTP.getConturiproxy)
+)
+>>>
+(arraddError
+|||
+arraddContent
+)
+)
+
+addContent::(AssocListStringString,String)->IOStateArrowsXmlTreeXmlTree
+addContent(al,c)
+=replaceChildren(txtc)
+>>>
+seqA(map(uncurryaddAttr)al)
+
+getURIContents::IOStateArrowsXmlTreeXmlTree
+getURIContents
+=getContentsFromString
+`orElse`
+getContentsFromDoc
+where
+getContentsFromString
+=(getAttrValuea_source
+>>>
+isA(isPrefixOfstringProtocol)
+)
+`guards`
+getStringContents
+
+getContentsFromDoc
+=((addTransferURI$<getBaseURI
+>>>
+getCont
+)
+`when`
+(setAbsURI$<(getAttrValuea_source
+>>^
+(\src->(ifnullsrcthen"stdin:"elsesrc))-- empty document name -> read from stdin
+)
+)
+)
+>>>
+setDocumentStatusFromSystemState"getURIContents"
+
+setAbsURIsrc
+=ifA(constAsrc>>>changeBaseURI)
+this
+(issueFatal("illegal URI : "++showsrc))
+
+addTransferURIuri
+=addAttrtransferURIuri
+
+getCont
+=applyA(getBaseURI-- compute the handler and call it
+>>>
+traceString2(("getURIContents: reading"++).show)
+>>>
+getSchemeFromURI
+>>>
+getProtocolHandler
+)
+`orElse`
+this-- don't change tree, when no handler can be found
+
+setBaseURIFromDoc::IOStateArrowsXmlTreeXmlTree
+setBaseURIFromDoc
+=perform(getAttrValuetransferURI
+>>>
+isA(isPrefixOfstringProtocol)-- do not change base URI when reading from a string
+>>>
+setBaseURI
+)
+
+{- |
+ Read the content of a document.
+
+ This routine is usually called from 'Text.XML.HXT.Arrow.ProcessDocument.getDocumentContents'.
+
+ The input must be a root node (constructed with 'Text.XML.HXT.Arrow.XmlArrow.root'), usually without children.
+ The attribute list contains all input parameters, e.g. URI or source file name, encoding preferences, ...
+ If the source name is empty, the input is read from standard input.
+
+ The source is transformed into an absolute URI. If the source is a relative URI, or a file name,
+ it is expanded into an absolut URI with respect to the current base URI.
+ The default base URI is of protocol \"file\" and points to the current working directory.
+
+ The currently supported protocols are \"http\", \"file\", \"stdin\" and \"string\".
+
+ The latter two are internal protocols. An uri of the form \"stdin:\" stands for the content of
+ the standard input stream.
+
+ \"string:some text\" means, that \"some text\" is taken as input.
+ This internal protocol is used for reading from normal 'String' values.
+
+-}
+
+getXmlContents::IOStateArrowsXmlTreeXmlTree
+getXmlContents
+=getXmlContents'parseXmlDocEncodingSpec
+>>>
+setBaseURIFromDoc
+
+getXmlEntityContents::IOStateArrowsXmlTreeXmlTree
+getXmlEntityContents
+=getXmlContents'parseXmlEntityEncodingSpec
+>>>
+processChildrenremoveEncodingSpec
+>>>
+setBaseURIFromDoc
+
+getXmlContents'::IOStateArrowsXmlTreeXmlTree->IOStateArrowsXmlTreeXmlTree
+getXmlContents'parseEncodingSpec
+=(getURIContents
+>>>
+parseEncodingSpec
+>>>
+filterErrorMsg
+>>>
+decodeDocument
+>>>
+perform(getAttrValuetransferURI
+>>>
+traceString1(("getXmlContents: content read and decoded for "++).show)
+)
+>>>
+traceTree
+>>>
+traceSource
+)
+`when`
+isRoot
+
+-- ------------------------------------------------------------
+
+getEncoding::IOStateArrowsXmlTreeString
+getEncoding
+=catA[xshowgetChildren-- 1. guess: guess encoding by looking at the first few bytes
+>>>
+arrguessEncoding
+,getAttrValuetransferEncoding-- 2. guess: take the transfer encoding
+,getAttrValuea_encoding-- 4. guess: take encoding parameter in root node
+,getParamStringa_encoding-- 5. guess: take encoding parameter in global state
+,constAutf8-- default : utf8
+]
+>.(head.filter(not.null))-- make the filter deterministic: take 1. entry from list of guesses
+
+
+decodeDocument::IOStateArrowsXmlTreeXmlTree
+decodeDocument
+=(decodeArr$<getEncoding)
+`when`
+(isRoot>>>isXmlOrHtmlDoc)
+where
+isXmlOrHtmlDoc
+=(getAttrValuetransferMimeType>>^maptoLower)
+>>>
+isA(\t->nullt||isXmlMimeTypet||isHtmlMimeTypet)
+
+decodeArr::String->IOStateArrowsXmlTreeXmlTree
+decodeArrenc
+=maybenotFoundfound.getDecodingFct$enc
+where
+founddf
+=traceMsg2("decodeDocument: encoding is "++showenc)
+>>>
+processChildren(decodeTextdf)
+>>>
+addAttrtransferEncodingenc
+
+notFound
+=issueFatal("encoding scheme not supported: "++showenc)
+>>>
+setDocumentStatusFromSystemState"decoding document"
+
+decodeTextdf
+=getText
+>>>arrdf-- result is (string, [errMsg])
+>>>(((normalizeNL.fst)^>>mkText)-- take string, normalize newline and build text node
+<+>
+(arrLsnd-- take the error messages
+>>>
+arr((enc++).(" encoding error"++))-- prefix with enc error
+>>>
+applyA(arrissueErr)-- build issueErr arrow and apply
+>>>
+none-- neccessary for type match with <+>
+)
+)
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.Arrow.Edit
+ Copyright : Copyright (C) 2006 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id: Edit.hs,v 1.8 2006/11/12 14:52:59 hxml Exp $
+
+ common edit arrows
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.Arrow.Edit
+(canonicalizeAllNodes
+,canonicalizeForXPath
+,canonicalizeContents
+,collapseAllXText
+,collapseXText
+
+,escapeXmlDoc
+,escapeHtmlDoc
+
+,haskellRepOfXmlDoc
+,treeRepOfXmlDoc
+,addHeadlineToXmlDoc
+
+,indentDoc
+,numberLinesInXmlDoc
+
+,removeComment
+,removeAllComment
+,removeWhiteSpace
+,removeAllWhiteSpace
+,removeDocWhiteSpace
+
+,transfCdata
+,transfAllCdata
+,transfCharRef
+,transfAllCharRef
+
+,hasXmlPi
+,addXmlPi
+,addXmlPiEncoding
+
+,addDoctypeDecl
+,addXHtmlDoctypeStrict
+,addXHtmlDoctypeTransitional
+,addXHtmlDoctypeFrameset
+)
+where
+
+importControl.Arrow
+importControl.Arrow.ArrowList
+importControl.Arrow.ArrowIf
+importControl.Arrow.ArrowTree
+
+importControl.Arrow.ListArrow
+
+importText.XML.HXT.Arrow.XmlArrow
+
+importText.XML.HXT.DOM.Interface
+
+importqualified
+Text.XML.HXT.DOM.XmlNodeasXN
+
+importText.XML.HXT.DOM.Unicode
+(isXmlSpaceChar)
+
+importText.XML.HXT.DOM.FormatXmlTree
+(formatXmlTree)
+
+importText.XML.HXT.Parser.XmlEntities
+(xmlEntities)
+
+importText.XML.HXT.Parser.XhtmlEntities
+(xhtmlEntities)
+
+importData.Maybe
+
+importqualifiedData.MapasM
+
+-- ------------------------------------------------------------
+
+-- |
+-- Applies some "Canonical XML" rules to a document 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'::LAXmlTreeXmlTree->LAXmlTreeXmlTree
+canonicalizeTree'toBeRemoved
+=processChildren(none`when`isText)
+>>>
+processBottomUpcanonicalize1Node
+where
+canonicalize1Node::LAXmlTreeXmlTree
+canonicalize1Node
+=(deepisPi`when`isDTD)-- remove DTD parts, except PIs
+>>>
+(none`when`toBeRemoved)-- remove unintersting nodes
+>>>
+(processAttrl(processChildrentransfCharRef
+>>>
+collapseXText
+)
+`when`isElem
+)
+>>>
+transfCdata-- CDATA -> text
+>>>
+transfCharRef-- Char refs -> text
+>>>
+collapseXText-- combine text
+
+
+-- |
+-- Applies some "Canonical XML" rules to a document 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.
+--
+-- Rules: remove DTD parts, processing instructions, comments and substitute char refs in attribute
+-- values and text
+--
+-- Not implemented yet:
+--
+-- - Whitespace within start and end tags is normalized
+--
+-- - Special characters in attribute values and character content are replaced by character references
+
+canonicalizeAllNodes::ArrowLista=>aXmlTreeXmlTree
+canonicalizeAllNodes
+=fromLA$
+canonicalizeTree'(isCmt-- remove comment
+<+>
+isXmlPi-- remove xml declaration
+)
+
+-- |
+-- Canonicalize a tree for XPath
+-- Like 'canonicalizeAllNodes' but comment nodes are not removed
+--
+-- see 'canonicalizeAllNodes'
+
+canonicalizeForXPath::ArrowLista=>aXmlTreeXmlTree
+canonicalizeForXPath
+=fromLA$
+canonicalizeTree'isXmlPi
+
+-- |
+-- Canonicalize the contents of a document
+--
+-- substitutes all char refs in text and attribute values,
+-- removes CDATA section and combines all sequences of resulting text
+-- nodes into a single text node
+--
+-- see 'canonicalizeAllNodes'
+
+canonicalizeContents::ArrowLista=>aXmlTreeXmlTree
+canonicalizeContents
+=fromLA$
+processBottomUpcanonicalize1Node
+where
+canonicalize1Node::LAXmlTreeXmlTree
+canonicalize1Node
+=(processAttrl(processChildrentransfCharRef
+>>>
+collapseXText
+)
+`when`isElem
+)
+>>>
+transfCdata-- CDATA -> text
+>>>
+transfCharRef-- Char refs -> text
+>>>
+collapseXText-- combine text
+
+-- ------------------------------------------------------------
+
+collapseXText'::LAXmlTreeXmlTree
+collapseXText'
+=replaceChildren(listAgetChildren>>>arrL(foldrmergeText'[]))
+where
+mergeText'::XmlTree->XmlTrees->XmlTrees
+mergeText't1(t2:ts2)
+|XN.isTextt1&&XN.isTextt2
+=let
+s1=fromJust.XN.getText$t1
+s2=fromJust.XN.getText$t2
+t=XN.mkText(s1++s2)
+in
+t:ts2
+mergeText't1ts
+=t1:ts
+
+-- |
+-- Collects sequences of text nodes in the list of children of a node into one single text node.
+-- This is useful, e.g. after char and entity reference substitution
+
+collapseXText::ArrowLista=>aXmlTreeXmlTree
+collapseXText
+=fromLA$
+collapseXText'
+
+-- |
+-- Applies collapseXText recursively.
+--
+--
+-- see also : 'collapseXText'
+
+collapseAllXText::ArrowLista=>aXmlTreeXmlTree
+collapseAllXText
+=fromLA$
+processBottomUpcollapseXText'
+
+-- ------------------------------------------------------------
+
+-- |
+-- escape XmlText,
+-- transform all special XML chars into char- or entity- refs
+
+typeEntityRefTable=M.MapIntString
+
+xmlEntityRefTable
+,xhtmlEntityRefTable::EntityRefTable
+
+xmlEntityRefTable=buildEntityRefTable$xmlEntities
+xhtmlEntityRefTable=buildEntityRefTable$xhtmlEntities
+
+buildEntityRefTable::[(String,Int)]->EntityRefTable
+buildEntityRefTable=M.fromList.map(\(x,y)->(y,x))
+
+escapeText''::(Char->XmlTree)->(Char->Bool)->XmlTree->XmlTrees
+escapeText''escCharisEsct
+=maybe[t]escape.XN.getText$t
+where
+escape[]
+=[]
+escape(c:s1)
+|isEscc
+=escCharc:escapes1
+escapes
+=XN.mkTexts1:escapes2
+where
+(s1,s2)=breakisEscs
+
+{-
+escapeCharRef :: Char -> XmlTree
+escapeCharRef = XN.mkCharRef . fromEnum
+-}
+
+escapeEntityRef::EntityRefTable->Char->XmlTree
+escapeEntityRefentityTablec
+=maybe(XN.mkCharRefc')XN.mkEntityRef.M.lookupc'$entityTable
+where
+c'=fromEnumc
+
+escapeXmlEntityRef::Char->XmlTree
+escapeXmlEntityRef=escapeEntityRefxmlEntityRefTable
+
+escapeHtmlEntityRef::Char->XmlTree
+escapeHtmlEntityRef=escapeEntityRefxhtmlEntityRefTable
+
+-- |
+-- escape all special XML chars into XML entity references or char references
+--
+-- convert the special XML chars \< and & in text nodes into prefefiened XML entity references,
+-- in attribute values also \', \", \>, \\n, \\r and \\t are converted into entity or char references,
+-- in comments nothing is converted (see XML standard 2.4, useful e.g. for JavaScript).
+
+escapeXmlDoc::ArrowLista=>aXmlTreeXmlTree
+escapeXmlDoc
+=fromLA$escapeDocescXmlTextescXmlAttrValue
+where
+escXmlText
+=arrL$escapeText''escapeXmlEntityRef(`elem`"<&")-- no escape for ", ' and > required: XML standard 2.4
+escXmlAttrValue
+=arrL$escapeText''escapeXmlEntityRef(`elem`"<>\"\'&\n\r\t")
+
+
+-- |
+-- escape all special HTML chars into XHTML entity references or char references
+--
+-- convert the special XML chars \< and & and all none ASCII chars in text nodes into prefefiened XML or XHTML entity references,
+-- in attribute values also \', \", \>, \\n, \\r and \\t are converted into entity or char references,
+-- in comments nothing is converted
+
+escapeHtmlDoc::ArrowLista=>aXmlTreeXmlTree
+escapeHtmlDoc
+=fromLA$escapeDocescHtmlTextescHtmlAttrValue
+where
+escHtmlText
+=arrL$escapeText''escapeHtmlEntityRefisHtmlTextEsc
+escHtmlAttrValue
+=arrL$escapeText''escapeHtmlEntityRefisHtmlAttrEsc
+
+isHtmlTextEscc
+=c>=toEnum(128)||(c`elem`"<&")
+isHtmlAttrEscc
+=c>=toEnum(128)||(c`elem`"<>\"\'&\n\r\t")
+
+escapeDoc::LAXmlTreeXmlTree->LAXmlTreeXmlTree->LAXmlTreeXmlTree
+escapeDocescTextescAttr
+=escape
+where
+escape
+=choiceA
+[isElem:->(processChildrenescape
+>>>
+processAttrlescVal
+)
+,isText:->escText
+-- , isCmt :-> escCmt
+,isDTD:->processTopDownescDTD
+,this:->this
+]
+escVal=processChildrenescAttr
+escDTD=escVal`when`(isDTDEntity<+>isDTDPEntity)
+
+-- ------------------------------------------------------------
+
+-- |
+-- convert a document into a Haskell representation (with show).
+--
+-- Useful for debugging and trace output.
+-- see also : 'treeRepOfXmlDoc', 'numberLinesInXmlDoc'
+
+haskellRepOfXmlDoc::ArrowLista=>aXmlTreeXmlTree
+haskellRepOfXmlDoc
+=fromLA$
+root[getAttrl][show^>>mkText]
+
+-- |
+-- 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::ArrowLista=>aXmlTreeXmlTree
+numberLinesInXmlDoc
+=fromLA$
+processChildren(changeTextnumberLines)
+where
+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::ArrowLista=>aXmlTreeXmlTree
+treeRepOfXmlDoc
+=fromLA$
+root[getAttrl][formatXmlTree^>>mkText]
+
+addHeadlineToXmlDoc::ArrowXmla=>aXmlTreeXmlTree
+addHeadlineToXmlDoc
+=fromLA$(addTitle$<(getAttrValuea_source>>^formatTitle))
+where
+addTitlestr
+=replaceChildren(txtstr<+>getChildren<+>txt"\n")
+formatTitlestr
+="\n"++headline++"\n"++underline++"\n\n"
+where
+headline="content of: "++str
+underline=map(const'=')headline
+
+-- ------------------------------------------------------------
+
+removeComment'::LAXmlTreeXmlTree
+removeComment'=none`when`isCmt
+
+-- |
+-- remove Comments: @none `when` isCmt@
+
+removeComment::ArrowXmla=>aXmlTreeXmlTree
+removeComment=fromLA$removeComment'
+
+-- |
+-- remove all comments recursively
+
+removeAllComment::ArrowXmla=>aXmlTreeXmlTree
+removeAllComment=fromLA$processBottomUpremoveComment'
+
+-- ----------
+
+removeWhiteSpace'::LAXmlTreeXmlTree
+removeWhiteSpace'=none`when`isWhiteSpace
+
+-- |
+-- simple filter for removing whitespace.
+--
+-- no check on sigificant whitespace, e.g. in HTML \<pre\>-elements, is done.
+--
+--
+-- see also : 'removeAllWhiteSpace', 'removeDocWhiteSpace'
+
+removeWhiteSpace::ArrowXmla=>aXmlTreeXmlTree
+removeWhiteSpace=fromLA$removeWhiteSpace'
+
+-- |
+-- simple recursive filter for removing all whitespace.
+--
+-- removes all text nodes in a tree that consist only of whitespace.
+--
+--
+-- see also : 'removeWhiteSpace', 'removeDocWhiteSpace'
+
+removeAllWhiteSpace::ArrowXmla=>aXmlTreeXmlTree
+removeAllWhiteSpace=fromLA$processBottomUpremoveWhiteSpace'
+
+-- |
+-- filter for removing all not significant whitespace.
+--
+-- the tree traversed for removing whitespace between elements,
+-- 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::ArrowXmla=>aXmlTreeXmlTree
+removeDocWhiteSpace=fromLA$removeRootWhiteSpace
+
+
+removeRootWhiteSpace::LAXmlTreeXmlTree
+removeRootWhiteSpace
+=processChildrenprocessRootElement
+`when`
+isRoot
+where
+processRootElement::LAXmlTreeXmlTree
+processRootElement
+=removeWhiteSpace>>>processChild
+where
+processChild
+=choiceA[isDTD
+:->removeAllWhiteSpace-- whitespace in DTD is redundant
+,this
+:->replaceChildren(getChildren
+>>.indentTreesinsertNothingFalse1
+)
+]
+
+-- ------------------------------------------------------------
+
+-- |
+-- 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 or a document fragment
+-- result is the semantically equivalent formatted tree.
+--
+--
+-- see also : 'removeDocWhiteSpace'
+
+indentDoc::ArrowXmla=>aXmlTreeXmlTree
+indentDoc=fromLA$
+((isRoot`guards`indentRoot)
+`orElse`
+(root[][this]>>>indentRoot>>>getChildren)
+)
+
+-- ------------------------------------------------------------
+
+indentRoot::LAXmlTreeXmlTree
+indentRoot=processChildrenindentRootChildren
+where
+indentRootChildren
+=removeText>>>indentChild>>>insertNL
+where
+removeText=none`when`isText
+insertNL=this<+>txt"\n"
+indentChild=(replaceChildren
+(getChildren
+>>.
+indentTrees(insertIndentation2)False1
+)
+`whenNot`isDTD
+)
+
+-- ------------------------------------------------------------
+--
+-- copied from EditFilter and rewritten for arrows
+-- to remove dependency to the filter module
+
+indentTrees::(Int->LAXmlTreeXmlTree)->Bool->Int->XmlTrees->XmlTrees
+indentTrees___[]
+=[]
+indentTreesindentFilterpreserveSpacelevelts
+=runLAslsfls
+++
+indentRestrs
+where
+runLAsfl
+=runLA(constLl>>>f)undefined
+
+(ls,rs)
+=breakXN.isElemts
+
+isSignificant::Bool
+isSignificant
+=preserveSpace
+||
+(not.null.runLAsisSignificantPart)ls
+
+isSignificantPart::LAXmlTreeXmlTree
+isSignificantPart
+=catA
+[isText`guards`negisWhiteSpace
+,isCdata
+,isCharRef
+,isEntityRef
+]
+
+lsf::LAXmlTreeXmlTree
+lsf
+|isSignificant
+=this
+|otherwise
+=(none`when`isWhiteSpace)
+>>>
+(indentFilterlevel<+>this)
+
+indentRest::XmlTrees->XmlTrees
+indentRest[]
+|isSignificant
+=[]
+|otherwise
+=runLA(indentFilter(level-1))undefined
+
+indentRest(t':ts')
+=runLA((indentElem
+>>>
+lsf
+)
+`when`isElem
+)t'
+++
+(ifnullts'
+thenindentRest
+elseindentTreesindentFilterpreserveSpacelevel
+)ts'
+where
+indentElem
+=replaceChildren(getChildren
+>>.
+indentChildren
+)
+
+xmlSpaceAttrValue::String
+xmlSpaceAttrValue
+=concat.runLA(getAttrValue"xml:space")$t'
+
+preserveSpace'::Bool
+preserveSpace'
+=(fromMaybepreserveSpace
+.
+lookupxmlSpaceAttrValue
+)[("preserve",True)
+,("default",False)
+]
+
+indentChildren::XmlTrees->XmlTrees
+indentChildrencs'
+|all(maybeFalse(allisXmlSpaceChar).XN.getText)cs'
+=[]
+|otherwise
+=indentTreesindentFilterpreserveSpace'(level+1)cs'
+
+
+-- filter for indenting elements
+
+insertIndentation::Int->Int->LAaXmlTree
+insertIndentationindentWidthlevel
+=txt('\n':replicate(level*indentWidth)' ')
+
+-- filter for removing all whitespace
+
+insertNothing::Int->LAaXmlTree
+insertNothing_=none
+
+-- ------------------------------------------------------------
+
+transfCdata'::LAXmlTreeXmlTree
+transfCdata'=(getCdata>>>mkText)`when`isCdata
+
+-- |
+-- converts a CDATA section node into a normal text node
+
+transfCdata::ArrowXmla=>aXmlTreeXmlTree
+transfCdata=fromLA$
+transfCdata'
+
+-- |
+-- converts CDATA sections in whole document tree into normal text nodes
+
+transfAllCdata::ArrowXmla=>aXmlTreeXmlTree
+transfAllCdata=fromLA$
+processBottomUptransfCdata'
+
+--
+
+transfCharRef'::LAXmlTreeXmlTree
+transfCharRef'=(getCharRef>>>arr(\i->[toEnumi])>>>mkText)
+`when`
+isCharRef
+
+-- |
+-- converts character references to normal text
+
+transfCharRef::ArrowXmla=>aXmlTreeXmlTree
+transfCharRef=fromLA$
+transfCharRef'
+
+-- |
+-- recursively converts all character references to normal text
+
+transfAllCharRef::ArrowXmla=>aXmlTreeXmlTree
+transfAllCharRef=fromLA$
+processBottomUptransfCharRef'
+
+-- ------------------------------------------------------------
+
+hasXmlPi::ArrowXmla=>aXmlTreeXmlTree
+hasXmlPi
+=fromLA
+(getChildren
+>>>
+isPi
+>>>
+hasNamet_xml
+)
+
+-- | add an \<?xml version=\"1.0\"?\> processing instruction
+-- if it's not already there
+
+addXmlPi::ArrowXmla=>aXmlTreeXmlTree
+addXmlPi
+=fromLA
+(insertChildrenAt0((mkPi(mkSNsNamet_xml)none
+>>>
+addAttra_version"1.0"
+)
+<+>
+txt"\n"
+)
+`whenNot`
+hasXmlPi
+)
+
+-- | add an encoding spec to the \<?xml version=\"1.0\"?\> processing instruction
+
+addXmlPiEncoding::ArrowXmla=>String->aXmlTreeXmlTree
+addXmlPiEncodingenc
+=fromLA$
+processChildren(addAttra_encodingenc
+`when`
+(isPi>>>hasNamet_xml)
+)
+
+-- | add an XHTML strict doctype declaration to a document
+
+addXHtmlDoctypeStrict
+,addXHtmlDoctypeTransitional
+,addXHtmlDoctypeFrameset::ArrowXmla=>aXmlTreeXmlTree
+
+-- | add an XHTML strict doctype declaration to a document
+
+addXHtmlDoctypeStrict
+=addDoctypeDecl"html""-//W3C//DTD XHTML 1.0 Strict//EN""http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"
+
+-- | add an XHTML transitional doctype declaration to a document
+
+addXHtmlDoctypeTransitional
+=addDoctypeDecl"html""-//W3C//DTD XHTML 1.0 Transitional//EN""http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"
+
+-- | add an XHTML frameset doctype declaration to a document
+
+addXHtmlDoctypeFrameset
+=addDoctypeDecl"html""-//W3C//DTD XHTML 1.0 Frameset//EN""http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd"
+
+-- | add a doctype declaration to a document
+--
+-- The arguments are the root element name, the PUBLIC id and the SYSTEM id
+
+addDoctypeDecl::ArrowXmla=>String->String->String->aXmlTreeXmlTree
+addDoctypeDeclrootElempublicsystem
+=fromLA$
+replaceChildren
+(mkDTDDoctype[(a_name,rootElem)
+,(k_public,public)
+,(k_system,system)
+]none
+<+>
+txt"\n"
+<+>
+getChildren
+)
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.Arrow.Namespace
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id: Namespace.hs,v 1.13 2006/11/12 14:52:59 hxml Exp $
+
+ namespace specific arrows
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.Arrow.Namespace
+(attachNsEnv
+,cleanupNamespaces
+,collectNamespaceDecl
+,collectPrefixUriPairs
+,isNamespaceDeclAttr
+,getNamespaceDecl
+,processWithNsEnv
+,processWithNsEnvWithoutAttrl
+,propagateNamespaces
+,uniqueNamespaces
+,uniqueNamespacesFromDeclAndQNames
+,validateNamespaces
+)
+where
+
+importControl.Arrow-- arrow classes
+importControl.Arrow.ArrowList
+importControl.Arrow.ArrowIf
+importControl.Arrow.ArrowTree
+importControl.Arrow.ListArrow
+
+importText.XML.HXT.DOM.Interface
+importText.XML.HXT.Arrow.XmlArrow
+
+importData.Maybe
+(isNothing
+,fromJust
+)
+
+importData.List
+(nub)
+
+-- ------------------------------------------------------------
+
+-- | test whether an attribute node contains an XML Namespace declaration
+
+isNamespaceDeclAttr::ArrowXmla=>aXmlTreeXmlTree
+isNamespaceDeclAttr
+=fromLA$
+(getAttrName>>>isAisNsQName)`guards`this
+where
+isNsQNamen
+=px==a_xmlns
+&&
+(nulllp||(not.null.tail$lp))
+where
+(px,lp)=span(/=':').qualifiedName$n
+
+-- | get the namespace prefix and the namespace URI out of
+-- an attribute tree with a namespace declaration (see 'isNamespaceDeclAttr')
+-- for all other nodes this arrow fails
+
+getNamespaceDecl::ArrowXmla=>aXmlTree(String,String)
+getNamespaceDecl
+=fromLA$
+isNamespaceDeclAttr
+>>>
+((getAttrName
+>>>
+arrgetNsPrefix
+)
+&&&xshowgetChildren
+)
+where
+getNsPrefix=drop6.qualifiedName-- drop "xmlns:"
+
+-- ------------------------------------------------------------
+
+-- | collect all namespace declarations contained in a document
+--
+-- apply 'getNamespaceDecl' to a whole XmlTree
+
+collectNamespaceDecl::LAXmlTree(String,String)
+collectNamespaceDecl=multigetAttrl>>>getNamespaceDecl
+
+-- | collect all (namePrefix, namespaceUri) pairs from a tree
+--
+-- all qualified names are inspected, whether a namespace uri is defined,
+-- for these uris the prefix and uri is returned. This arrow is useful for
+-- namespace cleanup, e.g. for documents generated with XSLT. It can be used
+-- together with 'collectNamespaceDecl' to 'cleanupNamespaces'
+
+collectPrefixUriPairs::LAXmlTree(String,String)
+collectPrefixUriPairs
+=multi(isElem<+>getAttrl<+>isPi)
+>>>
+getQName
+>>>
+arrLgetPrefixUri
+where
+getPrefixUri::QName->[(String,String)]
+getPrefixUrin
+|nulluri=[]
+|px==a_xmlns
+||
+px==a_xml=[]-- these ones are reserved an predefined
+|otherwise=[(namePrefixn,uri)]
+where
+uri=namespaceUrin
+px=namePrefixn
+
+-- ------------------------------------------------------------
+
+-- | generate unique namespaces and add all namespace declarations to the root element
+--
+-- Calls 'cleanupNamespaces' with 'collectNamespaceDecl'
+
+uniqueNamespaces::ArrowXmla=>aXmlTreeXmlTree
+uniqueNamespaces
+=fromLA$
+cleanupNamespacescollectNamespaceDecl
+
+-- | generate unique namespaces and add all namespace declarations for all prefix-uri pairs in all qualified names
+--
+-- useful for cleanup of namespaces in generated documents.
+-- Calls 'cleanupNamespaces' with @ collectNamespaceDecl <+> collectPrefixUriPairs @
+
+uniqueNamespacesFromDeclAndQNames::ArrowXmla=>aXmlTreeXmlTree
+uniqueNamespacesFromDeclAndQNames
+=fromLA$
+cleanupNamespaces(collectNamespaceDecl<+>collectPrefixUriPairs)
+
+-- | does the real work for namespace cleanup.
+--
+-- The parameter is used for collecting namespace uris and prefixes from the input tree
+
+cleanupNamespaces::LAXmlTree(String,String)->LAXmlTreeXmlTree
+cleanupNamespacescollectNamespaces
+=renameNamespaces$<(listAcollectNamespaces>>^nub)
+where
+renameNamespaces::NsEnv->LAXmlTreeXmlTree
+renameNamespacesenv
+=processBottomUp
+(processAttrl
+((none`when`isNamespaceDeclAttr)-- remove all namespace declarations
+>>>
+changeQNamerenamePrefix-- update namespace prefix of attribute names, if namespace uri is set
+)
+>>>
+changeQNamerenamePrefix-- update namespace prefix of element names
+)
+>>>
+attachEnvenv1-- all all namespaces as attributes to the root node attribute list
+where
+renamePrefix::QName->QName
+renamePrefixn
+|nulluri=n
+|isNothingnewPx=n
+|otherwise=n{namePrefix=fromJustnewPx}
+where
+uri=namespaceUrin
+newPx=lookupurirevEnv1
+
+revEnv1=map(\(x,y)->(y,x))env1
+
+env1::NsEnv
+env1=newEnv[]uris
+
+uris::[String]
+uris=nub.mapsnd$env
+
+genPrefixes::[String]
+genPrefixes=map(("ns"++).show)[(0::Int)..]
+
+newEnv::NsEnv->[String]->NsEnv
+newEnvenv'[]
+=env'
+
+newEnvenv'(uri:rest)
+=newEnvenv''rest
+where
+env''=(prefix,uri):env'
+prefix
+=head(filternotAlreadyUsed$preferedPrefixes++genPrefixes)
+preferedPrefixes
+=mapfst.filter((==uri).snd)$env
+notAlreadyUseds
+=isNothing.lookups$env'
+
+-- ------------------------------------------------------------
+
+-- | auxiliary arrow for processing with a namespace environment
+--
+-- process a document tree with an arrow, containing always the
+-- valid namespace environment as extra parameter.
+-- The namespace environment is implemented as a 'Data.AssocList.AssocList'.
+-- Processing of attributes can be controlled by a boolean parameter
+
+processWithNsEnv1::ArrowXmla=>Bool->(NsEnv->aXmlTreeXmlTree)->NsEnv->aXmlTreeXmlTree
+processWithNsEnv1withAttrfenv
+=ifAisElem-- the test is just an optimization
+(processWithExtendedEnv$<arr(extendEnvenv))-- only element nodes contain namespace declarations
+(processWithExtendedEnvenv)
+where
+processWithExtendedEnvenv'
+=fenv'-- apply the env filter
+>>>
+((ifwithAttr
+thenprocessAttrl(fenv')-- apply the env to all attributes
+elsethis
+)
+>>>
+processChildren(processWithNsEnvfenv')-- apply the env recursively to all children
+)
+`when`isElem-- attrl and children only need processing for elem nodes
+
+extendEnv::NsEnv->XmlTree->NsEnv
+extendEnvenv't'
+=addEntriesnewDeclsenv'
+where
+newDecls=runLA(getAttrl>>>getNamespaceDecl)t'
+
+-- ------------------------------------------------------------
+
+-- | process a document tree with an arrow, containing always the
+-- valid namespace environment as extra parameter.
+--
+-- The namespace environment is implemented as a 'Data.AssocList.AssocList'
+
+processWithNsEnv::ArrowXmla=>(NsEnv->aXmlTreeXmlTree)->NsEnv->aXmlTreeXmlTree
+processWithNsEnv=processWithNsEnv1True
+
+-- | process all element nodes of a document tree with an arrow, containing always the
+-- valid namespace environment as extra parameter. Attribute lists are not processed.
+--
+-- See also: 'processWithNsEnv'
+
+processWithNsEnvWithoutAttrl::ArrowXmla=>(NsEnv->aXmlTreeXmlTree)->NsEnv->aXmlTreeXmlTree
+processWithNsEnvWithoutAttrl=processWithNsEnv1False
+
+-- -----------------------------------------------------------------------------
+
+-- | attach all valid namespace declarations to the attribute list of element nodes.
+--
+-- This arrow is useful for document processing, that requires access to all namespace
+-- declarations at any element node, but which cannot be done with a simple 'processWithNsEnv'.
+
+attachNsEnv::ArrowXmla=>NsEnv->aXmlTreeXmlTree
+attachNsEnvinitialEnv
+=fromLA$processWithNsEnvWithoutAttrlattachEnvinitialEnv
+where
+
+attachEnv::NsEnv->LAXmlTreeXmlTree
+attachEnvenv
+=(processAttrl(none`when`isNamespaceDeclAttr)
+>>>
+addAttrl(catAnsAttrl)
+)
+`when`isElem
+where
+nsAttrl::[LAXmlTreeXmlTree]
+nsAttrl=mapnsDeclToAttrenv
+
+nsDeclToAttr::(String,String)->LAXmlTreeXmlTree
+nsDeclToAttr(n,uri)
+=mkAttrqn(txturi)
+where
+qn::QName
+qn=mkNsName(a_xmlns++(ifnullnthen""else':':n))xmlnsNamespace
+
+-- -----------------------------------------------------------------------------
+
+-- |
+-- propagate all namespace declarations \"xmlns:ns=...\" to all element and attribute nodes of a document.
+--
+-- This arrow does not check for illegal use of namespaces.
+-- The real work is done by 'propagateNamespaceEnv'.
+--
+-- The arrow may be applied repeatedly if neccessary.
+
+propagateNamespaces::ArrowXmla=>aXmlTreeXmlTree
+propagateNamespaces=fromLA$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::NsEnv->LAXmlTreeXmlTree
+propagateNamespaceEnv
+=processWithNsEnvaddNamespaceUri
+where
+addNamespaceUri::NsEnv->LAXmlTreeXmlTree
+addNamespaceUrienv'
+=choiceA[isElem:->changeElemName(setNamespaceenv')
+,isAttr:->attachNamespaceUriToAttrenv'
+,isPi:->changePiName(setNamespaceenv')
+,this:->this
+]
+
+attachNamespaceUriToAttr::NsEnv->LAXmlTreeXmlTree
+attachNamespaceUriToAttrattrEnv
+=((getName>>>isAhasPrefixLocalPart)
+`guards`
+changeAttrName(setNamespaceattrEnv)
+)
+`orElse`
+(changeAttrName(constxmlnsQN)
+`when`
+hasNamea_xmlns
+)
+where
+hasPrefixLocalPart::String->Bool
+hasPrefixLocalParts
+=(':'`elem`s)-- small optimization: only do some string handling when is ':' found
+&&
+(let-- check none empty prefix and local part
+(px,lp)=span(/=':')s
+in
+not(nullpx)&¬(null(drop1lp))
+)
+
+-- -----------------------------------------------------------------------------
+
+-- |
+-- validate the namespace constraints in a whole tree.
+--
+-- Result is the list of errors concerning namespaces.
+-- Predicates 'isWellformedQName', 'isWellformedQualifiedName', 'isDeclaredNamespaces'
+-- and 'isWellformedNSDecl' are applied to the appropriate elements and attributes.
+
+validateNamespaces::ArrowXmla=>aXmlTreeXmlTree
+validateNamespaces=fromLAvalidateNamespaces1
+
+validateNamespaces1::LAXmlTreeXmlTree
+validateNamespaces1
+=choiceA[isRoot:->(getChildren>>>validateNamespaces1)-- root is correct by definition
+,this:->multivalidate1Namespaces
+]
+
+-- |
+-- a single node for namespace constrains.
+
+validate1Namespaces::LAXmlTreeXmlTree
+validate1Namespaces
+=choiceA
+[isElem:->catA[(getQName>>>isA(not.isWellformedQName)
+)
+`guards`nsError(\n->"element name "++shown++" is not a wellformed qualified name")
+
+,(getQName>>>isA(not.isDeclaredNamespace)
+)
+`guards`nsError(\n->"namespace for prefix in element name "++shown++" is undefined")
+
+,doubleOcc$<((getAttrl>>>getUniversalName)>>.doubles)
+
+,getAttrl>>>validate1Namespaces
+]
+
+,isAttr:->catA[(getQName>>>isA(not.isWellformedQName)
+)
+`guards`nsError(\n->"attribute name "++shown++" is not a wellformed qualified name")
+
+,(getQName>>>isA(not.isDeclaredNamespace)
+)
+`guards`nsError(\n->"namespace for prefix in attribute name "++shown++" is undefined")
+
+,(hasNamePrefixa_xmlns>>>xshowgetChildren>>>isAnull
+)
+`guards`nsError(\n->"namespace value of namespace declaration for "++shown++" has no value")
+
+,(getQName>>>isA(not.isWellformedNSDecl)
+)
+`guards`nsError(\n->"illegal namespace declaration for name "++n++" starting with reserved prefix "++show"xml")
+]
+
+,isDTD:->catA[isDTDDoctype<+>isDTDAttlist<+>isDTDElement<+>isDTDName
+>>>
+getDTDAttrValuea_name
+>>>
+(isA(not.isWellformedQualifiedName)
+`guards`
+nsErr(\n->"a DTD part contains a not wellformed qualified Name: "++shown)
+)
+
+,isDTDAttlist
+>>>
+getDTDAttrValuea_value
+>>>
+(isA(not.isWellformedQualifiedName)
+`guards`
+nsErr(\n->"an ATTLIST declaration contains as attribute name a not wellformed qualified Name: "++shown)
+)
+
+,isDTDEntity<+>isDTDPEntity<+>isDTDNotation
+>>>
+getDTDAttrValuea_name
+>>>
+(isA(not.isNCName)
+`guards`
+nsErr(\n->"an entity or notation declaration contains a not wellformed NCName: "++shown)
+)
+]
+,isPi:->catA[getName
+>>>
+(isA(not.isNCName)
+`guards`
+nsErr(\n->"a PI contains a not wellformed NCName: "++shown)
+)
+]
+]
+where
+nsError::(String->String)->LAXmlTreeXmlTree
+nsErrormsg
+=getName>>>nsErrmsg
+
+nsErr::(String->String)->LAStringXmlTree
+nsErrmsg=arrmsg>>>mkErrorc_err
+
+doubleOcc::String->LAXmlTreeXmlTree
+doubleOccan
+=nsError(\n->"multiple occurences of universal name for attributes of tag "++shown++" : "++showan)
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.Arrow.Pickle.Xml
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id$
+
+Pickler functions for converting between user defined data types
+and XmlTree data. Usefull for persistent storage and retreival
+of arbitray data as XML documents
+
+This module is an adaptation of the pickler combinators
+developed by Andrew Kennedy
+( http:\/\/research.microsoft.com\/~akenn\/fun\/picklercombinators.pdf )
+
+The difference to Kennedys approach is that the target is not
+a list of Chars but a list of XmlTrees. The basic picklers will
+convert data into XML text nodes. New are the picklers for
+creating elements and attributes.
+
+One extension was neccessary: The unpickling may fail.
+Therefore the unpickler has a Maybe result type.
+Failure is used to unpickle optional elements
+(Maybe data) and lists of arbitray length
+
+There is an example program demonstrating the use
+of the picklers for a none trivial data structure.
+(see \"examples\/arrows\/pickle\" directory)
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.Arrow.Pickle.Xml
+where
+
+importData.Maybe
+
+importText.XML.HXT.DOM.Interface
+importqualifiedText.XML.HXT.DOM.XmlNodeasXN
+
+importControl.Arrow.ListArrows
+importText.XML.HXT.Arrow.XmlArrow
+importText.XML.HXT.Arrow.Pickle.Schema
+
+-- ------------------------------------------------------------
+
+dataSt=St{attributes::[XmlTree]
+,contents::[XmlTree]
+}
+
+dataPUa=PU{appPickle::(a,St)->St
+,appUnPickle::St->(Maybea,St)
+,theSchema::Schema
+}
+
+emptySt::St
+emptySt=St{attributes=[]
+,contents=[]
+}
+
+addAtt::XmlTree->St->St
+addAttxs=s{attributes=x:attributess}
+
+addCont::XmlTree->St->St
+addContxs=s{contents=x:contentss}
+
+dropCont::St->St
+dropConts=s{contents=drop1(contentss)}
+
+getAtt::String->St->MaybeXmlTree
+getAttnames
+=listToMaybe$
+runLA(arrLattributes
+>>>
+isAttr>>>hasNamename
+)s
+
+getCont::St->MaybeXmlTree
+getConts=listToMaybe.contents$s
+
+-- ------------------------------------------------------------
+
+-- | conversion of an arbitrary value into an XML document tree.
+--
+-- The pickler, first parameter, controls the conversion process.
+-- Result is a complete document tree including a root node
+
+pickleDoc::PUa->a->XmlTree
+pickleDocpv
+=XN.mkRoot(attributesst)(contentsst)
+where
+st=appPicklep(v,emptySt)
+
+-- | Conversion of an XML document tree into an arbitrary data type
+--
+-- The inverse of 'pickleDoc'.
+-- This law should hold for all picklers: @ unpickle px . pickle px $ v == Just v @.
+-- Not every possible combination of picklers make sense.
+-- For reconverting a value from an XML tree, is becomes neccessary,
+-- to introduce \"enough\" markup for unpickling the value
+
+unpickleDoc::PUa->XmlTree->Maybea
+unpickleDocpt
+|XN.isRoott
+=fst.appUnPicklep$St{attributes=fromJust.XN.getAttrl$t
+,contents=XN.getChildrent
+}
+|otherwise
+=Nothing
+
+-- ------------------------------------------------------------
+
+-- | The zero pickler
+--
+-- Encodes nothing, fails always during unpickling
+
+xpZero::PUa
+xpZero=PU{appPickle=snd
+,appUnPickle=\s->(Nothing,s)
+,theSchema=scNull
+}
+
+-- unit pickler
+
+xpUnit::PU()
+xpUnit=xpLift()
+
+-- | Lift a value to a pickler
+--
+-- When pickling, nothing is encoded, when unpickling, the given value is inserted.
+-- This pickler always succeeds.
+
+xpLift::a->PUa
+xpLiftx=PU{appPickle=snd
+,appUnPickle=\s->(Justx,s)
+,theSchema=scEmpty
+}
+
+-- | Lift a Maybe value to a pickler.
+--
+-- @Nothing@ is mapped to the zero pickler, @Just x@ is pickled with @xpLift x@.
+
+xpLiftMaybe::Maybea->PUa
+xpLiftMaybev=(xpLiftMaybe'v){theSchema=scOptionscEmpty}
+where
+xpLiftMaybe'Nothing=xpZero
+xpLiftMaybe'(Justx)=xpLiftx
+
+
+-- | pickle\/unpickle combinator for sequence and choice.
+--
+-- When the first unpickler fails,
+-- the second one is taken, else the third one configured with the result from the first
+-- is taken. This pickler is a generalisation for 'xpSeq' and 'xpChoice' .
+--
+-- The schema must be attached later, e.g. in xpPair or other higher level combinators
+
+xpCondSeq::PUb->(b->a)->PUa->(a->PUb)->PUb
+xpCondSeqpdfpak
+=PU{appPickle=(\(b,s)->
+let
+a=fb
+pb=ka
+in
+appPicklepa(a,(appPicklepb(b,s)))
+)
+,appUnPickle=(\s->
+let
+(a,s')=appUnPicklepas
+in
+caseaof
+Nothing->appUnPicklepds
+Justa'->appUnPickle(ka')s'
+)
+,theSchema=undefined
+}
+
+
+-- | Combine two picklers sequentially.
+--
+-- If the first fails during
+-- unpickling, the whole unpickler fails
+
+xpSeq::(b->a)->PUa->(a->PUb)->PUb
+xpSeq=xpCondSeqxpZero
+
+
+-- | combine tow picklers with a choice
+--
+-- Run two picklers in sequence like with xpSeq.
+-- When during unpickling the first one fails,
+-- an alternative pickler (first argument) is applied.
+-- This pickler only is used as combinator for unpickling.
+
+xpChoice::PUb->PUa->(a->PUb)->PUb
+xpChoicepb=xpCondSeqpbundefined
+
+
+-- | map value into another domain and apply pickler there
+--
+-- One of the most often used picklers.
+
+xpWrap::(a->b,b->a)->PUa->PUb
+xpWrap(i,j)pa=(xpSeqjpa(xpLift.i)){theSchema=theSchemapa}
+
+-- | like 'xpWrap', but if the inverse mapping is undefined, the unpickler fails
+--
+-- Map a value into another domain. If the inverse mapping is
+-- undefined (Nothing), the unpickler fails
+
+xpWrapMaybe::(a->Maybeb,b->a)->PUa->PUb
+xpWrapMaybe(i,j)pa=(xpSeqjpa(xpLiftMaybe.i)){theSchema=theSchemapa}
+
+-- | pickle a pair of values sequentially
+--
+-- Used for pairs or together with wrap for pickling
+-- algebraic data types with two components
+
+xpPair::PUa->PUb->PU(a,b)
+xpPairpapb
+=(xpSeqfstpa(\a->
+xpSeqsndpb(\b->
+xpLift(a,b)))
+){theSchema=scSeq(theSchemapa)(theSchemapb)}
+
+-- | Like 'xpPair' but for triples
+
+xpTriple::PUa->PUb->PUc->PU(a,b,c)
+xpTriplepapbpc
+=xpWrap(toTriple,fromTriple)(xpPairpa(xpPairpbpc))
+where
+toTriple~(a,~(b,c))=(a,b,c)
+fromTriple~(a,b,c)=(a,(b,c))
+
+-- | Like 'xpPair' and 'xpTriple' but for 4-tuples
+
+xp4Tuple::PUa->PUb->PUc->PUd->PU(a,b,c,d)
+xp4Tuplepapbpcpd
+=xpWrap(toQuad,fromQuad)(xpPairpa(xpPairpb(xpPairpcpd)))
+where
+toQuad~(a,~(b,~(c,d)))=(a,b,c,d)
+fromQuad~(a,b,c,d)=(a,(b,(c,d)))
+
+-- | Like 'xpPair' and 'xpTriple' but for 5-tuples
+
+xp5Tuple::PUa->PUb->PUc->PUd->PUe->PU(a,b,c,d,e)
+xp5Tuplepapbpcpdpe
+=xpWrap(toQuint,fromQuint)(xpPairpa(xpPairpb(xpPairpc(xpPairpdpe))))
+where
+toQuint~(a,~(b,~(c,~(d,e))))=(a,b,c,d,e)
+fromQuint~(a,b,c,d,e)=(a,(b,(c,(d,e))))
+
+-- | Like 'xpPair' and 'xpTriple' but for 6-tuples
+
+xp6Tuple::PUa->PUb->PUc->PUd->PUe->PUf->PU(a,b,c,d,e,f)
+xp6Tuplepapbpcpdpepf
+=xpWrap(toSix,fromSix)(xpPairpa(xpPairpb(xpPairpc(xpPairpd(xpPairpepf)))))
+where
+toSix~(a,~(b,~(c,~(d,~(e,f)))))=(a,b,c,d,e,f)
+fromSix~(a,b,c,d,e,f)=(a,(b,(c,(d,(e,f)))))
+
+-- | Pickle a string into an XML text node
+--
+-- One of the most often used primitive picklers. Attention:
+-- For pickling empty strings use 'xpText0'. If the text has a more
+-- specific datatype than xsd:string, use 'xpTextDT'
+
+xpText::PUString
+xpText=xpTextDTscString1
+
+-- | Pickle a string into an XML text node
+--
+-- Text pickler with a description of the structure of the text
+-- by a schema. A schema for a data type can be defined by 'Text.XML.HXT.Arrow.Pickle.Schema.scDT'.
+-- In 'Text.XML.HXT.Arrow.Pickle.Schema' there are some more functions for creating
+-- simple datatype descriptions.
+
+xpTextDT::Schema->PUString
+xpTextDTsc
+=PU{appPickle=\(s,st)->addCont(XN.mkTexts)st
+,appUnPickle=\st->fromMaybe(Nothing,st)(unpickleStringst)
+,theSchema=sc
+}
+where
+unpickleStringst
+=do
+t<-getContst
+s<-XN.getTextt
+return(Justs,dropContst)
+
+-- | Pickle a possibly empty string into an XML node.
+--
+-- Must be used in all places, where empty strings are legal values.
+-- If the content of an element can be an empty string, this string disapears
+-- during storing the DOM into a document and reparse the document.
+-- So the empty text node becomes nothing, and the pickler must deliver an empty string,
+-- if there is no text node in the document.
+
+xpText0::PUString
+xpText0=xpText0DTscString1
+
+-- | Pickle a possibly empty string with a datatype description into an XML node.
+--
+-- Like 'xpText0' but with extra Parameter for datatype description as in 'xpTextDT'.
+
+xpText0DT::Schema->PUString
+xpText0DTsc
+=xpWrap(fromMaybe"",emptyToNothing)$xpOption$xpTextDTsc
+where
+emptyToNothing""=Nothing
+emptyToNothingx=Justx
+
+-- | Pickle an arbitrary value by applyling show during pickling
+-- and read during unpickling.
+--
+-- Real pickling is then done with 'xpText'.
+-- One of the most often used pimitive picklers. Applicable for all
+-- types which are instances of @Read@ and @Show@
+
+xpPrim::(Reada,Showa)=>PUa
+xpPrim
+=xpWrapMaybe(readMaybe,show)xpText
+where
+readMaybe::Reada=>String->Maybea
+readMaybestr
+=val(readsstr)
+where
+val[(x,"")]=Justx
+val_=Nothing
+
+-- | Pickle an XmlTree by just adding it
+--
+-- Usefull for components of type XmlTree in other data structures
+
+xpTree::PUXmlTree
+xpTree=PU{appPickle=\(s,st)->addContsst
+,appUnPickle=\st->fromMaybe(Nothing,st)(unpickleTreest)
+,theSchema=Any
+}
+where
+unpickleTreest
+=do
+t<-getContst
+return(Justt,dropContst)
+
+-- | Encoding of optional data by ignoring the Nothing case during pickling
+-- and relying on failure during unpickling to recompute the Nothing case
+--
+-- The default pickler for Maybe types
+
+xpOption::PUa->PU(Maybea)
+xpOptionpa
+=PU{appPickle=(\(a,st)->
+caseaof
+Nothing->st
+Justx->appPicklepa(x,st)
+)
+
+,appUnPickle=appUnPickle$
+xpChoice(xpLiftNothing)pa(xpLift.Just)
+
+,theSchema=scOption(theSchemapa)
+}
+
+-- | Encoding of list values by pickling all list elements sequentially.
+--
+-- Unpickler relies on failure for detecting the end of the list.
+-- The standard pickler for lists. Can also be used in combination with 'xpWrap'
+-- for constructing set and map picklers
+
+xpList::PUa->PU[a]
+xpListpa
+=PU{appPickle=(\(a,st)->
+caseaof
+[]->st
+_:_->appPicklepc(a,st)
+)
+,appUnPickle=appUnPickle$
+xpChoice(xpLift[])pa
+(\x->xpSeqid(xpListpa)(\xs->xpLift(x:xs)))
+
+,theSchema=scList(theSchemapa)
+}
+where
+pc=xpSeqheadpa(\x->
+xpSeqtail(xpListpa)(\xs->
+xpLift(x:xs)))
+
+-- | Encoding of a none empty list of values
+--
+-- Attention: when calling this pickler with an empty list,
+-- an internal error \"head of empty list is raised\".
+
+xpList1::PUa->PU[a]
+xpList1pa
+=(xpWrap(\(x,xs)->x:xs
+,\(x:xs)->(x,xs)
+)$
+xpPairpa(xpListpa)
+){theSchema=scList1(theSchemapa)}
+
+-- | Pickler for sum data types.
+--
+-- Every constructor is mapped to an index into the list of picklers.
+-- The index is used only during pickling, not during unpickling, there the 1. match is taken
+
+xpAlt::(a->Int)->[PUa]->PUa
+xpAlttagps
+=PU{appPickle=(\(a,st)->
+let
+pa=ps!!(taga)
+in
+appPicklepa(a,st)
+)
+,appUnPickle=appUnPickle$
+(casepsof
+[]->xpZero
+pa:ps1->xpChoice(xpAlttagps1)paxpLift
+)
+,theSchema=scAlts(maptheSchemaps)
+}
+
+-- | Pickler for wrapping\/unwrapping data into an XML element
+--
+-- Extra parameter is the element name. THE pickler for constructing
+-- nested structures
+
+xpElem::String->PUa->PUa
+xpElemnamepa
+=PU{appPickle=(\(a,st)->
+let
+st'=appPicklepa(a,emptySt)
+in
+addCont(XN.mkElement(mkNamename)(attributesst')(contentsst'))st
+)
+,appUnPickle=\st->fromMaybe(Nothing,st)(unpickleElementst)
+,theSchema=scElemname(theSchemapa)
+}
+where
+unpickleElementst
+=do
+t<-getContst
+n<-XN.getElemNamet
+ifqualifiedNamen/=name
+thenfail"element name does not match"
+elsedo
+letcs=XN.getChildrent
+al<-XN.getAttrlt
+res<-fst.appUnPicklepa$St{attributes=al,contents=cs}
+return(Justres,dropContst)
+
+-- | Pickler for storing\/retreiving data into\/from an attribute value
+--
+-- The attribute is inserted in the surrounding element constructed by the 'xpElem' pickler
+
+xpAttr::String->PUa->PUa
+xpAttrnamepa
+=PU{appPickle=(\(a,st)->
+let
+st'=appPicklepa(a,emptySt)
+in
+addAtt(XN.mkAttr(mkNamename)(contentsst'))st
+)
+,appUnPickle=\st->fromMaybe(Nothing,st)(unpickleAttrst)
+,theSchema=scAttrname(theSchemapa)
+}
+where
+unpickleAttrst
+=do
+a<-getAttnamest
+letav=XN.getChildrena
+res<-fst.appUnPicklepa$St{attributes=[],contents=av}
+return(Justres,st)-- attribute is not removed from attribute list,
+-- attributes are selected by name
+
+-- | Add an optional attribute for an optional value (Maybe a).
+
+xpAttrImplied::String->PUa->PU(Maybea)
+xpAttrImpliednamepa
+=xpOption$xpAttrnamepa
+
+xpAttrFixed::String->String->PU()
+xpAttrFixednameval
+=(xpWrapMaybe(\v->ifv==valthenJust()elseNothing
+,constval
+)$
+xpAttrnamexpText
+){theSchema=scAttrname(scFixedval)}
+
+-- | Add an attribute with a fixed value.
+--
+-- Useful e.g. to declare namespaces. Is implemented by 'xpAttrFixed'
+
+xpAddFixedAttr::String->String->PUa->PUa
+xpAddFixedAttrnamevalpa
+=xpWrap(snd
+,(,)()
+)$
+xpPair(xpAttrFixednameval)pa
+
+-- ------------------------------------------------------------
+
+-- | The class for overloading 'xpickle', the default pickler
+
+classXmlPicklerawhere
+xpickle::PUa
+
+instanceXmlPicklerIntwhere
+xpickle=xpPrim
+
+instanceXmlPicklerIntegerwhere
+xpickle=xpPrim
+
+{-
+ no instance of XmlPickler Char
+ because then every text would be encoded
+ char by char, because of the instance for lists
+
+instance XmlPickler Char where
+ xpickle = xpPrim
+-}
+
+instanceXmlPickler()where
+xpickle=xpUnit
+
+instance(XmlPicklera,XmlPicklerb)=>XmlPickler(a,b)where
+xpickle=xpPairxpicklexpickle
+
+instance(XmlPicklera,XmlPicklerb,XmlPicklerc)=>XmlPickler(a,b,c)where
+xpickle=xpTriplexpicklexpicklexpickle
+
+instance(XmlPicklera,XmlPicklerb,XmlPicklerc,XmlPicklerd)=>XmlPickler(a,b,c,d)where
+xpickle=xp4Tuplexpicklexpicklexpicklexpickle
+
+instance(XmlPicklera,XmlPicklerb,XmlPicklerc,XmlPicklerd,XmlPicklere)=>XmlPickler(a,b,c,d,e)where
+xpickle=xp5Tuplexpicklexpicklexpicklexpicklexpickle
+
+instanceXmlPicklera=>XmlPickler[a]where
+xpickle=xpListxpickle
+
+instanceXmlPicklera=>XmlPickler(Maybea)where
+xpickle=xpOptionxpickle
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.Arrow.Pickle
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id$
+
+Pickler functions for converting between user defined data types
+and XmlTree data. Usefull for persistent storage and retreival
+of arbitray data as XML documents
+
+This module is an adaptation of the pickler combinators
+developed by Andrew Kennedy
+( http:\/\/research.microsoft.com\/~akenn\/fun\/picklercombinators.pdf )
+
+The difference to Kennedys approach is that the target is not
+a list of Chars but a list of XmlTrees. The basic picklers will
+convert data into XML text nodes. New are the picklers for
+creating elements and attributes.
+
+One extension was neccessary: The unpickling may fail.
+Therefore the unpickler has a Maybe result type.
+Failure is used to unpickle optional elements
+(Maybe data) and lists of arbitray length
+
+There is an example program demonstrating the use
+of the picklers for a none trivial data structure.
+(see \"examples\/arrows\/pickle\" directory)
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.Arrow.Pickle
+(xpickleDocument-- from this module Text.XML.HXT.Arrow.Pickle
+,xunpickleDocument
+,xpickleWriteDTD
+,xpickleDTD
+,checkPickler
+,xpickleVal
+,xunpickleVal
+,thePicklerDTD
+,a_addDTD
+
+-- from Text.XML.HXT.Arrow.Pickle.Xml
+,pickleDoc
+,unpickleDoc
+
+,PU(..)
+,XmlPickler
+
+,xp4Tuple
+,xp5Tuple
+,xpAddFixedAttr
+,xpAlt
+,xpAttr
+,xpAttrFixed
+,xpAttrImplied
+,xpChoice
+,xpCondSeq
+,xpElem
+,xpickle
+,xpLift
+,xpLiftMaybe
+,xpList
+,xpList1
+,xpOption
+,xpPair
+,xpPrim
+,xpSeq
+,xpText
+,xpText0
+,xpTextDT
+,xpText0DT
+,xpTree
+,xpTriple
+,xpUnit
+,xpWrap
+,xpWrapMaybe
+,xpZero
+
+-- from Text.XML.HXT.Arrow.Pickle.Schema
+,Schema
+,Schemas
+,DataTypeDescr
+)
+where
+
+importData.Maybe
+
+importControl.Arrow.ListArrows
+
+importText.XML.HXT.DOM.Interface
+importText.XML.HXT.Arrow.XmlArrow
+importText.XML.HXT.Arrow.XmlIOStateArrow
+importText.XML.HXT.Arrow.ReadDocument
+importText.XML.HXT.Arrow.WriteDocument
+
+importText.XML.HXT.Arrow.Pickle.Xml
+importText.XML.HXT.Arrow.Pickle.Schema
+importText.XML.HXT.Arrow.Pickle.DTD
+
+-- ------------------------------------------------------------
+
+-- the arrow interface for pickling and unpickling
+
+-- | store an arbitray value in a persistent XML document
+--
+-- The pickler converts a value into an XML tree, this is written out with
+-- 'Text.XML.HXT.Arrow.writeDocument'. The option list is passed to 'Text.XML.HXT.Arrow.writeDocument'
+--
+-- An option evaluated by this arrow is 'a_addDTD'.
+-- If 'a_addDTD' is set ('v_1'), the pickler DTD is added as an inline DTD into the document.
+
+xpickleDocument::PUa->Attributes->String->IOStateArrowsaXmlTree
+xpickleDocumentxpaldest
+=xpickleValxp
+>>>
+traceMsg1"xpickleVal applied"
+>>>
+(iflookup1a_addDTDal==v_1
+thenreplaceChildren((constAundefined>>>xpickleDTDxp>>>getChildren)
+<+>
+getChildren
+)
+elsethis
+)
+>>>
+writeDocumentaldest
+
+-- | Option for generating and adding DTD when document is pickled
+
+a_addDTD::String
+a_addDTD="addDTD"
+
+-- | read an arbitray value from an XML document
+--
+-- The document is read with 'Text.XML.HXT.Arrow.readDocument'. Options are passed
+-- to 'Text.XML.HXT.Arrow.readDocument'. The conversion from XmlTree is done with the
+-- pickler.
+--
+-- @ xpickleDocument xp al dest >>> xunpickleDocument xp al' dest @ is the identity arrow
+-- when applied with the appropriate options. When during pickling indentation is switched on,
+-- the whitespace must be removed during unpickling.
+
+xunpickleDocument::PUa->Attributes->String->IOStateArrowsba
+xunpickleDocumentxpalsrc
+=readDocumentalsrc
+>>>
+traceMsg1("xunpickleVal for "++showsrc++" started")
+>>>
+xunpickleValxp
+>>>
+traceMsg1("xunpickleVal for "++showsrc++" finished")
+
+-- | Write out the DTD generated out of a pickler. Calls 'xpicklerDTD'
+
+xpickleWriteDTD::PUb->Attributes->String->IOStateArrowsbXmlTree
+xpickleWriteDTDxpaldest
+=xpickleDTDxp
+>>>
+writeDocumentaldest
+
+-- | The arrow for generating the DTD out of a pickler
+--
+-- A DTD is generated from a pickler and check for consistency.
+-- Errors concerning the DTD are issued.
+
+xpickleDTD::PUb->IOStateArrowsbXmlTree
+xpickleDTDxp=root[][constL(thePicklerDTDxp)
+>>>
+filterErrorMsg
+]
+
+-- | An arrow for checking picklers
+--
+-- A value is transformed into an XML document by a given pickler,
+-- the associated DTD is extracted from the pickler and checked,
+-- the document including the DTD is tranlated into a string,
+-- this string is read and validated against the included DTD,
+-- and unpickled.
+-- The last step is the equality with the input.
+--
+-- If the check succeeds, the arrow works like this, else it fails.
+
+checkPickler::Eqa=>PUa->IOStateArrowsaa
+checkPicklerxp=((((xpickleValxp
+>>>
+replaceChildren((constAundefined>>>xpickleDTDxp>>>getChildren)
+<+>
+getChildren
+)
+>>>
+writeDocumentToString[]
+>>>
+readFromString[(a_validate,v_1)]
+>>>
+(xunpickleValxp
+`orElse`
+(issueErr"unpickling the document failed"
+>>>
+none
+)
+)
+)
+&&&
+this
+)
+>>>isA(uncurry(==))
+)
+`guards`this
+)
+`orElse`issueErr"pickle/unpickle combinators failed"
+
+-- | The arrow version of the pickler function
+
+xpickleVal::ArrowXmla=>PUb->abXmlTree
+xpickleValxp=arr(pickleDocxp)
+
+-- | The arrow version of the unpickler function
+
+xunpickleVal::ArrowXmla=>PUb->aXmlTreeb
+xunpickleValxp=arrL(maybeToList.unpickleDocxp)
+
+
+-- | Compute the associated DTD of a pickler
+
+thePicklerDTD::PUb->XmlTrees
+thePicklerDTD=dtdDescrToXml.dtdDescr.theSchema
+
+-- ------------------------------------------------------------
+
+
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.Arrow.ProcessDocument
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id: ProcessDocument.hs,v 1.3 2006/08/30 16:20:52 hxml Exp $
+
+Compound arrows for reading, parsing, validating and writing XML documents
+
+All arrows use IO and a global state for options, errorhandling, ...
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.Arrow.ProcessDocument
+(parseXmlDocument
+,parseHtmlDocument
+,validateDocument
+,propagateAndValidateNamespaces
+,getDocumentContents
+)
+where
+
+importControl.Arrow-- arrow classes
+importControl.Arrow.ArrowList
+importControl.Arrow.ArrowIf
+importControl.Arrow.ArrowTree
+
+importText.XML.HXT.DOM.Interface
+importText.XML.HXT.Arrow.XmlArrow
+importText.XML.HXT.Arrow.XmlIOStateArrow
+
+importText.XML.HXT.Arrow.ParserInterface
+(parseXmlDoc
+,parseHtmlDoc
+,parseHtmlTagSoup
+,substHtmlEntityRefs
+,validateDoc
+,transformDoc
+)
+
+importText.XML.HXT.Arrow.Edit
+(transfAllCharRef
+)
+
+importText.XML.HXT.Arrow.GeneralEntitySubstitution
+(processGeneralEntities
+)
+
+importText.XML.HXT.Arrow.DTDProcessing
+(processDTD
+)
+
+importText.XML.HXT.Arrow.DocumentInput
+(getXmlContents
+)
+
+importText.XML.HXT.Arrow.Namespace
+(propagateNamespaces
+,validateNamespaces
+)
+
+-- ------------------------------------------------------------
+
+{- |
+XML parser
+
+Input tree must be a root tree with a text tree as child containing the document to be parsed.
+The parser generates from the input string a tree of a wellformed XML document,
+processes the DTD (parameter substitution, conditional DTD parts, ...) and
+substitutes all general entity references. Next step is character reference substitution.
+Last step is the document validation.
+Validation can be controlled by an extra parameter.
+
+Example:
+
+> parseXmlDocument True -- parse and validate document
+>
+> parseXmlDocument False -- only parse document, don't validate
+
+This parser is useful for applications processing correct XML documents.
+-}
+
+parseXmlDocument::Bool->IOStateArrowsXmlTreeXmlTree
+parseXmlDocumentvalidate
+=(replaceChildren((getAttrValuea_source
+&&&
+xshowgetChildren
+)
+>>>
+parseXmlDoc
+>>>
+filterErrorMsg
+)
+>>>
+setDocumentStatusFromSystemState"parse XML document"
+>>>
+processDTD
+>>>
+processGeneralEntities
+>>>
+transfAllCharRef
+>>>
+(ifvalidate
+thenvalidateDocument
+elsethis
+)
+)
+`when`documentStatusOk
+
+-- ------------------------------------------------------------
+
+{- |
+HTML parser
+
+Input tree must be a root tree with a text tree as child containing the document to be parsed.
+The parser tries to parse everything as HTML, if the HTML document is not wellformed XML or if
+errors occur, warnings are generated. The warnings can be issued, or suppressed.
+
+Example: @ parseHtmlDocument True @ : parse document and issue warnings
+
+This parser is useful for applications like web crawlers, where the pages may contain
+arbitray errors, but the application is only interested in parts of the document, e.g. the plain text.
+
+-}
+
+parseHtmlDocument::Bool->Bool->Bool->Bool->Bool->Bool->IOStateArrowsXmlTreeXmlTree
+parseHtmlDocumentwithTagSoupwithNamespaceswarningspreserveCmtremoveWhitespaceasHtml
+=(perform(getAttrValuea_source>>>traceString1(("parseHtmlDoc: parse HTML document "++).show))
+>>>
+replaceChildren((getAttrValuea_source-- get source name
+&&&
+xshowgetChildren
+)-- get string to be parsed
+>>>
+parseHtml
+)
+>>>
+removeWarnings
+>>>
+setDocumentStatusFromSystemState"parse HTML document"
+>>>
+traceTree
+>>>
+traceSource
+>>>
+perform(getAttrValuea_source
+>>>
+traceString1(\src->"parse HTML document "++showsrc++" finished")
+)
+)
+`when`documentStatusOk
+where
+parseHtml
+|withTagSoup=traceMsg1("parse document with tagsoup "++
+(ifasHtmlthen"HT"else"X")++"ML parser"
+)
+>>>
+parseHtmlTagSoupwithNamespaceswarningspreserveCmtremoveWhitespaceasHtml
+
+|otherwise=traceMsg1("parse document with parsec HTML parser")
+>>>
+parseHtmlDoc-- run parser
+>>>
+substHtmlEntityRefs-- substitute entity refs
+removeWarnings
+|withTagSoup
+&&
+notwarnings=this
+|otherwise=processTopDownWithAttrl
+(ifwarnings-- remove warnings inserted by parser and entity subst
+thenfilterErrorMsg
+else(none
+`when`
+isError
+)
+)
+
+-- ------------------------------------------------------------
+
+{- | Document validation
+
+Input must be a complete document tree. The document
+is validated with respect to the DTD spec.
+Only useful for XML documents containing a DTD.
+
+If the document is valid, it is transformed with respect to the DTD,
+normalization of attribute values, adding default values, sorting attributes by name,...
+
+If no error was found, result is the normalized tree,
+else the error status is set in the list of attributes
+of the root node \"\/\" and the document content is removed from the tree.
+
+-}
+
+validateDocument::IOStateArrowsXmlTreeXmlTree
+validateDocument
+=(traceMsg1"validating document"
+>>>
+perform(validateDoc
+>>>
+filterErrorMsg
+)
+>>>
+setDocumentStatusFromSystemState"document validation"
+>>>
+transformDoc
+>>>
+traceMsg1"document validated"
+>>>
+traceSource
+>>>
+traceTree
+)
+`when`
+documentStatusOk
+
+-- ------------------------------------------------------------
+
+{- | Namespace propagation
+
+Input must be a complete document tree. The namespace declarations
+are evaluated and all element and attribute names are processed by
+splitting the name into prefix, local part and namespace URI.
+
+Naames are checked with respect to the XML namespace definition
+
+If no error was found, result is the unchanged input tree,
+else the error status is set in the list of attributes
+of the root node \"\/\" and the document content is removed from the tree.
+
+
+-}
+
+propagateAndValidateNamespaces::IOStateArrowsXmlTreeXmlTree
+propagateAndValidateNamespaces
+=(traceMsg1"propagating namespaces"
+>>>
+propagateNamespaces
+>>>
+traceTree
+>>>
+traceSource
+>>>
+traceMsg1"validating namespaces"
+>>>
+(setDocumentStatusFromSystemState"namespace propagation"
+`when`
+(validateNamespaces>>>performfilterErrorMsg)
+)
+>>>
+traceMsg1"namespace validation finished"
+)
+`when`
+documentStatusOk
+
+-- ------------------------------------------------------------
+
+{- |
+ creates a new document root, adds all options
+ as attributes to the document root and calls 'getXmlContents'.
+
+ If the document name is the empty string, the document will be read
+ from standard input.
+
+ For supported protocols see 'Text.XML.HXT.Arrow.DocumentInput.getXmlContents'
+-}
+
+getDocumentContents::Attributes->String->IOStateArrowsbXmlTree
+getDocumentContentsoptionssrc
+=root[][]
+>>>
+addAttra_sourcesrc
+>>>
+seqA(map(uncurryaddAttr)options)-- add all options to doc root
+>>>-- e.g. getXmlContents needs some of these
+traceMsg1("readDocument: start processing document "++showsrc)
+>>>
+getXmlContents
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.Arrow.ReadDocument
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id: ReadDocument.hs,v 1.10 2006/11/24 07:41:37 hxml Exp $
+
+Compound arrows for reading an XML\/HTML document or an XML\/HTML string
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.Arrow.ReadDocument
+(readDocument
+,readFromDocument
+,readString
+,readFromString
+,hread
+,xread
+)
+where
+
+importControl.Arrow.ListArrows
+
+importText.XML.HXT.DOM.Interface
+importText.XML.HXT.Arrow.XmlArrow
+importText.XML.HXT.Arrow.XmlIOStateArrow
+
+importText.XML.HXT.Arrow.Edit
+(canonicalizeAllNodes
+,canonicalizeForXPath
+,canonicalizeContents
+,removeDocWhiteSpace
+)
+
+importText.XML.HXT.Arrow.ParserInterface
+
+importText.XML.HXT.Arrow.ProcessDocument
+(getDocumentContents
+,parseXmlDocument
+,parseHtmlDocument
+,propagateAndValidateNamespaces
+)
+
+importText.XML.HXT.RelaxNG.Validator
+(validateDocumentWithRelaxSchema
+)
+
+importData.Char
+(toLower
+)
+
+-- ------------------------------------------------------------
+
+{- |
+the main document input filter
+
+this filter can be configured by an option list, a value of type "Attributes"
+
+available options:
+
+* 'a_parse_html': use HTML parser, else use XML parser (default)
+
+- 'a_tagsoup' : use light weight and lasy parser based on tagsoup lib
+
+- 'a_parse_by_mimetype' : select the parser by the mime type of the document
+ (pulled out of the HTTP header). When the mime type is set to \"text\/html\"
+ the HTML parser (parsec or tagsoup) is taken, when it\'s set to
+ \"text\/xml\" or \"text\/xhtml\" the XML parser (parsec or tagsoup) is taken.
+ If the mime type is something else no further processing is performed,
+ the contents is given back to the application in form of a single text node.
+ If the default document encoding ('a_encoding') is set to isoLatin1, this even enables processing
+ of arbitray binary data.
+
+- 'a_validate' : validate document againsd DTD (default), else skip validation
+
+- 'a_relax_schema' : validate document with Relax NG, the options value is the schema URI
+ this implies using XML parser, no validation against DTD, and canonicalisation
+
+- '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 (default)
+
+- '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_encoding' : default document encoding ('utf8', 'isoLatin1', 'usAscii', 'iso8859_2', ... , 'iso8859_16', ...)
+
+All attributes not evaluated by readDocument are stored in the created document root node for easy access of the various
+options in e.g. the input\/output modules
+
+If the document name is the empty string or an uri of the form \"stdin:\", the document is read from standard input.
+
+examples:
+
+> readDocument [ ] "test.xml"
+
+reads and validates a document \"test.xml\", no namespace propagation, only canonicalization is performed
+
+> readDocument [ (a_validate, "0")
+> , (a_encoding, isoLatin1)
+> ] "test.xml"
+
+reads document \"test.xml\" without validation, default encoding 'isoLatin1'.
+
+
+> readDocument [ (a_parse_html, "1")
+> , (a_encoding, isoLatin1)
+> , (a_tagsoup, "1")
+> ] ""
+
+reads a HTML document from standard input, no validation is done when parsing HTML, default encoding is 'isoLatin1',
+parsing is done with tagsoup parser
+
+> readDocument [ (a_parse_html, "1")
+> , (a_proxy, "www-cache:3128")
+> , (a_curl, "1")
+> , (a_issue_warnings, "0")
+> ] "http://www.haskell.org/"
+
+reads Haskell homepage with HTML parser ignoring any warnings, with http access via external program curl and proxy \"www-cache\" at port 3128
+
+> readDocument [ (a_validate, "1")
+> , (a_check_namespace, "1")
+> , (a_remove_whitespace, "1")
+> , (a_trace, "2")
+> ] "http://www.w3c.org/"
+
+read w3c home page (xhtml), validate and check namespaces, remove whitespace between tags, trace activities with level 2
+
+for minimal complete examples see 'Text.XML.HXT.Arrow.WriteDocument.writeDocument' and 'runX', the main starting point for running an XML arrow.
+-}
+
+readDocument::Attributes->String->IOStateArrowsbXmlTree
+readDocumentuserOptionssrc
+=traceLevel
+>>>
+addInputOptionsToSystemState
+>>>
+getDocumentContentsremainingOptionssrc
+>>>
+(processDoc$<getMimeType)
+>>>
+traceMsg1("readDocument: "++showsrc++" processed")
+>>>
+traceSource
+>>>
+traceTree
+where
+options
+=addEntriesuserOptionsdefaultOptions
+
+defaultOptions
+=[(a_parse_html,v_0)
+,(a_tagsoup,v_0)
+,(a_validate,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)
+,(a_parse_by_mimetype,v_0)
+]
+
+httpOptions
+=[a_proxy,a_use_curl,a_options_curl]
+
+remainingOptions
+=filter(not.fliphasEntrydefaultOptions.fst)options
+
+traceLevel
+=maybethis(setTraceLevel.read).lookupa_trace$options
+
+addInputOptionsToSystemState
+=addSysOptions(filter((`elem`httpOptions).fst)remainingOptions)
+where
+addSysOptions
+=seqA.map(uncurrysetParamString)
+
+getMimeType
+=getAttrValuetransferMimeType>>^maptoLower
+
+processDocmimeType
+=traceMsg1("readDocument: "++showsrc++" (mime type: "++showmimeType++") will be processed")
+>>>
+parse
+>>>
+(ifisXmlOrHtml
+then(checknamespaces
+>>>
+canonicalize
+>>>
+whitespace
+>>>
+relax
+)
+elsethis
+)
+where
+parse
+|isHtml
+||
+withTagSoup=parseHtmlDocument-- parse as HTML or with tagsoup XML
+withTagSoup
+withNamespaces
+issueW
+(not(hasOptiona_canonicalize)&&preserveCmt)
+removeWS
+isHtml
+|validateWithRelax=parseXmlDocumentFalse-- for Relax NG use XML parser without validation
+|isXml=parseXmlDocumentvalidate-- parse as XML
+|otherwise=this-- don't parse, mime type is not XML nor HTML
+checknamespaces
+|(withNamespaces&¬withTagSoup)
+||
+validateWithRelax=propagateAndValidateNamespaces
+|otherwise=this
+canonicalize
+|withTagSoup=this-- tagsoup already removes redundant struff
+|validateWithRelax=canonicalizeAllNodes
+|hasOptiona_canonicalize
+&&
+preserveCmt=canonicalizeForXPath
+|hasOptiona_canonicalize=canonicalizeAllNodes
+|otherwise=this
+relax
+|validateWithRelax=validateDocumentWithRelaxSchemaremainingOptionsrelaxSchema
+|otherwise=this
+whitespace
+|removeWS
+&&
+notwithTagSoup=removeDocWhiteSpace-- tagsoup already removes whitespace
+|otherwise=this
+validateWithRelax=hasEntrya_relax_schemaoptions
+relaxSchema=lookup1a_relax_schemaoptions
+parseHtml=hasOptiona_parse_html
+parseXml=hasOptiona_parse_xml
+isHtml=parseHtml-- force HTML
+||
+mimeTypeIsHtml
+isXml=parseXml-- force XML parsing
+||
+(notparseHtml
+&&
+(mimeTypeIsXml||nullmimeType)-- mime type is XML or not there
+)
+isXmlOrHtml=isHtml||isXml
+parseByMimeType=hasOptiona_parse_by_mimetype
+validate=hasOptiona_validate
+withNamespaces=hasOptiona_check_namespaces
+withTagSoup=hasOptiona_tagsoup
+issueW=hasOptiona_issue_warnings
+removeWS=hasOptiona_remove_whitespace
+preserveCmt=hasOptiona_preserve_comment
+mimeTypeIsHtml=parseByMimeType&&isHtmlMimeTypemimeType
+mimeTypeIsXml=parseByMimeType&&isXmlMimeTypemimeType
+hasOptionn=optionIsSetnoptions
+
+-- ------------------------------------------------------------
+
+-- |
+-- the arrow version of 'readDocument', the arrow input is the source URI
+
+readFromDocument::Attributes->IOStateArrowsStringXmlTree
+readFromDocumentuserOptions
+=applyA(arr$\s->readDocumentuserOptionss)
+
+-- ------------------------------------------------------------
+
+-- |
+-- read a document that is stored in a normal Haskell String
+--
+-- the same function as readDocument, but the parameter forms the input.
+-- All options available for 'readDocument' are applicable for readString.
+--
+-- Default encoding: No encoding is done, the String argument is taken as Unicode string
+
+readString::Attributes->String->IOStateArrowsbXmlTree
+readStringuserOptionscontent
+=readDocument((a_encoding,unicodeString):userOptions)(stringProtocol++content)
+
+-- ------------------------------------------------------------
+
+-- |
+-- the arrow version of 'readString', the arrow input is the source URI
+
+readFromString::Attributes->IOStateArrowsStringXmlTree
+readFromStringuserOptions
+=applyA(arr$\s->readStringuserOptionss)
+
+-- ------------------------------------------------------------
+
+-- |
+-- parse a string as HTML content, substitute all HTML entity refs and canonicalize tree
+-- (substitute char refs, ...). Errors are ignored.
+--
+-- A simpler version of 'readFromString' but with less functionality.
+-- Does not run in the IO monad
+
+hread::ArrowXmla=>aStringXmlTree
+hread
+=parseHtmlContent
+>>>
+substHtmlEntityRefs
+>>>
+processTopDown(none`when`isError)
+>>>
+canonicalizeContents
+
+-- |
+-- parse a string as XML content, substitute all predefined XML entity refs and canonicalize tree
+-- (substitute char refs, ...)
+
+xread::ArrowXmla=>aStringXmlTree
+xread
+=parseXmlContent
+>>>
+substXmlEntityRefs
+>>>
+canonicalizeContents
+
+-- ------------------------------------------------------------
+
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.Arrow.WriteDocument
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id: WriteDocument.hs,v 1.8 2006/11/09 20:27:42 hxml Exp $
+
+Compound arrow for writing XML documents
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.Arrow.WriteDocument
+(writeDocument
+,writeDocumentToString
+,prepareContents
+)
+where
+
+importControl.Arrow-- arrow classes
+importControl.Arrow.ArrowList
+importControl.Arrow.ArrowIf
+importControl.Arrow.ArrowTree
+
+importText.XML.HXT.DOM.Interface
+importText.XML.HXT.Arrow.XmlArrow
+importText.XML.HXT.Arrow.XmlIOStateArrow
+
+importText.XML.HXT.Arrow.Edit
+(indentDoc
+,removeDocWhiteSpace
+,treeRepOfXmlDoc
+,haskellRepOfXmlDoc
+,escapeXmlDoc
+,escapeHtmlDoc
+)
+
+importText.XML.HXT.Arrow.DocumentOutput
+(putXmlDocument
+,encodeDocument
+)
+
+-- ------------------------------------------------------------
+
+{- |
+the main filter for writing documents
+
+this filter can be configured by an option list like 'Text.XML.HXT.Arrow.ReadDocument.readDocument'
+
+usage: @ writeDocument optionList destination @
+
+if @ destination @ is the empty string or \"-\", stdout is used as output device
+
+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_encoding' : encoding of document, default is 'a_encoding' or 'utf8'
+
+- 'a_output_xml' : (default) issue XML: quote special XML chars \>,\<,\",\',& where neccessary
+ add XML processing instruction
+ and encode document with respect to 'a_output_encoding',
+ if explicitly switched of, the plain text is issued, this is useful
+ for non XML output, e.g. generated Haskell code, LaTex, Java, ...
+
+- 'a_output_html' : issue XHTML: quote alle XML chars, use HTML entity refs or char refs for none ASCII chars
+
+- 'a_no_xml_pi' : suppress generation of \<?xml ... ?\> processing instruction
+
+- 'a_show_tree' : show tree representation of document (for debugging)
+
+- 'a_show_haskell' : show Haskell representaion of document (for debugging)
+
+ a minimal main program for copying a document
+ has the following structure:
+
+> module Main
+> where
+>
+> import Text.XML.HXT.Arrow
+>
+> main :: IO ()
+> main
+> = do
+> runX ( readDocument [] "hello.xml"
+> >>>
+> writeDocument [] "bye.xml"
+> )
+> return ()
+
+an example for copying a document to standard output with tracing and evaluation of
+error code is:
+
+> module Main
+> where
+>
+> import Text.XML.HXT.Arrow
+> import System.Exit
+>
+> main :: IO ()
+> main
+> = do
+> [rc] <- runX ( readDocument [ (a_trace, "1")
+> ] "hello.xml"
+> >>>
+> writeDocument [ (a_output_encoding, isoLatin1)
+> ] "-" -- output to stdout
+> >>>
+> getErrStatus
+> )
+> exitWith ( if rc >= c_err
+> then ExitFailure 1
+> else ExitSuccess
+> )
+-}
+
+writeDocument::Attributes->String->IOStateArrowsXmlTreeXmlTree
+writeDocumentuserOptionsdst
+=perform(traceMsg1("writeDocument: destination is "++showdst)
+>>>
+prepareContentsuserOptions
+>>>
+putXmlDocumentdst
+>>>
+traceMsg1"writeDocument: finished"
+)
+`when`
+documentStatusOk
+
+-- ------------------------------------------------------------
+
+-- |
+-- Convert a document into a string. Formating is done the same way
+-- and with the same options as in 'writeDocument'.
+
+writeDocumentToString::Attributes->IOStateArrowsXmlTreeString
+writeDocumentToStringuserOptions
+=prepareContentsuserOptions
+>>>
+xshowgetChildren
+
+-- ------------------------------------------------------------
+
+-- |
+-- indent and format output
+
+prepareContents::Attributes->IOStateArrowsXmlTreeXmlTree
+prepareContentsuserOptions
+=indent
+>>>
+format
+where
+indent
+|hasOptiona_indent=indentDoc-- document indentation
+|hasOptiona_remove_whitespace=removeDocWhiteSpace-- remove all whitespace between tags
+|otherwise=this
+
+format
+|hasOptiona_show_tree=treeRepOfXmlDoc
+|hasOptiona_show_haskell=haskellRepOfXmlDoc
+|hasOptiona_output_html=escapeHtmlDoc-- escape al XML and HTML chars >= 128
+>>>
+encodeDocument-- convert doc into text with respect to output encoding with ASCII as default
+suppressXmlPi(lookupDefusAsciia_output_encodingoptions)
+|hasOptiona_output_xml=escapeXmlDoc-- escape lt, gt, amp, quot,
+>>>
+encodeDocument-- convert doc into text with respect to output encoding
+suppressXmlPi(lookupDef""a_output_encodingoptions)
+|otherwise=this
+
+suppressXmlPi-- remove <?xml ... ?> when set
+=hasOptiona_no_xml_pi
+
+hasOptionn
+=optionIsSetnoptions
+
+options=addEntries
+userOptions
+[(a_indent,v_0)
+,(a_remove_whitespace,v_0)
+,(a_output_xml,v_1)
+,(a_show_tree,v_0)
+,(a_show_haskell,v_0)
+,(a_output_html,v_0)
+,(a_no_xml_pi,v_0)
+]
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.Arrow.XPath
+ Copyright : Copyright (C) 2006 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ Arrows for working with XPath and XmlNodeSets.
+
+ Most of the XPath arrows come in two versions,
+ one without dealing with namespaces, element and attribute names
+ in XPath expressions are taken as they ar ignoring any prefix:localname structure.
+
+ The second variant uses a namespace environment for associating the right
+ namespace for the appropriate prefix. an entry for the empty prefix
+ defines the default namespace for the expression.
+
+ The second variant should be used, when in the application namespaces
+ are significant, that means when namespace propagation is done for
+ the documents to be processed.
+
+ NodeSets are sets of \"pointer\" into an XML tree to reference
+ subnodes. These nodesets can be computed by XPath expressions or
+ normal arrows. The nodesets can then be used later for selecting
+ or modifying subtrees of this tree in an efficient way.
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.Arrow.XPath
+(getXPathTreesInDoc
+,getXPathTreesInDocWithNsEnv
+,getXPathTrees
+,getXPathTreesWithNsEnv
+,getElemNodeSet
+,getElemAndAttrNodeSet
+,getXPathNodeSet
+,getFromNodeSet
+,processXPathTrees
+,processXPathTreesWithNsEnv
+,processFromNodeSet
+)
+where
+
+importqualifiedText.XML.HXT.XPathasPT
+(getXPathSubTreesWithNsEnv
+,getXPathNodeSetWithNsEnv
+)
+
+importControl.Arrow.ListArrows
+
+importText.XML.HXT.DOM.Interface
+importText.XML.HXT.Arrow.XmlArrow
+
+importText.XML.HXT.Arrow.Edit
+(canonicalizeForXPath
+)
+
+-- ------------------------------------------------------------
+
+-- |
+-- Select parts of a whole XML document with root node by a XPath expression.
+--
+-- The main filter for selecting parts of a document via XPath.
+--
+-- The string argument must be a XPath expression with an absolute location path,
+-- the argument tree must be a complete document tree.
+--
+-- Before evaluating the xpath query, the document is canonicalized
+-- with 'Text.XML.HXT.Arrow.Edit.canonicalizeForXPath'
+--
+-- Result is a possibly empty list of XmlTrees forming the set of selected XPath values.
+-- XPath values other than XmlTrees (numbers, attributes, tagnames, ...)
+-- are convertet to text nodes.
+
+getXPathTreesInDoc::ArrowXmla=>String->aXmlTreeXmlTree
+getXPathTreesInDoc=getXPathTreesInDocWithNsEnv[]
+
+-- | Same as 'getXPathTreesInDoc' but with namespace environment for the XPath names
+
+getXPathTreesInDocWithNsEnv::ArrowXmla=>NsEnv->String->aXmlTreeXmlTree
+getXPathTreesInDocWithNsEnvenvquery=canonicalizeForXPath
+>>>
+arrL(PT.getXPathSubTreesWithNsEnvenvquery)
+
+-- |
+-- Select parts of an arbitrary XML tree by a XPath expression.
+--
+-- The main filter for selecting parts of an arbitrary XML tree via XPath.
+-- The string argument must be a XPath expression with an absolute location path,
+-- There are no restrictions on the argument tree.
+--
+-- No canonicalization is performed before evaluating the query
+--
+-- Result is a possibly empty list of XmlTrees forming the set of selected XPath values.
+-- XPath values other than XmlTrees (numbers, attributes, tagnames, ...)
+-- are convertet to text nodes.
+
+getXPathTrees::ArrowXmla=>String->aXmlTreeXmlTree
+getXPathTrees=getXPathTreesWithNsEnv[]
+
+-- | Same as 'getXPathTrees' but with namespace environment for the XPath names
+
+getXPathTreesWithNsEnv::ArrowXmla=>NsEnv->String->aXmlTreeXmlTree
+getXPathTreesWithNsEnvenvquery=arrL(PT.getXPathSubTreesWithNsEnvenvquery)
+
+-- | Select a set of nodes via an XPath expression from an arbitray XML tree
+--
+-- The result is a set of \"pointers\" to nodes. This set can be used to
+-- access or modify the values of the subnodes in subsequent calls to 'getFromNodeSet' or 'processFromNodeSet'.
+--
+-- This function enables for parsing an XPath expressions and traversing the tree for node selection once
+-- and reuse this result possibly many times for later selection and modification operations.
+
+getXPathNodeSet::ArrowXmla=>String->aXmlTreeXmlNodeSet
+getXPathNodeSet=getXPathNodeSetWithNsEnv[]
+
+-- | Same as 'getXPathNodeSet' but with namespace environment for the XPath names
+
+getXPathNodeSetWithNsEnv::ArrowXmla=>NsEnv->String->aXmlTreeXmlNodeSet
+getXPathNodeSetWithNsEnvnsEnvquery=arr(PT.getXPathNodeSetWithNsEnvnsEnvquery)
+
+-- ------------------------------------------------------------
+
+getNodeSet::ArrowXmla=>aXmlTreeQName->aXmlTreeXmlTree->aXmlTreeXmlNodeSet
+getNodeSetaff
+=((listA(getChildren
+>>>
+getNodeSetaff
+)
+>>>
+arrfilterNodeSet
+)
+&&&
+listAaf
+&&&
+listAf
+)
+>>^(\~(cl,(al,n))->XNS(not.null$n)alcl)
+where
+filterNodeSet::[XmlNodeSet]->ChildNodes
+filterNodeSet
+=concat.zipWithfilterIx[0..]
+
+filterIx::Int->XmlNodeSet->ChildNodes
+filterIx_ix(XNSFalse[][])
+=[]
+filterIxixps
+=[(ix,ps)]
+
+-- |
+-- compute a node set from a tree, containing all nodes selected by the predicate arrow
+--
+-- computation of the set of element nodes with name \"a\" is done with
+--
+-- > getElemNodeSet (hasName "a")
+
+getElemNodeSet::ArrowXmla=>aXmlTreeXmlTree->aXmlTreeXmlNodeSet
+getElemNodeSetf
+=getNodeSetnonef
+
+-- |
+-- compute a node set from a tree, containing all nodes including attribute nodes
+-- elected by the predicate arrow
+
+getElemAndAttrNodeSet::ArrowXmla=>aXmlTreeXmlTree->aXmlTreeXmlNodeSet
+getElemAndAttrNodeSetf
+=getNodeSet(getAttrl
+>>>
+(f`guards`getAttrName)
+)f
+
+-- ------------------------------------------------------------
+
+-- |
+-- select all subtrees specified by a previously computed node set
+--
+-- the following law holds:
+--
+-- > getFromNodeSet $< getElemNodeSet f == multi f
+
+getFromNodeSet::ArrowXmla=>XmlNodeSet->aXmlTreeXmlTree
+getFromNodeSet(XNStalcl)
+=fromLA$
+(iftthenthiselsenone)
+<+>
+(getAttrl>>>getFromAttrlal)
+<+>
+(getFromChildren(0-1)cl$<listAgetChildren)
+where
+
+getFromAttrl::[QName]->LAXmlTreeXmlTree
+getFromAttrll
+=(catA.maphasQName$l)
+`guards`
+this
+
+getFromChildren::Int->ChildNodes->XmlTrees->LAXmlTreeXmlTree
+getFromChildren_[]_
+=none
+
+getFromChildreni'((i,sp):sps)ts
+=(arrL(constt')>>>getFromNodeSetsp)
+<+>
+getFromChildrenispsts'
+where
+(t',ts')=splitAt1.drop(i-i'-1)$ts
+
+-- ------------------------------------------------------------
+
+-- |
+-- process all subtrees selected by an XPath expression
+--
+-- the following law holds:
+--
+-- > processXPathTrees p xpathExpr == processFromNodeSet p $< getXPathNodeSet xpathExpr
+
+
+processXPathTrees::ArrowXmla=>aXmlTreeXmlTree->String->aXmlTreeXmlTree
+processXPathTreesf=processXPathTreesWithNsEnvf[]
+
+-- | Same as 'processXPathTrees' but with namespace environment for the XPath names
+
+processXPathTreesWithNsEnv::ArrowXmla=>aXmlTreeXmlTree->NsEnv->String->aXmlTreeXmlTree
+processXPathTreesWithNsEnvfnsEnvquery
+=choiceA
+[isRoot:->processChildrenpns
+,this:->pns
+]
+where
+pns=processFromNodeSetf$<getXPathNodeSetWithNsEnvnsEnvquery
+
+-- |
+-- process all subtrees specified by a previously computed node set in bottom up manner
+--
+-- the follwoing law holds:
+--
+-- > processFromNodeSet g $< getElemNodeSet f == processBottomUp (g `when` f)
+--
+-- when attributes are contained in the node set (see 'getElemAndAttrNodeSet'), these are processed
+-- after the children and before the node itself
+--
+-- the advantage of processFromNodeSet is the separation of the selection of set of nodes to be processed (e.g. modified)
+-- from the real proccessing. The selection sometimes can be done once, the processing possibly many times.
+
+processFromNodeSet::ArrowXmla=>aXmlTreeXmlTree->XmlNodeSet->aXmlTreeXmlTree
+processFromNodeSetf(XNStalcl)
+=(ifnullcl
+thenthis
+elsereplaceChildren(processC(0-1)cl$<listAgetChildren)
+)
+>>>
+(ifnullal
+thenthis
+elseprocessAttrl(processAal)
+)
+>>>
+(ifnott
+thenthis
+elsef
+)
+where
+
+-- processA :: ChildNodes -> a XmlTree XmlTree
+processAl
+=f`when`(catA.maphasQName$l)
+
+-- processC :: ChildNodes -> XmlTrees -> a XmlTree XmlTree
+processC_[]ts
+=arrL(constts)
+
+processCi'((i,sp):sps)ts
+=arrL(constts1)
+<+>
+(arrL(constti)>>>processFromNodeSetfsp)
+<+>
+processCispsts21
+where
+(ts1,ts2)=splitAt(i-i'-1)ts
+(ti,ts21)=splitAt1ts2
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.Arrow.XmlArrow
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id: XmlArrow.hs,v 1.34 2006/11/02 16:43:39 hxml Exp $
+
+ Basic arrows for processing XML documents
+
+ All arrows use IO and a global state for options, errorhandling, ...
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.Arrow.XmlArrow
+(moduleText.XML.HXT.Arrow.XmlArrow)
+where
+
+importData.Maybe
+
+importControl.Arrow-- classes
+importControl.Arrow.ArrowList
+importControl.Arrow.ArrowIf
+importControl.Arrow.ArrowTree
+
+importControl.Arrow.ListArrow-- arrow types
+importControl.Arrow.StateListArrow
+importControl.Arrow.IOListArrow
+importControl.Arrow.IOStateListArrow
+
+importText.XML.HXT.DOM.Interface
+importText.XML.HXT.DOM.Unicode
+(isXmlSpaceChar
+)
+importqualifiedText.XML.HXT.DOM.XmlNodeasXN
+importqualifiedText.XML.HXT.DOM.ShowXmlasXS
+
+{- | Arrows for processing 'Text.XML.HXT.DOM.TypeDefs.XmlTree's
+
+These arrows can be grouped into predicates, selectors, constructors, and transformers.
+
+All predicates (tests) act like 'Control.Arrow.ArrowIf.none' for failure and 'Control.Arrow.ArrowIf.this' for success.
+A logical and can be formed by @ a1 >>> a2 @, a locical or by @ a1 \<+\> a2 @.
+
+Selector arrows will fail, when applied to wrong input, e.g. selecting the text of a node with 'getText'
+will fail when applied to a none text node.
+
+Edit arrows will remain the input unchanged, when applied to wrong argument, e.g. editing the content of a text node
+with 'changeText' applied to an element node will return the unchanged element node.
+-}
+
+infixl7+=
+
+class(Arrowa,ArrowLista,ArrowTreea)=>ArrowXmlawhere
+
+-- discriminating predicates
+
+-- | test for text nodes
+isText::aXmlTreeXmlTree
+isText=isAXN.isText
+
+-- | test for char reference, used during parsing
+isCharRef::aXmlTreeXmlTree
+isCharRef=isAXN.isCharRef
+
+-- | test for entity reference, used during parsing
+isEntityRef::aXmlTreeXmlTree
+isEntityRef=isAXN.isEntityRef
+
+-- | test for comment
+isCmt::aXmlTreeXmlTree
+isCmt=isAXN.isCmt
+
+-- | test for CDATA section, used during parsing
+isCdata::aXmlTreeXmlTree
+isCdata=isAXN.isCdata
+
+-- | test for processing instruction
+isPi::aXmlTreeXmlTree
+isPi=isAXN.isPi
+
+-- | test for processing instruction \<?xml ...\>
+isXmlPi::aXmlTreeXmlTree
+isXmlPi=isPi>>>hasName"xml"
+
+-- | test for element
+isElem::aXmlTreeXmlTree
+isElem=isAXN.isElem
+
+-- | test for DTD part, used during parsing
+isDTD::aXmlTreeXmlTree
+isDTD=isAXN.isDTD
+
+-- | test for attribute tree
+isAttr::aXmlTreeXmlTree
+isAttr=isAXN.isAttr
+
+-- | test for error message
+isError::aXmlTreeXmlTree
+isError=isAXN.isError
+
+-- | test for root node (element with name \"\/\")
+isRoot::aXmlTreeXmlTree
+isRoot=isAXN.isRoot
+
+-- | test for text nodes with text, for which a predicate holds
+--
+-- example: @hasText (all (\`elem\` \" \\t\\n\"))@ check for text nodes with only whitespace content
+
+hasText::(String->Bool)->aXmlTreeXmlTree
+hasTextp=(isText>>>getText>>>isAp)`guards`this
+
+-- | test for text nodes with only white space
+--
+-- implemented with 'hasTest'
+
+isWhiteSpace::aXmlTreeXmlTree
+isWhiteSpace=hasText(allisXmlSpaceChar)
+
+-- |
+-- test whether a node (element, attribute, pi) has a name with a special property
+
+hasNameWith::(QName->Bool)->aXmlTreeXmlTree
+hasNameWithp=(getQName>>>isAp)`guards`this
+
+-- |
+-- test whether a node (element, attribute, pi) has a specific qualified name
+-- useful only after namespace propagation
+hasQName::QName->aXmlTreeXmlTree
+hasQNamen=(getQName>>>isA(==n))`guards`this
+
+-- |
+-- test whether a node has a specific name (prefix:localPart ore localPart),
+-- generally useful, even without namespace handling
+hasName::String->aXmlTreeXmlTree
+hasNamen=(getName>>>isA(==n))`guards`this
+
+-- |
+-- test whether a node has a specific name as local part,
+-- useful only after namespace propagation
+hasLocalPart::String->aXmlTreeXmlTree
+hasLocalPartn=(getLocalPart>>>isA(==n))`guards`this
+
+-- |
+-- test whether a node has a specific name prefix,
+-- useful only after namespace propagation
+hasNamePrefix::String->aXmlTreeXmlTree
+hasNamePrefixn=(getNamePrefix>>>isA(==n))`guards`this
+
+-- |
+-- test whether a node has a specific namespace URI
+-- useful only after namespace propagation
+hasNamespaceUri::String->aXmlTreeXmlTree
+hasNamespaceUrin=(getNamespaceUri>>>isA(==n))`guards`this
+
+-- |
+-- test whether an element node has an attribute node with a specific name
+hasAttr::String->aXmlTreeXmlTree
+hasAttrn=(getAttrl>>>hasNamen)`guards`this
+
+-- |
+-- test whether an element node has an attribute node with a specific qualified name
+hasQAttr::QName->aXmlTreeXmlTree
+hasQAttrn=(getAttrl>>>hasQNamen)`guards`this
+
+-- |
+-- test whether an element node has an attribute with a specific value
+hasAttrValue::String->(String->Bool)->aXmlTreeXmlTree
+hasAttrValuenp=(getAttrl>>>hasNamen>>>xshowgetChildren>>>isAp)`guards`this
+
+-- |
+-- test whether an element node has an attribute with a qualified name and a specific value
+hasQAttrValue::QName->(String->Bool)->aXmlTreeXmlTree
+hasQAttrValuenp=(getAttrl>>>hasQNamen>>>xshowgetChildren>>>isAp)`guards`this
+
+-- constructor arrows ------------------------------------------------------------
+
+-- | text node construction arrow
+mkText::aStringXmlTree
+mkText=arrXN.mkText
+
+-- | char reference construction arrow, useful for document output
+mkCharRef::aIntXmlTree
+mkCharRef=arrXN.mkCharRef
+
+-- | entity reference construction arrow, useful for document output
+mkEntityRef::aStringXmlTree
+mkEntityRef=arrXN.mkEntityRef
+
+-- | comment node construction, useful for document output
+mkCmt::aStringXmlTree
+mkCmt=arrXN.mkCmt
+
+-- | CDATA construction, useful for document output
+mkCdata::aStringXmlTree
+mkCdata=arrXN.mkCdata
+
+-- | error node construction, useful only internally
+mkError::Int->aStringXmlTree
+mkErrorlevel=arr(XN.mkErrorlevel)
+
+-- | element construction:
+-- | the attributes and the content of the element are computed by applying arrows
+-- to the input
+mkElement::QName->anXmlTree->anXmlTree->anXmlTree
+mkElementnafcf=(listAaf&&&listAcf)
+>>>
+arr2(\alcl->XN.mkElementnalcl)
+-- | attribute node construction:
+-- | the attribute value is computed by applying an arrow to the input
+mkAttr::QName->anXmlTree->anXmlTree
+mkAttrqnf=listAf>>>arr(XN.mkAttrqn)
+
+-- | processing instruction construction:
+-- | the content of the processing instruction is computed by applying an arrow to the input
+mkPi::QName->anXmlTree->anXmlTree
+mkPiqnf=listAf>>>arr(XN.mkPiqn)
+
+-- convenient arrows for constructors --------------------------------------------------
+
+-- | convenient arrow for element construction, more comfortable variant of 'mkElement'
+--
+-- example for simplifying 'mkElement' :
+--
+-- > mkElement qn (a1 <+> ... <+> ai) (c1 <+> ... <+> cj)
+--
+-- equals
+--
+-- > mkqelem qn [a1,...,ai] [c1,...,cj]
+
+mkqelem::QName->[anXmlTree]->[anXmlTree]->anXmlTree
+mkqelemnafscfs=mkElementn(catAafs)(catAcfs)
+
+-- | convenient arrow for element construction with strings instead of qualified names as tagnames, see also 'mkElement' and 'mkelem'
+mkelem::String->[anXmlTree]->[anXmlTree]->anXmlTree
+mkelemnafscfs=mkElement(mkSNsNamen)(catAafs)(catAcfs)
+
+-- | convenient arrow for element constrution with attributes but without content, simple variant of 'mkelem' and 'mkElement'
+aelem::String->[anXmlTree]->anXmlTree
+aelemnafs=catAafs>.\al->XN.mkElement(mkSNsNamen)al[]
+
+-- | convenient arrow for simple element constrution without attributes, simple variant of 'mkelem' and 'mkElement'
+selem::String->[anXmlTree]->anXmlTree
+selemncfs=catAcfs>.XN.mkElement(mkSNsNamen)[]
+
+-- | convenient arrow for constrution of empty elements without attributes, simple variant of 'mkelem' and 'mkElement'
+eelem::String->anXmlTree
+eelemn=constA(XN.mkElement(mkSNsNamen)[][])
+
+-- | construction of an element node with name \"\/\" for document roots
+root::[anXmlTree]->[anXmlTree]->anXmlTree
+root=mkelemt_root
+
+-- | alias for 'mkAttr'
+qattr::QName->anXmlTree->anXmlTree
+qattr=mkAttr
+
+-- | convenient arrow for attribute constrution, simple variant of 'mkAttr'
+attr::String->anXmlTree->anXmlTree
+attr=mkAttr.mkSNsName
+
+-- constant arrows (ignoring the input) for tree construction ------------------------------
+
+-- | constant arrow for text nodes
+txt::String->anXmlTree
+txt=constA.XN.mkText
+
+-- | constant arrow for char reference nodes
+charRef::Int->anXmlTree
+charRef=constA.XN.mkCharRef
+
+-- | constant arrow for entity reference nodes
+entityRef::String->anXmlTree
+entityRef=constA.XN.mkEntityRef
+
+-- | constant arrow for comment
+cmt::String->anXmlTree
+cmt=constA.XN.mkCmt
+
+-- | constant arrow for warning
+warn::String->anXmlTree
+warn=constA.(XN.mkErrorc_warn)
+
+-- | constant arrow for errors
+err::String->anXmlTree
+err=constA.(XN.mkErrorc_err)
+
+-- | constant arrow for fatal errors
+fatal::String->anXmlTree
+fatal=constA.(XN.mkErrorc_fatal)
+
+-- | constant arrow for simple processing instructions, see 'mkPi'
+spi::String->String->anXmlTree
+spipiNamepiCont=constA(XN.mkPi(mkSNsNamepiName)[XN.mkTextpiCont])
+
+-- | constant arrow for attribute nodes, attribute name is a qualified name and value is a text,
+-- | see also 'mkAttr', 'qattr', 'attr'
+sqattr::QName->String->anXmlTree
+sqattranav=constA(XN.mkAttran[XN.mkTextav])
+
+-- | constant arrow for attribute nodes, attribute name and value are
+-- | given by parameters, see 'mkAttr'
+sattr::String->String->anXmlTree
+sattranav=constA(XN.mkAttr(mkSNsNamean)[XN.mkTextav])
+
+-- selector arrows --------------------------------------------------
+
+-- | select the text of a text node
+getText::aXmlTreeString
+getText=arrL(maybeToList.XN.getText)
+
+-- | select the value of a char reference
+getCharRef::aXmlTreeInt
+getCharRef=arrL(maybeToList.XN.getCharRef)
+
+-- | select the name of a entity reference node
+getEntityRef::aXmlTreeString
+getEntityRef=arrL(maybeToList.XN.getEntityRef)
+
+-- | select the comment of a comment node
+getCmt::aXmlTreeString
+getCmt=arrL(maybeToList.XN.getCmt)
+
+-- | select the content of a CDATA node
+getCdata::aXmlTreeString
+getCdata=arrL(maybeToList.XN.getCdata)
+
+-- | select the name of a processing instruction
+getPiName::aXmlTreeQName
+getPiName=arrL(maybeToList.XN.getPiName)
+
+-- | select the content of a processing instruction
+getPiContent::aXmlTreeXmlTree
+getPiContent=arrL(fromMaybe[].XN.getPiContent)
+
+-- | select the name of an element node
+getElemName::aXmlTreeQName
+getElemName=arrL(maybeToList.XN.getElemName)
+
+-- | select the attribute list of an element node
+getAttrl::aXmlTreeXmlTree
+getAttrl=arrL(fromMaybe[].XN.getAttrl)
+
+-- | select the DTD type of a DTD node
+getDTDPart::aXmlTreeDTDElem
+getDTDPart=arrL(maybeToList.XN.getDTDPart)
+
+-- | select the DTD attributes of a DTD node
+getDTDAttrl::aXmlTreeAttributes
+getDTDAttrl=arrL(maybeToList.XN.getDTDAttrl)
+
+-- | select the name of an attribute
+getAttrName::aXmlTreeQName
+getAttrName=arrL(maybeToList.XN.getAttrName)
+
+-- | select the error level (c_warn, c_err, c_fatal) from an error node
+getErrorLevel::aXmlTreeInt
+getErrorLevel=arrL(maybeToList.XN.getErrorLevel)
+
+-- | select the error message from an error node
+getErrorMsg::aXmlTreeString
+getErrorMsg=arrL(maybeToList.XN.getErrorMsg)
+
+-- | select the qualified name from an element, attribute or pi
+getQName::aXmlTreeQName
+getQName=arrL(maybeToList.XN.getName)
+
+-- | select the prefix:localPart or localPart from an element, attribute or pi
+getName::aXmlTreeString
+getName=arrL(maybeToList.XN.getQualifiedName)
+
+-- | select the univeral name ({namespace URI} ++ localPart)
+getUniversalName::aXmlTreeString
+getUniversalName=arrL(maybeToList.XN.getUniversalName)
+
+-- | select the univeral name (namespace URI ++ localPart)
+getUniversalUri::aXmlTreeString
+getUniversalUri=arrL(maybeToList.XN.getUniversalUri)
+
+-- | select the local part
+getLocalPart::aXmlTreeString
+getLocalPart=arrL(maybeToList.XN.getLocalPart)
+
+-- | select the name prefix
+getNamePrefix::aXmlTreeString
+getNamePrefix=arrL(maybeToList.XN.getNamePrefix)
+
+-- | select the namespace URI
+getNamespaceUri::aXmlTreeString
+getNamespaceUri=arrL(maybeToList.XN.getNamespaceUri)
+
+-- | select the value of an attribute of an element node,
+-- always succeeds with empty string as default value \"\"
+getAttrValue::String->aXmlTreeString
+getAttrValuen=xshow(getAttrl>>>hasNamen>>>getChildren)
+
+-- | like 'getAttrValue', but fails if the attribute does not exist
+getAttrValue0::String->aXmlTreeString
+getAttrValue0n=getAttrl>>>hasNamen>>>xshowgetChildren
+
+-- | like 'getAttrValue', but select the value of an attribute given by a qualified name,
+-- always succeeds with empty string as default value \"\"
+getQAttrValue::QName->aXmlTreeString
+getQAttrValuen=xshow(getAttrl>>>hasQNamen>>>getChildren)
+
+-- | like 'getQAttrValue', but fails if attribute does not exist
+getQAttrValue0::QName->aXmlTreeString
+getQAttrValue0n=getAttrl>>>hasQNamen>>>xshowgetChildren
+
+-- edit arrows --------------------------------------------------
+
+-- | edit the string of a text node
+changeText::(String->String)->aXmlTreeXmlTree
+changeTextcf=arr(XN.changeTextcf)`when`isText
+
+-- | edit the comment string of a comment node
+changeCmt::(String->String)->aXmlTreeXmlTree
+changeCmtcf=arr(XN.changeCmtcf)`when`isCmt
+
+-- | edit an element-, attribute- or pi- name
+changeQName::(QName->QName)->aXmlTreeXmlTree
+changeQNamecf=arr(XN.changeNamecf)`when`getQName
+
+-- | edit an element name
+changeElemName::(QName->QName)->aXmlTreeXmlTree
+changeElemNamecf=arr(XN.changeElemNamecf)`when`isElem
+
+-- | edit an attribute name
+changeAttrName::(QName->QName)->aXmlTreeXmlTree
+changeAttrNamecf=arr(XN.changeAttrNamecf)`when`isAttr
+
+-- | edit a pi name
+changePiName::(QName->QName)->aXmlTreeXmlTree
+changePiNamecf=arr(XN.changePiNamecf)`when`isPi
+
+-- | edit an attribute value
+changeAttrValue::(String->String)->aXmlTreeXmlTree
+changeAttrValuecf=replaceChildren(xshowgetChildren
+>>>arrcf
+>>>mkText
+)
+`when`isAttr
+
+
+-- | edit an attribute list of an element node
+changeAttrl::(XmlTrees->XmlTrees->XmlTrees)->aXmlTreeXmlTree->aXmlTreeXmlTree
+changeAttrlcff=((listAf&&&this)
+>>>
+arr2changeAL
+)
+`when`
+(isElem<+>isPi)
+where
+changeALasx=XN.changeAttrl(\xs->cfxsas)x
+
+-- | replace an element, attribute or pi name
+setQName::QName->aXmlTreeXmlTree
+setQNamen=changeQName(constn)
+
+-- | replace an element name
+setElemName::QName->aXmlTreeXmlTree
+setElemNamen=changeElemName(constn)
+
+-- | replace an attribute name
+setAttrName::QName->aXmlTreeXmlTree
+setAttrNamen=changeAttrName(constn)
+
+-- | replace an element name
+setPiName::QName->aXmlTreeXmlTree
+setPiNamen=changePiName(constn)
+
+-- | replace an atribute list of an element node
+setAttrl::aXmlTreeXmlTree->aXmlTreeXmlTree
+setAttrl=changeAttrl(constid)-- (\ x y -> y)
+
+-- | add a list of attributes list to an element
+addAttrl::aXmlTreeXmlTree->aXmlTreeXmlTree
+addAttrl=changeAttrl(XN.mergeAttrl)
+
+-- | add (or replace) an attribute
+addAttr::String->String->aXmlTreeXmlTree
+addAttranav=addAttrl(sattranav)
+
+-- | remove an attribute
+removeAttr::String->aXmlTreeXmlTree
+removeAttran=processAttrl(none`when`hasNamean)
+
+-- | remove an attribute with a qualified name
+removeQAttr::QName->aXmlTreeXmlTree
+removeQAttran=processAttrl(none`when`hasQNamean)
+
+-- | process the attributes of an element node with an arrow
+processAttrl::aXmlTreeXmlTree->aXmlTreeXmlTree
+processAttrlf=setAttrl(getAttrl>>>f)
+
+-- | process a whole tree inclusive attribute list of element nodes
+-- see also: 'Control.Arrow.ArrowTree.processTopDown'
+
+processTopDownWithAttrl::aXmlTreeXmlTree->aXmlTreeXmlTree
+processTopDownWithAttrlf=processTopDown(f>>>(processAttrl(processTopDownf)`when`isElem))
+
+-- | convenient op for adding attributes or children to a node
+--
+-- usage: @ tf += cf @
+--
+-- the @tf@ arrow computes an element node, and all trees computed by @cf@ are
+-- added to this node, if a tree is an attribute, it is inserted in the attribute list
+-- else it is appended to the content list.
+--
+-- attention: do not build long content list this way because '+=' is implemented by ++
+--
+-- examples:
+--
+-- > eelem "a"
+-- > += sattr "href" "page.html"
+-- > += sattr "name" "here"
+-- > += txt "look here"
+--
+-- is the same as
+--
+-- > mkelem [ sattr "href" "page.html"
+-- > , sattr "name" "here"
+-- > ]
+-- > [ txt "look here" ]
+--
+-- and results in the XML fragment: \<a href=\"page.html\" name=\"here\"\>look here\<\/a\>
+--
+-- advantage of the '+=' operator is, that attributes and content can be added
+-- any time step by step.
+-- if @tf@ computes a whole list of trees, e.g. a list of \"td\" or \"tr\" elements,
+-- the attributes or content is added to all trees. useful for adding \"class\" or \"style\" attributes
+-- to table elements.
+
+(+=)::abXmlTree->abXmlTree->abXmlTree
+tf+=cf=(tf&&&listAcf)>>>arr2addChildren
+where
+addChildren::XmlTree->XmlTrees->XmlTree
+addChildrentcs
+=foldladdChildtcs
+addChild::XmlTree->XmlTree->XmlTree
+addChildtc
+|not(XN.isElemt)
+=t
+|XN.isAttrc
+=XN.changeAttrl(XN.addAttrc)t
+|otherwise
+=XN.changeChildren(++[c])t
+
+-- | apply an arrow to the input and convert the resulting XML trees into a string representation
+xshow::anXmlTree->anString
+xshowf=f>.XS.xshow
+
+{- | Document Type Definition arrows
+
+These are separated, because they are not needed for document processing,
+only when processing the DTD, e.g. for generating access funtions for the toolbox
+from a DTD (se example DTDtoHaskell in the examples directory)
+-}
+
+
+class(ArrowXmla)=>ArrowDTDawhere
+isDTDDoctype::aXmlTreeXmlTree
+isDTDDoctype=isA(maybeFalse(==DOCTYPE).XN.getDTDPart)
+
+isDTDElement::aXmlTreeXmlTree
+isDTDElement=isA(maybeFalse(==ELEMENT).XN.getDTDPart)
+
+isDTDContent::aXmlTreeXmlTree
+isDTDContent=isA(maybeFalse(==CONTENT).XN.getDTDPart)
+
+isDTDAttlist::aXmlTreeXmlTree
+isDTDAttlist=isA(maybeFalse(==ATTLIST).XN.getDTDPart)
+
+isDTDEntity::aXmlTreeXmlTree
+isDTDEntity=isA(maybeFalse(==ENTITY).XN.getDTDPart)
+
+isDTDPEntity::aXmlTreeXmlTree
+isDTDPEntity=isA(maybeFalse(==PENTITY).XN.getDTDPart)
+
+isDTDNotation::aXmlTreeXmlTree
+isDTDNotation=isA(maybeFalse(==NOTATION).XN.getDTDPart)
+
+isDTDCondSect::aXmlTreeXmlTree
+isDTDCondSect=isA(maybeFalse(==CONDSECT).XN.getDTDPart)
+
+isDTDName::aXmlTreeXmlTree
+isDTDName=isA(maybeFalse(==NAME).XN.getDTDPart)
+
+isDTDPERef::aXmlTreeXmlTree
+isDTDPERef=isA(maybeFalse(==PEREF).XN.getDTDPart)
+
+hasDTDAttr::String->aXmlTreeXmlTree
+hasDTDAttrn=isA(isJust.lookupn.fromMaybe[].XN.getDTDAttrl)
+
+getDTDAttrValue::String->aXmlTreeString
+getDTDAttrValuen=arrL(maybeToList.lookupn.fromMaybe[].XN.getDTDAttrl)
+
+setDTDAttrValue::String->String->aXmlTreeXmlTree
+setDTDAttrValuenv=arr(XN.changeDTDAttrl(addEntrynv))`when`isDTD
+
+mkDTDElem::DTDElem->Attributes->anXmlTree->anXmlTree
+mkDTDElemealcf=listAcf>>>arr(XN.mkDTDElemeal)
+
+mkDTDDoctype::Attributes->anXmlTree->anXmlTree
+mkDTDDoctype=mkDTDElemDOCTYPE
+
+mkDTDElement::Attributes->anXmlTree
+mkDTDElemental=mkDTDElemELEMENTalnone
+
+mkDTDEntity::Attributes->anXmlTree
+mkDTDEntityal=mkDTDElemENTITYalnone
+
+mkDTDPEntity::Attributes->anXmlTree
+mkDTDPEntityal=mkDTDElemPENTITYalnone
+
+instanceArrowXmlLA
+instanceArrowXml(SLAs)
+instanceArrowXmlIOLA
+instanceArrowXml(IOSLAs)
+
+instanceArrowDTDLA
+instanceArrowDTD(SLAs)
+instanceArrowDTDIOLA
+instanceArrowDTD(IOSLAs)
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.Arrow.XmlIOStateArrow
+ Copyright : Copyright (C) 2005 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id: XmlIOStateArrow.hs,v 1.39 2006/11/09 20:27:42 hxml Exp $
+
+ the basic state arrows for XML processing
+
+ A state is needed for global processing options,
+ like encoding options, document base URI, trace levels
+ and error message handling
+
+ The state is separated into a user defined state
+ and a system state. The system state contains variables
+ for error message handling, for tracing, for the document base
+ for accessing XML documents with relative references, e.g. DTDs,
+ and a global key value store. This assoc list has strings as keys
+ and lists of XmlTrees as values. It is used to store arbitrary
+ XML and text values, e.g. user defined global options.
+
+ The user defined part of the store is in the default case empty, defined as ().
+ It can be extended with an arbitray data type
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.Arrow.XmlIOStateArrow
+(-- * Data Types
+XIOState(..),
+XIOSysState(..),
+IOStateArrow,
+IOSArrow,
+
+-- * Running Arrows
+initialState,
+initialSysState,
+runX,
+
+-- * User State Manipulation
+getUserState,
+setUserState,
+changeUserState,
+withExtendedUserState,
+withOtherUserState,
+
+-- * Global System State Access
+getSysParam,
+changeSysParam,
+
+setParamList,
+setParam,
+unsetParam,
+getParam,
+getAllParams,
+setParamString,
+getParamString,
+setParamInt,
+getParamInt,
+
+-- * Error Message Handling
+clearErrStatus,
+setErrStatus,
+getErrStatus,
+setErrMsgStatus,
+setErrorMsgHandler,
+
+errorMsgStderr,
+errorMsgCollect,
+errorMsgStderrAndCollect,
+errorMsgIgnore,
+
+getErrorMessages,
+
+filterErrorMsg,
+issueWarn,
+issueErr,
+issueFatal,
+setDocumentStatus,
+setDocumentStatusFromSystemState,
+documentStatusOk,
+
+-- * Document Base
+setBaseURI,
+getBaseURI,
+changeBaseURI,
+setDefaultBaseURI,
+getDefaultBaseURI,
+runInLocalURIContext,
+
+-- * Tracing
+setTraceLevel,
+getTraceLevel,
+withTraceLevel,
+trace,
+traceMsg,
+traceString,
+traceSource,
+traceTree,
+traceDoc,
+traceState,
+
+-- * URI Manipulation
+expandURIString,
+expandURI,
+mkAbsURI,
+
+getFragmentFromURI,
+getPathFromURI,
+getPortFromURI,
+getQueryFromURI,
+getRegNameFromURI,
+getSchemeFromURI,
+getUserInfoFromURI
+)
+where
+
+importControl.Arrow-- arrow classes
+importControl.Arrow.ArrowList
+importControl.Arrow.ArrowIf
+importControl.Arrow.ArrowTree
+importControl.Arrow.ArrowIO
+importControl.Arrow.IOStateListArrow
+
+importControl.Strategies.DeepSeq
+
+importText.XML.HXT.DOM.Interface
+importText.XML.HXT.Arrow.XmlArrow
+
+importText.XML.HXT.Arrow.Edit
+(addHeadlineToXmlDoc
+,treeRepOfXmlDoc
+,indentDoc
+)
+
+importData.Maybe
+
+importNetwork.URI
+(URI
+,escapeURIChar
+,isUnescapedInURI
+,nonStrictRelativeTo
+,parseURIReference
+,uriAuthority
+,uriFragment
+,uriPath
+,uriPort
+,uriQuery
+,uriRegName
+,uriScheme
+,uriUserInfo
+)
+
+importSystem.IO
+(hPutStrLn
+,hFlush
+,stderr
+)
+
+importSystem.Directory
+(getCurrentDirectory
+)
+
+-- ------------------------------------------------------------
+{- $datatypes -}
+
+
+-- |
+-- predefined system state data type with all components for the
+-- system functions, like trace, error handling, ...
+
+dataXIOSysState=XIOSys{xio_trace::!Int
+,xio_errorStatus::!Int
+,xio_errorModule::!String
+,xio_errorMsgHandler::String->IO()
+,xio_errorMsgCollect::!Bool
+,xio_errorMsgList::!XmlTrees
+,xio_baseURI::!String
+,xio_defaultBaseURI::!String
+,xio_attrList::!(AssocListStringXmlTrees)
+}
+
+instanceDeepSeqXIOSysStatewhere
+deepSeq(XIOSystresememhemcemlbudual)y
+=deepSeqtr$deepSeqes$deepSeqem$deepSeqemh$deepSeqemc$deepSeqeml$deepSeqbu$deepSeqdu$deepSeqaly
+
+-- |
+-- state datatype consists of a system state and a user state
+-- the user state is not fixed
+
+dataXIOStateus=XIOState{xio_sysState::!XIOSysState
+,xio_userState::!us
+}
+
+instance(DeepSequs)=>DeepSeq(XIOStateus)where
+deepSeq(XIOStatesysusr)y=deepSeqsys$deepSequsry
+
+-- |
+-- The arrow type for stateful arrows
+
+typeIOStateArrowsbc=IOSLA(XIOStates)bc
+
+-- |
+-- The arrow for stateful arrows with no user defined state
+
+typeIOSArrowbc=IOStateArrow()bc
+
+-- ------------------------------------------------------------
+
+
+-- | the default global state, used as initial state when running an 'IOSArrow' with 'runIOSLA' or
+-- 'runX'
+
+initialState::us->XIOStateus
+initialStates=XIOState{xio_sysState=initialSysState
+,xio_userState=s
+}
+
+initialSysState::XIOSysState
+initialSysState=XIOSys{xio_trace=0
+,xio_errorStatus=c_ok
+,xio_errorModule=""
+,xio_errorMsgHandler=hPutStrLnstderr
+,xio_errorMsgCollect=False
+,xio_errorMsgList=[]
+,xio_baseURI=""
+,xio_defaultBaseURI=""
+,xio_attrList=[]
+}
+
+-- ------------------------------------------------------------
+
+-- |
+-- apply an 'IOSArrow' to an empty root node with 'initialState' () as initial state
+--
+-- the main entry point for running a state arrow with IO
+--
+-- when running @ runX f@ an empty XML root node is applied to @f@.
+-- usually @f@ will start with a constant arrow (ignoring the input), e.g. a 'Text.XML.HXT.Arrow.ReadDocument.readDocument' arrow.
+--
+-- for usage see examples with 'Text.XML.HXT.Arrow.WriteDocument.writeDocument'
+--
+-- if input has to be feed into the arrow use 'Control.Arrow.IOStateListArrow.runIOSLA' like in @ runIOSLA f emptyX inputDoc @
+
+runX::IOSArrowXmlTreec->IO[c]
+runX=runXIOState(initialState())
+
+runXIOState::XIOStates->IOStateArrowsXmlTreec->IO[c]
+runXIOStates0f
+=do
+(_finalState,res)<-runIOSLA(emptyRoot>>>f)s0undefined
+returnres
+where
+emptyRoot=root[][]
+
+-- ------------------------------------------------------------
+
+{- user state -}
+
+-- | read the user defined part of the state
+
+getUserState::IOStateArrowsbs
+getUserState
+=IOSLA$\s_->
+return(s,[xio_userStates])
+
+-- | change the user defined part of the state
+
+changeUserState::(b->s->s)->IOStateArrowsbb
+changeUserStatecf
+=IOSLA$\sv->
+lets'=s{xio_userState=cfv(xio_userStates)}
+inreturn(s',[v])
+
+-- | set the user defined part of the state
+
+setUserState::IOStateArrowsss
+setUserState
+=changeUserStateconst
+
+-- | extend user state
+--
+-- Run an arrow with an extended user state component, The old component
+-- is stored together with a new one in a pair, the arrow is executed with this
+-- extended state, and the augmented state component is removed form the state
+-- when the arrow has finished its execution
+
+withExtendedUserState::s1->IOStateArrow(s1,s0)bc->IOStateArrows0bc
+withExtendedUserStateinitS1f
+=IOSLA$\s0x->
+do
+~(finalS,res)<-runIOSLAf(XIOState{xio_sysState=xio_sysStates0
+,xio_userState=(initS1,xio_userStates0)
+}
+)x
+return(XIOState{xio_sysState=xio_sysStatefinalS
+,xio_userState=snd(xio_userStatefinalS)
+}
+,res
+)
+
+-- | change the type of user state
+--
+-- This conversion is useful, when running a state arrow with another
+-- structure of the user state, e.g. with () when executing some IO arrows
+
+withOtherUserState::s1->IOStateArrows1bc->IOStateArrows0bc
+withOtherUserStates1f
+=IOSLA$\sx->
+do
+(s',res)<-runIOSLAf(XIOState{xio_sysState=xio_sysStates
+,xio_userState=s1
+}
+)x
+return(XIOState{xio_sysState=xio_sysStates'
+,xio_userState=xio_userStates
+}
+,res
+)
+
+-- ------------------------------------------------------------
+
+{- $system state params -}
+
+getSysParam::(XIOSysState->c)->IOStateArrowsbc
+getSysParamf
+=IOSLA$\s_x->
+return(s,(:[]).f.xio_sysState$s)
+
+changeSysParam::(b->XIOSysState->XIOSysState)->IOStateArrowsbb
+changeSysParamcf
+=(IOSLA$\sv->
+lets'=changeSysState(cfv)s
+inreturn(s',[v])
+)
+where
+changeSysStatecsss=s{xio_sysState=css(xio_sysStates)}
+
+-- | store a single XML tree in global state under a given attribute name
+
+setParam::String->IOStateArrowsXmlTreeXmlTree
+setParamn
+=(:[])^>>setParamListn
+
+-- | store a list of XML trees in global system state under a given attribute name
+
+setParamList::String->IOStateArrowsXmlTreesXmlTree
+setParamListn
+=changeSysParamaddE
+>>>
+arrLid
+where
+addExs=s{xio_attrList=addEntrynx(xio_attrLists)}
+
+-- | remove an entry in global state, arrow input remains unchanged
+
+unsetParam::String->IOStateArrowsbb
+unsetParamn
+=changeSysParamdelE
+where
+delE_s=s{xio_attrList=delEntryn(xio_attrLists)}
+
+-- | read an attribute value from global state
+
+getParam::String->IOStateArrowsbXmlTree
+getParamn
+=getAllParams
+>>>
+arrL(lookup1n)
+
+-- | read all attributes from global state
+
+getAllParams::IOStateArrowsb(AssocListStringXmlTrees)
+getAllParams
+=getSysParamxio_attrList
+
+setParamString::String->String->IOStateArrowsbb
+setParamStringnv
+=perform(txtv
+>>>
+setParamn
+)
+
+-- | read a string value from global state,
+-- if parameter not set \"\" is returned
+
+getParamString::String->IOStateArrowsbString
+getParamStringn
+=xshow(getParamn)
+
+-- | store an int value in global state
+
+setParamInt::String->Int->IOStateArrowsbb
+setParamIntnv
+=setParamStringn(showv)
+
+-- | read an int value from global state
+--
+-- > getParamInt 0 myIntAttr
+
+getParamInt::Int->String->IOStateArrowsbInt
+getParamIntdefn
+=getParamStringn
+>>^
+(\x->ifnullxthendefelsereadx)
+
+-- ------------------------------------------------------------
+
+-- | reset global error variable
+
+changeErrorStatus::(Int->Int->Int)->IOStateArrowsIntInt
+changeErrorStatusf
+=changeSysParam(\ls->s{xio_errorStatus=fl(xio_errorStatuss)})
+
+clearErrStatus::IOStateArrowsbb
+clearErrStatus
+=perform(constA0>>>changeErrorStatusmin)
+
+-- | set global error variable
+
+setErrStatus::IOStateArrowsIntInt
+setErrStatus
+=changeErrorStatusmax
+
+-- | read current global error status
+
+getErrStatus::IOStateArrowsXmlTreeInt
+getErrStatus
+=getSysParamxio_errorStatus
+
+-- | raise the global error status level to that of the input tree
+
+setErrMsgStatus::IOStateArrowsXmlTreeXmlTree
+setErrMsgStatus
+=perform(getErrorLevel
+>>>
+setErrStatus
+)
+
+-- | set the error message handler and the flag for collecting the errors
+
+setErrorMsgHandler::Bool->(String->IO())->IOStateArrowsbb
+setErrorMsgHandlercf
+=changeSysParamcf
+where
+cf_s=s{xio_errorMsgHandler=f
+,xio_errorMsgCollect=c}
+
+-- | error message handler for output to stderr
+
+sysErrorMsg::IOStateArrowsXmlTreeXmlTree
+sysErrorMsg
+=perform(getErrorLevel&&&getErrorMsg
+>>>
+arrformatErrorMsg
+>>>
+(IOSLA$\se->
+do
+(xio_errorMsgHandler.xio_sysState$s)e
+return(s,undefined)
+)
+)
+where
+formatErrorMsg(level,msg)="\n"++errClasslevel++": "++msg
+errClassl
+=fromMaybe"fatal error".lookupl$msgList
+where
+msgList=[(c_ok,"no error")
+,(c_warn,"warning")
+,(c_err,"error")
+,(c_fatal,"fatal error")
+]
+
+
+-- | the default error message handler: error output to stderr
+
+errorMsgStderr::IOStateArrowsbb
+errorMsgStderr=setErrorMsgHandlerFalse(hPutStrLnstderr)
+
+-- | error message handler for collecting errors
+
+errorMsgCollect::IOStateArrowsbb
+errorMsgCollect=setErrorMsgHandlerTrue(const$return())
+
+-- | error message handler for output to stderr and collecting
+
+errorMsgStderrAndCollect::IOStateArrowsbb
+errorMsgStderrAndCollect=setErrorMsgHandlerTrue(hPutStrLnstderr)
+
+-- | error message handler for ignoring errors
+
+errorMsgIgnore::IOStateArrowsbb
+errorMsgIgnore=setErrorMsgHandlerFalse(const$return())
+
+-- |
+-- if error messages are collected by the error handler for
+-- processing these messages by the calling application,
+-- this arrow reads the stored messages and clears the error message store
+
+getErrorMessages::IOStateArrowsbXmlTree
+getErrorMessages
+=getSysParam(reverse.xio_errorMsgList)-- reverse the list of errors
+>>>
+clearErrorMsgList-- clear the error list in the system state
+>>>
+arrLid
+
+clearErrorMsgList::IOStateArrowsbb
+clearErrorMsgList
+=changeSysParam(\_s->s{xio_errorMsgList=[]})
+
+addToErrorMsgList::IOStateArrowsXmlTreeXmlTree
+addToErrorMsgList
+=changeSysParamcf
+where
+cfts=ifxio_errorMsgCollects
+thens{xio_errorMsgList=t:xio_errorMsgLists}
+elses
+
+-- ------------------------------------------------------------
+
+-- |
+-- filter error messages from input trees and issue errors
+
+filterErrorMsg::IOStateArrowsXmlTreeXmlTree
+filterErrorMsg
+=(setErrMsgStatus
+>>>
+sysErrorMsg
+>>>
+addToErrorMsgList
+>>>
+none
+)
+`when`
+isError
+
+-- | generate a warnig message
+
+issueWarn::String->IOStateArrowsbb
+issueWarnmsg=perform(warnmsg>>>filterErrorMsg)
+
+-- | generate an error message
+issueErr::String->IOStateArrowsbb
+issueErrmsg=perform(errmsg>>>filterErrorMsg)
+
+-- | generate a fatal error message, e.g. document not found
+
+issueFatal::String->IOStateArrowsbb
+issueFatalmsg=perform(fatalmsg>>>filterErrorMsg)
+
+-- |
+-- 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'.
+-- called by 'setDocumentStatusFromSystemState' when the system state indicates an error
+
+setDocumentStatus::Int->String->IOStateArrowsXmlTreeXmlTree
+setDocumentStatuslevelmsg
+=(addAttrl(sattra_status(showlevel)
+<+>
+sattra_modulemsg
+)
+>>>
+(iflevel>=c_err
+thensetChildren[]
+elsethis
+)
+)
+`when`
+isRoot
+
+-- |
+-- 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 the module name where the error occured and the error level are added as attributes with 'setDocumentStatus'
+-- else nothing is changed
+
+setDocumentStatusFromSystemState::String->IOStateArrowsXmlTreeXmlTree
+setDocumentStatusFromSystemStatemsg
+=setStatus$<getErrStatus
+where
+setStatuslevel
+|level<=c_warn=this
+|otherwise=setDocumentStatuslevelmsg
+
+
+-- |
+-- check whether tree is a document root and the status attribute has a value less than 'c_err'
+
+documentStatusOk::ArrowXmla=>aXmlTreeXmlTree
+documentStatusOk
+=isRoot
+>>>
+((getAttrValuea_status
+>>>
+isA(\v->nullv||((readv)::Int)<=c_warn)
+)
+`guards`
+this
+)
+
+-- ------------------------------------------------------------
+
+-- | set the base URI of a document, used e.g. for reading includes, e.g. external entities,
+-- the input must be an absolute URI
+
+setBaseURI::IOStateArrowsStringString
+setBaseURI
+=changeSysParam(\bs->s{xio_baseURI=b})
+>>>
+traceString2(("setBaseURI: new base URI is "++).show)
+
+-- | read the base URI from the globale state
+
+getBaseURI::IOStateArrowsbString
+getBaseURI
+=getSysParamxio_baseURI
+>>>
+((getDefaultBaseURI
+>>>
+setBaseURI
+>>>
+getBaseURI
+)
+`when`
+isAnull-- set and get it, if not yet done
+)
+
+-- | change the base URI with a possibly relative URI, can be used for
+-- evaluating the xml:base attribute. Returns the new absolute base URI.
+-- Fails, if input is not parsable with parseURIReference
+--
+-- see also: 'setBaseURI', 'mkAbsURI'
+
+changeBaseURI::IOStateArrowsStringString
+changeBaseURI
+=mkAbsURI
+>>>
+setBaseURI
+
+-- | set the default base URI, if parameter is null, the system base (@ file:\/\/\/\<cwd\>\/ @) is used,
+-- else the parameter, must be called before any document is read
+
+setDefaultBaseURI::String->IOStateArrowsbString
+setDefaultBaseURIbase
+=(ifnullbase
+thenarrIOgetDir
+elseconstAbase
+)
+>>>
+changeSysParam(\bs->s{xio_defaultBaseURI=b})
+>>>
+traceString2(("setDefaultBaseURI: new default base URI is "++).show)
+where
+getDir_=do
+cwd<-getCurrentDirectory
+return("file://"++normalizecwd++"/")
+
+-- 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
+
+
+-- | get the default base URI
+
+getDefaultBaseURI::IOStateArrowsbString
+getDefaultBaseURI
+=getSysParamxio_defaultBaseURI-- read default uri in system state
+>>>
+(setDefaultBaseURI""-- set the default uri in system state
+>>>
+getDefaultBaseURI)`when`isAnull-- when uri not yet set
+
+-- ------------------------------------------------------------
+
+-- | remember base uri, run an arrow and restore the base URI, used with external entity substitution
+
+runInLocalURIContext::IOStateArrowsbc->IOStateArrowsbc
+runInLocalURIContextf
+=(getBaseURI&&&this)
+>>>
+(this***listAf)
+>>>
+(setBaseURI***this)
+>>>
+arrLsnd
+
+-- ------------------------------------------------------------
+
+-- | set the global trace level
+
+setTraceLevel::Int->IOStateArrowsbb
+setTraceLevell
+=changeSysParam(\_s->s{xio_trace=l})
+
+-- | read the global trace level
+
+getTraceLevel::IOStateArrowsbInt
+getTraceLevel
+=getSysParamxio_trace
+
+-- | run an arrow with a given trace level, the old trace level is restored after the arrow execution
+
+withTraceLevel::Int->IOStateArrowsbc->IOStateArrowsbc
+withTraceLevellevelf
+=(getTraceLevel&&&this)
+>>>
+(setTraceLevellevel***listAf)
+>>>
+(restoreTraceLevel***this)
+>>>
+arrLsnd
+where
+restoreTraceLevel::IOStateArrowsIntInt
+restoreTraceLevel
+=setTraceLevel$<this
+
+-- | apply a trace arrow and issue message to stderr
+
+trace::Int->IOStateArrowsbString->IOStateArrowsbb
+traceleveltrc
+=perform(trc
+>>>
+arrIO(\s->(do
+hPutStrLnstderrs
+hFlushstderr
+)
+)
+)
+`when`(getTraceLevel
+>>>
+isA(>=level)
+)
+
+-- | issue a string message as trace
+traceMsg::Int->String->IOStateArrowsbb
+traceMsglevelmsg
+=perform(tracelevel$
+constA('-':"- ("++showlevel++") "++msg)
+)
+
+-- | issue the string input of an arrow
+traceString::Int->(String->String)->IOStateArrowsStringString
+traceStringlevelf
+=perform(applyA(arrf>>>arr(traceMsglevel)))
+
+-- | issue the source representation of a document if trace level >= 3
+--
+-- for better readability the source is formated with indentDoc
+
+traceSource::IOStateArrowsXmlTreeXmlTree
+traceSource
+=trace3$
+xshow
+(choiceA[isRoot:->(indentDoc
+>>>
+getChildren
+)
+,isElem:->(root[][this]
+>>>indentDoc
+>>>getChildren
+>>>isElem
+)
+,this:->this
+]
+)
+
+-- | issue the tree representation of a document if trace level >= 4
+traceTree::IOStateArrowsXmlTreeXmlTree
+traceTree
+=trace4$
+xshow(treeRepOfXmlDoc
+>>>
+addHeadlineToXmlDoc
+>>>
+getChildren
+)
+
+-- | trace a main computation step
+-- issue a message when trace level >= 1, issue document source if level >= 3, issue tree when level is >= 4
+
+traceDoc::String->IOStateArrowsXmlTreeXmlTree
+traceDocmsg
+=traceMsg1msg
+>>>
+traceSource
+>>>
+traceTree
+
+-- | trace the global state
+
+traceState::IOStateArrowsbb
+traceState
+=perform(xshow((getAllParams>>.concat)
+>>>
+applyA(arrformatParam)
+)
+>>>
+traceString2("global state:\n"++)
+)
+where
+-- formatParam :: (String, XmlTrees) -> IOStateArrow s b1 XmlTree
+formatParam(n,v)
+=mkelem"param"[sattr"name"n][arrL(constv)]<+>txt"\n"
+
+-- ----------------------------------------------------------
+
+-- | compute the absolut URI for a given URI and a base URI
+
+expandURIString::String->String->MaybeString
+expandURIStringuribase
+=do
+base'<-parseURIReferencebase
+uri'<-parseURIReferenceuri
+abs'<-nonStrictRelativeTouri'base'
+return$showabs'
+
+-- | arrow variant of 'expandURIString', fails if 'expandURIString' returns Nothing
+
+expandURI::ArrowXmla=>a(String,String)String
+expandURI
+=arrL(maybeToList.uncurryexpandURIString)
+
+-- | arrow for expanding an input URI into an absolute URI using global base URI, fails if input is not a legal URI
+
+mkAbsURI::IOStateArrowsStringString
+mkAbsURI
+=(this&&&getBaseURI)>>>expandURI
+
+-- | arrow for selecting the scheme (protocol) of the URI, fails if input is not a legal URI.
+--
+-- See Network.URI for URI components
+
+getSchemeFromURI::ArrowLista=>aStringString
+getSchemeFromURI=getPartFromURIscheme
+where
+scheme=init.uriScheme
+
+-- | arrow for selecting the registered name (host) of the URI, fails if input is not a legal URI
+
+getRegNameFromURI::ArrowLista=>aStringString
+getRegNameFromURI=getPartFromURIhost
+where
+host=maybe""uriRegName.uriAuthority
+
+-- | arrow for selecting the port number of the URI without leading \':\', fails if input is not a legal URI
+
+getPortFromURI::ArrowLista=>aStringString
+getPortFromURI=getPartFromURIport
+where
+port=dropWhile(==':').maybe""uriPort.uriAuthority
+
+-- | arrow for selecting the user info of the URI without trailing \'\@\', fails if input is not a legal URI
+
+getUserInfoFromURI::ArrowLista=>aStringString
+getUserInfoFromURI=getPartFromURIui
+where
+ui=reverse.dropWhile(=='@').reverse.maybe""uriUserInfo.uriAuthority
+
+-- | arrow for computing the path component of an URI, fails if input is not a legal URI
+
+getPathFromURI::ArrowLista=>aStringString
+getPathFromURI=getPartFromURIuriPath
+
+-- | arrow for computing the query component of an URI, fails if input is not a legal URI
+
+getQueryFromURI::ArrowLista=>aStringString
+getQueryFromURI=getPartFromURIuriQuery
+
+-- | arrow for computing the fragment component of an URI, fails if input is not a legal URI
+
+getFragmentFromURI::ArrowLista=>aStringString
+getFragmentFromURI=getPartFromURIuriFragment
+
+-- | arrow for computing the path component of an URI, fails if input is not a legal URI
+
+getPartFromURI::ArrowLista=>(URI->String)->aStringString
+getPartFromURIsel
+=arrL(maybeToList.getPart)
+where
+getParts=do
+uri<-parseURIReferences
+return(seluri)
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.Arrow.XmlRegex
+ Copyright : Copyright (C) 2008 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ Regular Expression Matcher working on lists of XmlTrees
+
+ It's intendet to import this module with an explicit
+ import declaration for not spoiling the namespace
+ with these somewhat special arrows
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.Arrow.XmlRegex
+(XmlRegex
+,mkZero
+,mkUnit
+,mkPrim
+,mkPrimA
+,mkDot
+,mkStar
+,mkAlt
+,mkSeq
+,mkRep
+,mkRng
+,mkOpt
+,nullable
+,delta
+,matchXmlRegex
+,splitXmlRegex
+,scanXmlRegex
+,matchRegexA
+,splitRegexA
+,scanRegexA
+)
+where
+
+importControl.Arrow.ListArrows
+
+importData.Maybe
+
+importText.XML.HXT.DOM.Interface
+
+-- ------------------------------------------------------------
+-- the exported regex arrows
+
+-- | check whether a sequence of XmlTrees match an Xml regular expression
+--
+-- The arrow for 'matchXmlRegex'.
+--
+-- The expession is build up from simple arrows acting as predicate ('mkPrimA') for
+-- an XmlTree and of the usual cobinators for sequence ('mkSeq'), repetition
+-- ('mkStar', mkRep', 'mkRng') and choice ('mkAlt', 'mkOpt')
+
+matchRegexA::XmlRegex->LAXmlTreeXmlTree->LAXmlTreeXmlTrees
+matchRegexArets=ts>>.(\s->maybe[](const[s]).matchXmlRegexre$s)
+
+-- | split the sequence of trees computed by the filter a into
+--
+-- The arrow for 'splitXmlRegex'.
+--
+-- a first part matching the regex and a rest,
+-- if a prefix of the input sequence does not match the regex, the arrow fails
+-- else the pair containing the result lists is returned
+
+splitRegexA::XmlRegex->LAXmlTreeXmlTree->LAXmlTree(XmlTrees,XmlTrees)
+splitRegexArets=ts>>.(maybeToList.splitXmlRegexre)
+
+-- | scan the input sequence with a regex and give the result as a list of lists of trees back
+-- the regex must at least match one input tree, so the empty sequence should not match the regex
+--
+-- The arrow for 'scanXmlRegex'.
+
+scanRegexA::XmlRegex->LAXmlTreeXmlTree->LAXmlTreeXmlTrees
+scanRegexArets=ts>>.(fromMaybe[].scanXmlRegexre)
+
+-- ------------------------------------------------------------
+
+dataXmlRegex=ZeroString
+|Unit
+|Sym(XmlTree->Bool)
+|Dot
+|StarXmlRegex
+|AltXmlRegexXmlRegex
+|SeqXmlRegexXmlRegex
+|RepIntXmlRegex-- 1 or more repetitions
+|RngIntIntXmlRegex-- n..m repetitions
+
+-- ------------------------------------------------------------
+
+{- just for documentation
+
+class Inv a where
+ inv :: a -> Bool
+
+instance Inv XmlRegex where
+ inv (Zero _) = True
+ inv Unit = True
+ inv (Sym p) = p holds for some XmlTrees
+ inv Dot = True
+ inv (Star e) = inv e
+ inv (Alt e1 e2) = inv e1 &&
+ inv e2
+ inv (Seq e1 e2) = inv e1 &&
+ inv e2
+ inv (Rep i e) = i > 0 && inv e
+ inv (Rng i j e) = (i < j || (i == j && i > 1)) &&
+ inv e
+-}
+-- ------------------------------------------------------------
+--
+-- smart constructors
+
+mkZero::String->XmlRegex
+mkZero=Zero
+
+mkUnit::XmlRegex
+mkUnit=Unit
+
+mkPrim::(XmlTree->Bool)->XmlRegex
+mkPrim=Sym
+
+mkPrimA::LAXmlTreeXmlTree->XmlRegex
+mkPrimAa=mkPrim(not.null.runLAa)
+
+mkDot::XmlRegex
+mkDot=Dot
+
+mkStar::XmlRegex->XmlRegex
+mkStar(Zero_)=mkUnit-- {}* == ()
+mkStare@Unit=e-- ()* == ()
+mkStare@(Star_e1)=e-- (r*)* == r*
+mkStar(Rep1e1)=mkStare1-- (r+)* == r*
+mkStare@(Alt__)=Star(rmStare)-- (a*|b)* == (a|b)*
+mkStare=Stare
+
+rmStar::XmlRegex->XmlRegex
+rmStar(Alte1e2)=mkAlt(rmStare1)(rmStare2)
+rmStar(Stare1)=rmStare1
+rmStar(Rep1e1)=rmStare1
+rmStare1=e1
+
+mkAlt::XmlRegex->XmlRegex->XmlRegex
+mkAlte1(Zero_)=e1-- e1 u {} = e1
+mkAlt(Zero_)e2=e2-- {} u e2 = e2
+mkAlte1@(StarDot)_e2=e1-- A* u e1 = A*
+mkAlt_e1e2@(StarDot)=e2-- e1 u A* = A*
+mkAlt(Symp1)(Symp2)=mkPrim$\x->p1x||p2x-- melting of predicates
+mkAlte1e2@(Sym_)=mkAlte2e1-- symmetry: predicates always first
+mkAlte1@(Sym_)(Alte2@(Sym_)e3)=mkAlt(mkAlte1e2)e3-- prepare melting of predicates
+mkAlt(Alte1e2)e3=mkAlte1(mkAlte2e3)-- associativity
+mkAlte1e2=Alte1e2
+
+mkSeq::XmlRegex->XmlRegex->XmlRegex
+mkSeqe1@(Zero_)_e2=e1
+mkSeq_e1e2@(Zero_)=e2
+mkSeqUnite2=e2
+mkSeqe1Unit=e1
+mkSeq(Seqe1e2)e3=mkSeqe1(mkSeqe2e3)
+mkSeqe1e2=Seqe1e2
+
+mkRep::Int->XmlRegex->XmlRegex
+mkRep0e=mkStare
+mkRep_e@(Zero_)=e
+mkRep_e@Unit=e
+mkRepie=Repie
+
+mkRng::Int->Int->XmlRegex->XmlRegex
+mkRng00_e=mkUnit
+mkRng11e=e
+mkRnglbub_e
+|lb>ub=Zero$
+"illegal range "++
+showlb++".."++showub
+mkRng_l_ue@(Zero_)=e
+mkRng_l_ue@Unit=e
+mkRnglbube=Rnglbube
+
+mkOpt::XmlRegex->XmlRegex
+mkOpt=mkRng01
+
+-- ------------------------------------------------------------
+
+instanceShowXmlRegexwhere
+show(Zeros)="{err:"++s++"}"
+showUnit="()"
+show(Sym_p)="{single tree pred}"
+showDot="."
+show(Stare)="("++showe++")*"
+show(Alte1e2)="("++showe1++"|"++showe2++")"
+show(Seqe1e2)=showe1++showe2
+show(Rep1e)="("++showe++")+"
+show(Repie)="("++showe++"){"++showi++",}"
+show(Rng01e)="("++showe++")?"
+show(Rngije)="("++showe++"){"++showi++","++showj++"}"
+
+-- ------------------------------------------------------------
+
+nullable::XmlRegex->Bool
+nullable(Zero_)=False
+nullableUnit=True
+nullable(Sym_p)=False-- assumption: p holds for at least one tree
+nullableDot=False
+nullable(Star_)=True
+nullable(Alte1e2)=nullablee1||
+nullablee2
+nullable(Seqe1e2)=nullablee1&&
+nullablee2
+nullable(Rep_ie)=nullablee
+nullable(Rngi_e)=i==0||
+nullablee
+
+-- ------------------------------------------------------------
+
+delta::XmlRegex->XmlTree->XmlRegex
+deltae@(Zero_)_=e
+deltaUnitc=mkZero$
+"unexpected char "++showc
+delta(Symp)c
+|pc=mkUnit
+|otherwise=mkZero$
+"unexpected tree "++showc
+deltaDot_=mkUnit
+deltae@(Stare1)c=mkSeq(deltae1c)e
+delta(Alte1e2)c=mkAlt(deltae1c)(deltae2c)
+delta(Seqe1e2)c
+|nullablee1=mkAlt(mkSeq(deltae1c)e2)(deltae2c)
+|otherwise=mkSeq(deltae1c)e2
+delta(Repie)c=mkSeq(deltaec)(mkRep(i-1)e)
+delta(Rngije)c=mkSeq(deltaec)(mkRng((i-1)`max`0)(j-1)e)
+
+-- ------------------------------------------------------------
+
+delta'::XmlRegex->XmlTrees->XmlRegex
+delta'=foldldelta
+
+-- | match a sequence of XML trees with a regular expression over trees
+--
+-- If the input matches, the result is Nothing, else Just an error message is returned
+
+matchXmlRegex::XmlRegex->XmlTrees->MaybeString
+matchXmlRegexe
+=res.delta'e
+where
+res(Zeroer)=Juster
+resre
+|nullablere=Nothing-- o.k.
+|otherwise=Just$"input does not match "++showe
+
+-- ------------------------------------------------------------
+
+-- | split a sequence of XML trees into a pair of a a matching prefix and a rest
+--
+-- If there is no matching prefix, Nothing is returned
+
+splitXmlRegex::XmlRegex->XmlTrees->Maybe(XmlTrees,XmlTrees)
+splitXmlRegexre=splitXmlRegex're[]
+
+splitXmlRegex'::XmlRegex->XmlTrees->XmlTrees->Maybe(XmlTrees,XmlTrees)
+splitXmlRegex'reres[]
+|nullablere=Just(reverseres,[])
+|otherwise=Nothing
+
+splitXmlRegex'(Zero_)__
+=Nothing
+
+splitXmlRegex'reresxs@(x:xs')
+|isJustres'=res'
+|nullablere=Just(reverseres,xs)
+|otherwise=Nothing
+where
+re'=deltarex
+res'=splitXmlRegex're'(x:res)xs'
+
+-- ------------------------------------------------------------
+
+-- | scan a sequence of XML trees and split it into parts matching the given regex
+--
+-- If the parts cannot be split because of a missing match, or because of the
+-- empty sequence as match, Nothing is returned
+
+scanXmlRegex::XmlRegex->XmlTrees->Maybe[XmlTrees]
+scanXmlRegexrets=scanXmlRegex're(splitXmlRegexrets)
+
+scanXmlRegex'::XmlRegex->Maybe(XmlTrees,XmlTrees)->Maybe[XmlTrees]
+scanXmlRegex'_Nothing=Nothing
+scanXmlRegex'_(Just(rs,[]))=Just[rs]
+scanXmlRegex'_(Just([],_))=Nothing-- re is nullable (the empty word matches), nothing split off
+-- would give infinite list of empty lists
+scanXmlRegex're(Just(rs,rest))
+|isNothingres=Nothing
+|otherwise=Just(rs:fromJustres)
+where
+res=scanXmlRegex're(splitXmlRegexrerest)
+
+-- ------------------------------------------------------------
+
-- |
+-- Namespace filter
+--
+-- $Id: NamespaceFilter.hs,v 1.4 2006/11/12 14:53:00 hxml Exp $
+--
+-- 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
+
+-- -----------------------------------------------------------------------------
+
-- |
+-- basic Namespace and QName predicates and functions
+--
+-- $Id: NamespacePredicates.hs,v 1.3 2006/11/12 14:53:00 hxml Exp $
+--
+
+moduleText.XML.HXT.DOM.NamespacePredicates
+(moduleText.XML.HXT.DOM.NamespacePredicates
+)
+where
+
+importText.XML.HXT.DOM.XmlTreeTypes-- NTree and XNode types
+importText.XML.HXT.DOM.XmlKeywords-- keywords for DTD
+
+importText.XML.HXT.DOM.Unicode
+(isXmlNCNameStartChar
+,isXmlNCNameChar
+)
+
+-- -----------------------------------------------------------------------------
+--
+
+-- |
+-- Compute the name prefix and the namespace uri for a qualified name.
+--
+-- This function does not test whether the name is a wellformed qualified name.
+-- see Namespaces in XML Rule [6] to [8]. Error checking is done with separate functions,
+-- see 'isWellformedQName' and 'isWellformedQualifiedName' for error checking.
+
+setNamespace::NsEnv->QName->QName
+setNamespacenstn
+=uncurryns.span(/=':')$qn
+where
+qn=qualifiedNamen-- using qualifiedName instead of localPart enables recomputing of setNamespace
+
+ns::String->String->QName
+nslp""-- no ":" found in name, use default namespace uri
+=mkQName""lp(lookup1""nst)
+
+nspx@(_:_)(':':lp@(_:_))-- non empty prefix and non empty local part found
+=mkQNamepxlp(lookup1pxnst)
+
+ns__-- not a legal qualified name, don't change name
+=n
+
+xmlnsQN::QName
+xmlnsQN=mkQName""a_xmlnsxmlnsNamespace
+
+-- -----------------------------------------------------------------------------
+--
+
+-- |
+-- test for wellformed NCName, rule [4] XML Namespaces
+
+isNCName::String->Bool
+isNCName[]
+=False
+isNCNamen
+=and(zipWith($)
+(isXmlNCNameStartChar:repeatisXmlNCNameChar)
+n
+)
+
+-- |
+-- test for wellformed QName, rule [6] XML Namespaces
+-- predicate is used in filter 'valdateNamespaces'.
+
+isWellformedQualifiedName::String->Bool
+isWellformedQualifiedNames
+|nulllp
+=isNCNamepx
+|otherwise
+=isNCNamepx&&isNCName(taillp)
+where
+(px,lp)=span(/=':')s
+
+-- |
+-- test for wellformed QName values.
+-- A QName is wellformed, if the local part is a NCName, the namePrefix, if not empty, is also a NCName.
+-- predicate is used in filter 'valdateNamespaces'.
+
+isWellformedQName::QName->Bool
+isWellformedQNamen
+=isNCNamelp-- rule [8] XML Namespaces
+&&
+(nullpx-- rule [6] XML Namespaces
+||
+isNCNamepx-- rule [7] XML Namespaces
+)
+where
+px=namePrefixn
+lp=localPartn
+
+-- |
+-- test for a wellformed namespace declaration
+-- all namespace prefixes starting with \"xml\" are reserved for XML related definitions.
+-- predicate is used in filter 'valdateNamespaces'.
+
+isWellformedNSDecl::QName->Bool
+isWellformedNSDecln
+=nullpx
+||
+px/=a_xmlns
+||
+(take3lp)/=a_xml
+where
+lp=localPartn
+px=namePrefixn
+
+-- |
+--
+-- predicate is used in filter 'valdateNamespaces'.
+
+isDeclaredNamespace::QName->Bool
+isDeclaredNamespacen
+|nullpx-- no namespace used
+=True
+|px==a_xmlns-- "xmlns" has a predefined namespace uri
+=ns==xmlnsNamespace
+|px==a_xml-- "xml" has a predefiend namespace"
+=ns==xmlNamespace
+|otherwise-- namespace values are not empty
+=(not.null)ns
+where
+px=namePrefixn
+ns=namespaceUrin
+
+-- -----------------------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.DOM.QualifiedName
+ Copyright : Copyright (C) 2008 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : stable
+ Portability: portable
+
+ The core data types of the HXT DOM.
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.DOM.QualifiedName
+(moduleText.XML.HXT.DOM.QualifiedName
+)
+
+where
+importControl.Strategies.DeepSeq
+
+importData.Char(toLower)
+importData.Typeable
+
+-- -----------------------------------------------------------------------------
+--
+-- |
+-- Namespace support for element and attribute names.
+--
+-- A qualified name consists of a name prefix, a local name
+-- and a namespace uri.
+-- All modules, which are not namespace aware, use only the 'localPart' component.
+-- When dealing with namespaces, the document tree must be processed by "propagateNamespaces"
+-- to split names of structure \"prefix:localPart\" and label the name with the apropriate namespace uri
+
+dataQName=QN{namePrefix::String-- ^ the name prefix part of a qualified name \"namePrefix:localPart\"
+,localPart::String-- ^ the local part of a qualified name \"namePrefix:localPart\"
+,namespaceUri::String-- ^ the associated namespace uri
+}
+deriving(Ord,Show,Read,Typeable)
+
+-- | Two QNames are equal if (1. case) namespaces are both empty and the qualified names
+-- (prefix:localpart) are the same or (2. case) namespaces are set and namespaces and
+-- local parts both are equal
+
+instanceEqQNamewhere
+q1==q2
+|nullns1&&nullns2
+=qualifiedNameq1==qualifiedNameq2
+|otherwise
+=localPartq1==localPartq2
+&&
+ns1==ns2
+where
+ns1=namespaceUriq1
+ns2=namespaceUriq2
+
+instanceDeepSeqQNamewhere
+deepSeq(QNnplpns)y=deepSeqnp$deepSeqlp$deepSeqnsy
+
+-- |
+-- builds the full name \"prefix:localPart\", if prefix is not null, else the local part is the result
+
+qualifiedName::QName->String
+qualifiedNamen
+|nullpx
+=lp
+|otherwise
+=px++(':':lp)
+where
+px=namePrefixn
+lp=localPartn
+
+-- |
+-- builds the \"universal\" name, that is the namespace uri surrounded with \"{\" and \"}\" followed by the local part
+-- (specialisation of 'buildUniversalName')
+
+universalName::QName->String
+universalName=buildUniversalName(\nslp->'{':ns++'}':lp)
+
+-- |
+-- builds an \"universal\" uri, that is the namespace uri followed by the local part. This is usefull for RDF applications,
+-- where the subject, predicate and object often are concatenated from namespace uri and local part
+-- (specialisation of 'buildUniversalName')
+
+universalUri::QName->String
+universalUri=buildUniversalName(++)
+
+-- |
+-- builds a string from the namespace uri and the local part. If the namespace uri is empty, the local part is returned, else
+-- namespace uri and local part are combined with the combining function given by the first parameter
+
+buildUniversalName::(String->String->String)->QName->String
+buildUniversalNamebfn
+|nullns
+=lp
+|otherwise
+=bfnslp
+where
+ns=namespaceUrin
+lp=localPartn
+
+-- |
+-- constructs a complete qualified name with 'namePrefix', 'localPart' and 'namespaceUri'.
+
+mkQName::String->String->String->QName
+mkQNamepln
+=QN{namePrefix=p
+,localPart=l
+,namespaceUri=n
+}
+
+-- |
+-- constructs a simple, namespace unaware name, 'namePrefix' and 'namespaceUri' are set to the empty string.
+
+mkName::String->QName
+mkNames
+=QN{namePrefix=""
+,localPart=s
+,namespaceUri=""
+}
+
+-- |
+-- constructs a simple name, with prefix and localPart but without a namespace uri.
+--
+-- see also 'mkName', 'mkNsName', 'mkSNsName'
+
+mkPrefixLocalPart::String->String->QName
+mkPrefixLocalPartpl
+=QN{namePrefix=p
+,localPart=l
+,namespaceUri=""
+}
+
+-- |
+-- constructs a simple, namespace aware name, with prefix:localPart as first parameter, namspace uri as second.
+--
+-- see also 'mkName', 'mkPrefixLocalPart'
+
+mkNsName::String->String->QName
+mkNsNamenns
+=QN{namePrefix=p
+,localPart=l
+,namespaceUri=ns
+}
+where
+(x1,x2)=span(/=':')n
+(p,l)
+|nullx2=("",x1)
+|otherwise=(x1,tailx2)
+
+
+-- |
+-- constructs a simple name, with prefix:localPart as 1 parameter, with empty namspace uri, same as 'mkPrefixLocalPart, but with a single parameter
+--
+-- see also 'mkNsName', 'mkPrefixLocalPart'
+
+mkSNsName::String->QName
+mkSNsNamen=mkNsNamen""
+
+-- | Empty QName
+
+nullQName::QName
+nullQName=QN""""""
+
+-- | Equality of QNames: Two QNames are equal, if the local parts are equal
+-- and the namespace URIs are equal.
+-- The comparison works with and without namespace propagation.
+-- If namespaces have been propagated, the name is split into prefix and local part
+-- and the namespace uri is set. In this case the prefix is not significant for equality test.
+-- If namespaces have not been propagated, the local part contains the full name, prefix
+-- and namespace URI are empty. The full name (prefix and local part) is used for comparison.
+
+equalQName::QName->QName->Bool
+equalQName=equalQNameBy(==)
+
+-- | Equivalent QNames are defined as follows: The URIs are normalized before comparison.
+-- Comparison is done with 'equalQNameBy' and 'equivUri'
+
+equivQName::QName->QName->Bool
+equivQName=equalQNameByequivUri
+
+-- | Comparison of normalized namespace URIs using 'normalizeNsUri'
+
+equivUri::String->String->Bool
+equivUrixy=normalizeNsUrix==normalizeNsUriy
+
+-- | Sometimes a weaker equality relation than 'equalQName' is appropriate, e.g no case significance in names, ...
+-- a name normalization function can be applied to the strings before comparing. Called by 'equalQName' and
+-- 'equivQName'
+
+equalQNameBy::(String->String->Bool)->QName->QName->Bool
+equalQNameByequivq1q2
+=localPartq1==localPartq2
+&&
+(namespaceUriq1`equiv`namespaceUriq2)
+
+-- | Normalization of URIs: Normalization is done by conversion into lowercase letters. A trailing \"\/\" is ignored
+
+normalizeNsUri::String->String
+normalizeNsUri
+=maptoLower.stripSlash
+where
+stripSlash""=""
+stripSlashs
+|lasts=='/'=inits
+|otherwise=s
+
+-- -----------------------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.DOM.TypeDefs
+ Copyright : Copyright (C) 2008 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : stable
+ Portability: portable
+
+ The core data types of the HXT DOM.
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.DOM.TypeDefs
+(moduleData.AssocList
+,moduleText.XML.HXT.DOM.TypeDefs
+,moduleText.XML.HXT.DOM.QualifiedName
+)
+
+where
+
+importControl.Strategies.DeepSeq
+
+importData.AssocList
+importData.Tree.NTree.TypeDefs
+importData.Typeable
+
+importText.XML.HXT.DOM.QualifiedNamehiding(QN)
+
+-- -----------------------------------------------------------------------------
+--
+-- Basic types for xml tree and filters
+
+-- | Node of xml tree representation
+
+typeXmlTree=NTreeXNode
+
+-- | List of nodes of xml tree representation
+
+typeXmlTrees=NTreesXNode
+
+-- -----------------------------------------------------------------------------
+--
+-- XNode
+
+-- | Represents elements
+
+dataXNode=XTextString-- ^ ordinary text (leaf)
+|XCharRefInt-- ^ character reference (leaf)
+|XEntityRefString-- ^ entity reference (leaf)
+|XCmtString-- ^ comment (leaf)
+|XCdataString-- ^ CDATA section (leaf)
+|XPiQNameXmlTrees-- ^ Processing Instr with qualified name (leaf)
+-- with list of attributes.
+-- If tag name is xml, attributs are \"version\", \"encoding\", \"standalone\",
+-- else attribute list is empty, content is a text child node
+|XTagQNameXmlTrees-- ^ tag with qualified name and list of attributes (inner node or leaf)
+|XDTDDTDElemAttributes-- ^ DTD element with assoc list for dtd element features
+|XAttrQName-- ^ attribute with qualified name, the attribute value is stored in children
+|XErrorIntString-- ^ error message with level and text
+deriving(Eq,Ord,Show,Read,Typeable)
+
+instanceDeepSeqXNodewhere
+deepSeq(XTexts)y=deepSeqsy
+deepSeq(XCharRefi)y=deepSeqiy
+deepSeq(XEntityRefn)y=deepSeqny
+deepSeq(XCmtc)y=deepSeqcy
+deepSeq(XCdatas)y=deepSeqsy
+deepSeq(XPiqnts)y=deepSeqqn$deepSeqtsy
+deepSeq(XTagqncs)y=deepSeqqn$deepSeqcsy
+deepSeq(XDTDdeal)y=deepSeqde$deepSeqaly
+deepSeq(XAttrqn)y=deepSeqqny
+deepSeq(XErrorne)y=deepSeqn$deepSeqey
+
+-- -----------------------------------------------------------------------------
+--
+-- DTDElem
+
+-- | Represents a DTD element
+
+dataDTDElem=DOCTYPE-- ^ attr: name, system, public, XDTD elems as children
+|ELEMENT-- ^ attr: name, kind
+--
+-- name: element name
+--
+-- kind: \"EMPTY\" | \"ANY\" | \"\#PCDATA\" | children | mixed
+|CONTENT-- ^ element content
+--
+-- attr: kind, modifier
+--
+-- modifier: \"\" | \"?\" | \"*\" | \"+\"
+--
+-- kind: seq | choice
+|ATTLIST-- ^ attributes:
+-- name - name of element
+--
+-- value - name of attribute
+--
+-- type: \"CDATA\" | \"ID\" | \"IDREF\" | \"IDREFS\" | \"ENTITY\" | \"ENTITIES\" |
+--
+-- \"NMTOKEN\" | \"NMTOKENS\" |\"NOTATION\" | \"ENUMTYPE\"
+--
+-- kind: \"#REQUIRED\" | \"#IMPLIED\" | \"DEFAULT\"
+|ENTITY-- ^ for entity declarations
+|PENTITY-- ^ for parameter entity declarations
+|NOTATION-- ^ for notations
+|CONDSECT-- ^ for INCLUDEs, IGNOREs and peRefs: attr: type
+--
+-- type = INCLUDE, IGNORE or %...;
+|NAME-- ^ attr: name
+--
+-- for lists of names in notation types or nmtokens in enumeration types
+|PEREF-- ^ for Parameter Entity References in DTDs
+deriving(Eq,Ord,Show,Read,Typeable)
+
+instanceDeepSeqDTDElem
+
+-- -----------------------------------------------------------------------------
+
+-- | Attribute list
+--
+-- used for storing option lists and features of DTD parts
+
+typeAttributes=AssocListStringString
+
+-- -----------------------------------------------------------------------------
+--
+
+-- |
+-- Type for the namespace association list, used when propagating namespaces by
+-- modifying the 'QName' values in a tree
+
+typeNsEnv=AssocListStringString
+
+-- -----------------------------------------------------------------------------
+--
+-- Constants for error levels
+
+-- | no error, everything is ok
+c_ok::Int
+c_ok=0
+
+-- | Error level for XError, type warning
+c_warn::Int
+c_warn=c_ok+1
+
+-- | Error level for XError, type error
+c_err::Int
+c_err=c_warn+1
+
+-- | Error level for XError, type fatal error
+c_fatal::Int
+c_fatal=c_err+1
+
+-- -----------------------------------------------------------------------------
+
+-- | data type for representing a set of nodes as a tree structure
+--
+-- this structure is e.g. used to repesent the result of an XPath query
+-- such that the selected nodes can be processed or selected later in
+-- processing a document tree
+
+dataXmlNodeSet=XNS{thisNode::Bool-- ^ is this node part of the set ?
+,attrNodes::[QName]-- ^ the set of attribute nodes
+,childNodes::ChildNodes-- ^ the set of child nodes, a list of pairs of index and node set
+}
+deriving(Eq,Show,Typeable)
+
+typeChildNodes=[(Int,XmlNodeSet)]
+
+-- -----------------------------------------------------------------------------
+
-- |
+-- Common useful options
+--
+-- Version : $Id: XmlOptions.hs,v 1.1 2006/11/09 20:27:42 hxml Exp $
+--
+--
+
+moduleText.XML.HXT.DOM.XmlOptions
+(inputOptions
+,relaxOptions
+,outputOptions
+,generalOptions
+,versionOptions
+,showOptions
+
+,selectOptions
+,removeOptions
+,optionIsSet
+)
+where
+
+importText.XML.HXT.DOM.XmlKeywords
+importText.XML.HXT.DOM.TypeDefs
+
+importData.Maybe
+
+importSystem.Console.GetOpt
+
+-- ------------------------------------------------------------
+--
+
+-- |
+-- commonly useful options for XML input
+--
+-- can be used for option definition with haskell getopt
+--
+-- defines options: 'a_trace', 'a_proxy', 'a_use_curl', 'a_do_not_use_curl', 'a_options_curl', 'a_encoding',
+-- 'a_issue_errors', 'a_do_not_issue_errors', 'a_parse_html', 'a_parse_by_mimetype', 'a_tagsoup' 'a_issue_warnings', 'a_do_not_issue_warnings',
+-- 'a_parse_xml', 'a_validate', 'a_do_not_validate', 'a_canonicalize', 'a_do_not_canonicalize',
+--- 'a_preserve_comment', 'a_do_not_preserve_comment', 'a_check_namespaces', 'a_do_not_check_namespaces',
+-- 'a_remove_whitespace', 'a_do_not_remove_whitespace'
+
+inputOptions::[OptDescr(String,String)]
+inputOptions
+=[Option"t"[a_trace](OptArgtrc"LEVEL")"trace level (0-4), default 1"
+,Option"p"[a_proxy](ReqArg(atta_proxy)"PROXY")"proxy for http access (e.g. \"www-cache:3128\")"
+,Option""[a_use_curl](NoArg(atta_use_curlv_1))"HTTP access via external program \"curl\", more functionality, supports HTTP/1.0, less efficient"
+,Option""[a_do_not_use_curl](NoArg(atta_use_curlv_0))"HTTP access via built in HTTP/1.1 module (default)"
+,Option""[a_options_curl](ReqArg(atta_options_curl)"STR")"additional curl options, e.g. for timeout, ..."
+,Option""[a_default_baseuri](ReqArg(atttransferURI)"URI")"default base URI, default: \"file:///<cwd>/\""
+,Option"e"[a_encoding](ReqArg(atta_encoding)"CHARSET")("default document encoding ("++utf8++", "++isoLatin1++", "++usAscii++", ...)")
+,Option""[a_issue_errors](NoArg(atta_issue_errorsv_1))"issue all errorr messages on stderr (default)"
+,Option""[a_do_not_issue_errors](NoArg(atta_issue_errorsv_0))"ignore all error messages"
+,Option"H"[a_parse_html](NoArg(atta_parse_htmlv_1))"parse input as HTML, try to interprete everything as HTML, no validation"
+,Option"M"[a_parse_by_mimetype](NoArg(atta_parse_by_mimetypev_1))"parse dependent on mime type: text/html as HTML, text/xml and text/xhtml as XML, else no parse"
+,Option"T"[a_tagsoup](NoArg(atta_tagsoupv_1))"lasy tagsoup parser, for HTML and XML, no DTD, no validation, no PIs, only XHTML entityrefs"
+,Option""[a_issue_warnings](NoArg(atta_issue_warningsv_1))"issue warnings, when parsing HTML (default)"
+,Option"Q"[a_do_not_issue_warnings](NoArg(atta_issue_warningsv_0))"ignore warnings, when parsing HTML"
+,Option""[a_parse_xml](NoArg(atta_parse_htmlv_0))"parse input as XML (default)"
+,Option""[a_validate](NoArg(atta_validatev_1))"document validation when parsing XML (default)"
+,Option"w"[a_do_not_validate](NoArg(atta_validatev_0))"only wellformed check, no validation"
+,Option""[a_canonicalize](NoArg(atta_canonicalizev_1))"canonicalize document, remove DTD, comment, transform CDATA, CharRef's, ... (default)"
+,Option"c"[a_do_not_canonicalize](NoArg(atta_canonicalizev_0))"do not canonicalize document, don't remove DTD, comment, don't transform CDATA, CharRef's, ..."
+,Option"C"[a_preserve_comment](NoArg(atta_preserve_commentv_1))"don't remove comments during canonicalisation"
+,Option""[a_do_not_preserve_comment](NoArg(atta_preserve_commentv_0))"remove comments during canonicalisation (default)"
+,Option"n"[a_check_namespaces](NoArg(atta_check_namespacesv_1))"tag tree with namespace information and check namespaces"
+,Option""[a_do_not_check_namespaces](NoArg(atta_check_namespacesv_0))"ignore namespaces (default)"
+,Option"r"[a_remove_whitespace](NoArg(atta_remove_whitespacev_1))"remove redundant whitespace, simplifies tree and processing"
+,Option""[a_do_not_remove_whitespace](NoArg(atta_remove_whitespacev_0))"don't remove redundant whitespace (default)"
+]
+where
+attnv=(n,v)
+trc=atta_trace.show.max0.min9.(read::String->Int).('0':).filter(`elem`"0123456789").fromMaybev_1
+
+
+-- | available Relax NG validation options
+--
+-- defines options
+-- 'a_check_restrictions', 'a_validate_externalRef', 'a_validate_include', 'a_do_not_check_restrictions',
+-- 'a_do_not_validate_externalRef', 'a_do_not_validate_include'
+
+relaxOptions::[OptDescr(String,String)]
+relaxOptions
+=[Option"X"[a_relax_schema](ReqArg(atta_relax_schema)"SCHEMA")"validation with Relax NG, SCHEMA is the URI for the Relax NG schema"
+,Option""[a_check_restrictions](NoArg(a_check_restrictions,v_1))"check Relax NG schema restrictions during schema simplification (default)"
+,Option""[a_do_not_check_restrictions](NoArg(a_check_restrictions,v_0))"do not check Relax NG schema restrictions"
+,Option""[a_validate_externalRef](NoArg(a_validate_externalRef,v_1))"validate a Relax NG schema referenced by a externalRef-Pattern (default)"
+,Option""[a_do_not_validate_externalRef](NoArg(a_validate_externalRef,v_0))"do not validate a Relax NG schema referenced by an externalRef-Pattern"
+,Option""[a_validate_include](NoArg(a_validate_include,v_1))"validate a Relax NG schema referenced by an include-Pattern (default)"
+,Option""[a_do_not_validate_include](NoArg(a_validate_include,v_0))"do not validate a Relax NG schema referenced by an include-Pattern"
+{-
+ , Option "" [a_output_changes] (NoArg (a_output_changes, v_1)) "output Pattern transformations in case of an error"
+ , Option "" [a_do_not_collect_errors] (NoArg (a_do_not_collect_errors, v_1)) "stop Relax NG simplification after the first error has occurred"
+ -}
+]
+where
+attnv=(n,v)
+
+-- |
+-- commonly useful options for XML output
+--
+-- defines options: 'a_indent', 'a_output_encoding', 'a_output_file', 'a_output_html'
+
+outputOptions::[OptDescr(String,String)]
+outputOptions
+=[Option"i"[a_indent](NoArg(atta_indentv_1))"indent XML output for readability"
+,Option"o"[a_output_encoding](ReqArg(atta_output_encoding)"CHARSET")("encoding of output ("++utf8++", "++isoLatin1++", "++usAscii++")")
+,Option"f"[a_output_file](ReqArg(atta_output_file)"FILE")"output file for resulting document (default: stdout)"
+,Option""[a_output_html](NoArg(atta_output_htmlv_1))"output of none ASCII chars as HTMl entity references"
+,Option""[a_no_xml_pi](NoArg(atta_no_xml_piv_1))("output without <?xml ...?> processing instruction, useful in combination with --"++showa_output_html)
+]
+where
+attnv=(n,v)
+
+-- |
+-- commonly useful options
+--
+-- defines options: 'a_verbose', 'a_help'
+
+generalOptions::[OptDescr(String,String)]
+generalOptions
+=[Option"v"[a_verbose](NoArg(a_verbose,v_1))"verbose output"
+,Option"h?"[a_help](NoArg(a_help,v_1))"this message"
+]
+
+-- |
+-- defines 'a_version' option
+
+versionOptions::[OptDescr(String,String)]
+versionOptions
+=[Option"V"[a_version](NoArg(a_version,v_1))"show program version"
+]
+
+-- |
+-- debug output options
+
+showOptions::[OptDescr(String,String)]
+showOptions
+=[Option""[a_show_tree](NoArg(a_show_tree,v_1))"output tree representation instead of document source"
+,Option""[a_show_haskell](NoArg(a_show_haskell,v_1))"output internal Haskell representation instead of document source"
+]
+
+-- ------------------------------------------------------------
+
+-- |
+-- select options from a predefined list of option desciptions
+
+selectOptions::[String]->[OptDescr(String,String)]->[OptDescr(String,String)]
+selectOptionsolos
+=concat.map(\on->filter(\(Option_ons__)->on`elem`ons)os)$ol
+
+removeOptions::[String]->[OptDescr(String,String)]->[OptDescr(String,String)]
+removeOptionsolos
+=filter(\(Option_ons__)->not.any(`elem`ol)$ons)os
+
+-- |
+-- 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\".
+
+optionIsSet::String->Attributes->Bool
+optionIsSetn
+=(`elem`["1","True","true","Yes","yes"]).lookupDef""n
+
+-- ------------------------------------------------------------
+
-- |
+-- 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.
+--
+-- Version : $Id: XmlState.hs,v 1.3 2005/05/27 13:15:23 hxml Exp $
+
+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
+
+-- ------------------------------------------------------------
+
-- |
+-- exports the core data types
+-- and some additional types and functions
+-- for compatibility with none arrow modules
+--
+-- Version : $Id: XmlTreeTypes.hs,v 1.6 2006/05/09 15:30:43 hxml Exp $
+
+moduleText.XML.HXT.DOM.XmlTreeTypes
+(moduleData.Tree.NTree.Filter
+,moduleText.XML.HXT.DOM.TypeDefs
+,moduleText.XML.HXT.DOM.XmlTreeTypes
+)
+
+where
+
+importData.Tree.NTree.Filter
+importText.XML.HXT.DOM.TypeDefs
+
+-- aliases for compatiblility reasons
+
+mkNode::node->NTreesnode->NTreenode
+mkNode=mkTree
+
+formatNTree::(node->String)->NTreenode->String
+formatNTree=formatTree
+
+foldNTree::(a->[b]->b)->NTreea->b
+foldNTree=foldTree
+
+mapNTree::(a->b)->NTreea->NTreeb
+mapNTree=fmap
+
+nTreeToList::NTreea->[a]
+nTreeToList=nodesTree
+
+depthNTree::NTreea->Int
+depthNTree=depthTree
+
+cardNTree::NTreea->Int
+cardNTree=cardNTree
+
+-- -----------------------------------------------------------------------------
+--
+-- Basic types for filters
+
+-- | A functions that takes a node and returns a list of nodes
+
+typeXmlFilter=TFilterXNode
+
+-- | A function that takes a list of nodes and returns a list of nodes
+
+typeXmlSFilter=TSFilterXNode
+
+
+-- -----------------------------------------------------------------------------
+--
+
+-- | Tag name
+typeTagName=QName
+
+-- | Attribute name
+typeAttrName=QName
+
+-- -----------------------------------------------------------------------------
+
+-- | shortcut for 'qualifiedName'
+
+tName::QName->String
+tName=qualifiedName
+
+-- | shortcut for 'qualifiedName'
+
+aName::QName->String
+aName=qualifiedName
+
+-- -----------------------------------------------------------------------------
+
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.DTDValidation.TypeDefs
+ Copyright : Copyright (C) 2008 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ 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.DTDValidation.AttributeValueValidation
+(checkAttributeValue
+,normalizeAttributeValue
+)
+where
+
+importText.XML.HXT.Parser.XmlParsec
+(parseNMToken
+,parseName
+)
+
+importText.XML.HXT.DTDValidation.TypeDefs
+
+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->XmlArrow
+checkAttributeValuedtdPartattrDecl
+|isDTDAttlistNodeattrDecl
+=choiceA
+[isElem:->(checkAttrVal$<getAttrValueattrName)
+,isDTDAttlist:->(checkAttrVal$<(getDTDAttrl>>^dtd_default))
+,this:->none
+]
+|otherwise
+=none
+where
+al=getDTDAttributesattrDecl
+attrName=dtd_valueal
+attrType=dtd_typeal
+checkAttrValattrValue
+=checkValueattrTypedtdPartnormalizedValattrDecl
+where
+normalizedVal=normalizeAttributeValue(JustattrDecl)attrValue
+
+-- |
+-- 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->XmlArrow
+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->XmlArrow
+checkValueEnumerationattrDeclattrValue
+|isDTDAttlistNodeattrDecl
+&&
+attrValue`notElem`enumVals
+=err("Attribute "++show(dtd_valueal)++" for element "++show(dtd_nameal)++
+" must have a value from list "++showenumVals{- ++ " but has value " ++ show attrValue-}++".")
+|otherwise
+=none
+where
+al=getDTDAttributesattrDecl
+
+enumVals::[String]
+enumVals=map(dtd_name.getDTDAttributes)$(runLAgetChildrenattrDecl)
+
+-- |
+-- 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->XmlArrow
+checkValueEntitydtdPartattrDeclattrValue
+|isDTDAttlistNodeattrDecl
+&&
+attrValue`notElem`upEntities
+=err("Entity "++showattrValue++" of attribute "++show(dtd_valueal)++
+" for element "++show(dtd_nameal)++" is not unparsed. "++
+"The following unparsed entities exist: "++showupEntities++".")
+|otherwise
+=none
+where
+al=getDTDAttributesattrDecl
+
+upEntities::[String]
+upEntities=map(dtd_name.getDTDAttributes)(isUnparsedEntity$$dtdPart)
+
+-- |
+-- 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->XmlArrow
+checkValueEntitiesdtdPartattrDeclattrValue
+|isDTDAttlistNodeattrDecl
+=ifnullvalueList
+thenerr("Attribute "++show(dtd_valueal)++" of element "++
+show(dtd_nameal)++" must be one or more names.")
+elsecatA.map(checkValueEntitydtdPartattrDecl)$valueList
+|otherwise
+=none
+where
+al=getDTDAttributesattrDecl
+valueList=wordsattrValue
+
+-- |
+-- 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->XmlArrow
+checkValueNmtokenattrDeclattrValue
+|isDTDAttlistNodeattrDecl
+=constAattrValue>>>checkNmtoken
+|otherwise
+=none
+where
+al=getDTDAttributesattrDecl
+checkNmtoken
+=mkText>>>arrL(parseNMToken"")
+>>>
+isError
+>>>
+getErrorMsg
+>>>
+arr(\s->("Attribute value "++showattrValue++" of attribute "++show(dtd_valueal)++
+" for element "++show(dtd_nameal)++" must be a name token, "++(liness)!!1++"."))
+>>>
+mkErrorc_err
+
+-- |
+-- 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->XmlArrow
+checkValueNmtokensattrDeclattrValue
+|isDTDAttlistNodeattrDecl
+=ifnullvalueList
+thenerr("Attribute "++show(dtd_valueal)++" of element "++
+show(dtd_nameal)++" must be one or more name tokens.")
+elsecatA.map(checkValueNmtokenattrDecl)$valueList
+|otherwise
+=none
+where
+al=getDTDAttributesattrDecl
+valueList=wordsattrValue
+
+-- |
+-- 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->XmlArrow
+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->XmlArrow
+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->XmlArrow
+checkValueIdrefsattrDeclattrValue
+=catA.map(checkValueIdrefattrDecl).words$attrValue
+
+
+
+-- -----------------------------------------------------------------------------
+-- 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->XmlArrow
+checkForNamemsgattrDeclattrValue
+|isDTDAttlistNodeattrDecl
+=constAattrValue>>>checkName
+|otherwise
+=none
+where
+al=getDTDAttributesattrDecl
+checkName
+=mkText>>>arrL(parseName"")
+>>>
+isError
+>>>
+getErrorMsg
+>>>
+arr(\s->(msg++" "++showattrValue++" of attribute "++show(dtd_valueal)++
+" for element "++show(dtd_nameal)++" must be a name, "++(liness)!!1++"."))
+>>>
+mkErrorc_err
+
+-- -----------------------------------------------------------------------------
+
+-- |
+-- 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(JustattrDecl)value
+=normalizeAttributeattrType
+where
+al=getDTDAttributesattrDecl
+attrType=dtd_typeal
+
+normalizeAttribute::String->String
+normalizeAttributetyp
+|typ==k_cdata=cdataNormalizationvalue
+|otherwise=otherNormalizationvalue
+
+-- Attribute not declared in DTD, normalization as CDATA
+normalizeAttributeValueNothingvalue
+=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)
+
+-- ------------------------------------------------------------
+
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.DTDValidation.TypeDefs
+ Copyright : Copyright (C) 2008 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ 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
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.DTDValidation.DTDValidation
+(removeDoublicateDefs
+,validateDTD
+)
+where
+
+importText.XML.HXT.DTDValidation.TypeDefs
+importText.XML.HXT.DTDValidation.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::XmlArrow
+validateDTD-- dtdPart
+=isDTDDoctype
+`guards`
+(listAgetChildren
+>>>
+(validateParts$<<(getNotationNames&&&getElemNames))
+)
+where
+validatePartsnotationNameselemNames
+=validateNotations
+<+>
+validateEntitiesnotationNames
+<+>
+validateElementselemNames
+<+>
+validateAttributeselemNamesnotationNames
+
+getNotationNames::LA[XmlTree][String]
+getNotationNames=listA$unlistA>>>isDTDNotation>>>getDTDAttrValuea_name
+
+getElemNames::LA[XmlTree][String]
+getElemNames=listA$unlistA>>>isDTDElement>>>getDTDAttrValuea_name
+
+-- ------------------------------------------------------------
+
+checkName::String->SLA[String]XmlTreeXmlTree->SLA[String]XmlTreeXmlTree
+checkNamenamemsg
+=ifA(getState
+>>>
+isA(name`elem`)
+)
+msg
+(nextState(name:)>>>none)
+
+-- ------------------------------------------------------------
+
+-- |
+-- 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::LAXmlTreesXmlTree
+validateNotations
+=fromSLA[](unlistA
+>>>
+isDTDNotation
+>>>
+(checkForUniqueNotation$<getDTDAttrl)
+)
+where
+checkForUniqueNotation::Attributes->SLA[String]XmlTreeXmlTree
+checkForUniqueNotational
+=checkNamename$
+err("Notation "++showname++" was already specified.")
+where
+name=dtd_nameal
+
+-- |
+-- 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::[String]->LAXmlTreesXmlTree
+validateEntitiesnotationNames
+=(fromSLA[](unlistA
+>>>
+isDTDEntity
+>>>
+(checkForUniqueEntity$<getDTDAttrl)
+)
+)
+<+>
+(unlistA
+>>>
+isUnparsedEntity
+>>>
+(checkNotationDecl$<getDTDAttrl)
+)
+where
+
+-- Check if entities are declared multiple times
+
+checkForUniqueEntity::Attributes->SLA[String]XmlTreeXmlTree
+checkForUniqueEntityal
+=checkNamename$
+warn("Entity "++showname++" was already specified. "++
+"First declaration will be used.")
+where
+name=dtd_nameal
+
+-- Find unparsed entities for which no notation is specified
+
+checkNotationDecl::Attributes->XmlArrow
+checkNotationDeclal
+|notationName`elem`notationNames
+=none
+|otherwise
+=err("The notation "++shownotationName++" must be declared "++
+"when referenced in the unparsed entity declaration for "++
+showupEntityName++"."
+)
+where
+notationName=lookup1k_ndataal
+upEntityName=dtd_nameal
+
+-- |
+-- 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::[String]->LAXmlTreesXmlTree
+validateElementselemNames-- dtdPart
+=(fromSLA[](unlistA
+>>>
+isDTDElement
+>>>
+(checkForUniqueElement$<getDTDAttrl)
+)
+)
+<+>
+(unlistA
+>>>
+isMixedContentElement
+>>>
+(checkMixedContent$<getDTDAttrl)
+)
+<+>
+(unlistA
+>>>
+isDTDElement
+>>>
+(checkContentModelelemNames$<getDTDAttrl)
+)
+where
+
+-- Validates that an element is not declared multiple times
+
+checkForUniqueElement::Attributes->SLA[String]XmlTreeXmlTree
+checkForUniqueElemental
+=checkNamename$
+err("Element type "++showname++
+" must not be declared more than once.")
+where
+name=dtd_nameal
+
+-- Validates that an element name only appears once in a mixed-content declaration
+
+checkMixedContent::Attributes->XmlArrow
+checkMixedContental
+=fromSLA[](getChildren
+>>>
+getChildren
+>>>
+isDTDName
+>>>
+(check$<getDTDAttrl)
+)
+where
+elemName=dtd_nameal
+checkal'
+=checkNamename$
+err("The element type "++showname++
+" was already specified in the mixed-content model of the element declaration "++
+showelemName++".")
+where
+name=dtd_nameal'
+
+-- Issues a warning if an element mentioned in a content model is not
+-- declared in the DTD.
+checkContentModel::[String]->Attributes->XmlArrow
+checkContentModelnamesal
+|cm`elem`[v_children,v_mixed]
+=getChildren>>>checkContent
+|otherwise
+=none
+where
+elemName=dtd_nameal
+cm=dtd_typeal
+
+checkContent::XmlArrow
+checkContent
+=choiceA
+[isDTDName:->(checkName'$<getDTDAttrl)
+,isDTDContent:->(getChildren>>>checkContent)
+,this:->none
+]
+where
+checkName'al'
+|childElemName`elem`names
+=none
+|otherwise
+=warn("The element type "++showchildElemName++
+", used in content model of element "++showelemName++
+", is not declared."
+)
+where
+childElemName=dtd_nameal'
+
+-- |
+-- 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::[String]->[String]->LAXmlTreesXmlTree
+validateAttributeselemNamesnotationNames
+=-- 1. Find attributes for which no elements are declared
+(runCheckthis(checkDeclaredElementselemNames))
+<+>
+-- 2. Find attributes which are declared more than once
+(runNameCheckthischeckForUniqueAttributeDeclaration)
+<+>
+-- 3. Find enumerated attribute types which nmtokens are declared more than once
+(runCheck(isEnumAttrType`orElse`isNotationAttrType)checkEnumeratedTypes)
+<+>
+-- 4. Validate that there exists only one ID attribute for an element
+(runNameCheckisIdAttrTypecheckForUniqueId)
+<+>
+-- 5. Validate that there exists only one NOTATION attribute for an element
+(runNameCheckisNotationAttrTypecheckForUniqueNotation)
+<+>
+-- 6. Validate that ID attributes have the type #IMPLIED or #REQUIRED
+(runCheckisIdAttrTypecheckIdKindConstraint)
+<+>
+-- 7. Validate that all referenced notations are declared
+(runCheckisNotationAttrType(checkNotationDeclarationnotationNames))
+<+>
+-- 8. Validate that notations are not declared for EMPTY elements
+(checkNoNotationForEmptyElements$<listA(unlistA
+>>>
+isEmptyElement
+>>>
+getDTDAttrValuea_name
+)
+)
+<+>
+-- 9. Validate that the default value matches the lexical constraints of it's type
+(checkDefaultValueTypes$<this)
+
+where
+-- ------------------------------------------------------------
+-- control structures
+
+runCheckselectcheck
+=unlistA>>>isDTDAttlist
+>>>
+select
+>>>
+(check$<getDTDAttrl)
+
+runNameCheckselectcheck
+=fromSLA[]$runCheckselectcheck
+
+--------------------------------------------------------------------------
+
+-- 1. Find attributes for which no elements are declared
+
+checkDeclaredElements::[String]->Attributes->XmlArrow
+checkDeclaredElementselemNames'al
+|en`elem`elemNames'
+=none
+|otherwise
+=warn("The element type \""++en++"\" used in dclaration "++
+"of attribute \""++an++"\" is not declared."
+)
+where
+en=dtd_nameal
+an=dtd_valueal
+
+--------------------------------------------------------------------------
+
+-- 2. Find attributes which are declared more than once
+
+checkForUniqueAttributeDeclaration::Attributes->SLA[String]XmlTreeXmlTree
+checkForUniqueAttributeDeclarational
+=checkNamename$
+warn("Attribute \""++aname++"\" for element type \""++
+ename++"\" is already declared. First "++
+"declaration will be used.")
+where
+ename=dtd_nameal
+aname=dtd_valueal
+name=ename++"|"++aname
+
+--------------------------------------------------------------------------
+
+-- 3. Find enumerated attribute types which nmtokens are declared more than once
+
+checkEnumeratedTypes::Attributes->XmlArrow
+checkEnumeratedTypesal
+=fromSLA[](getChildren
+>>>
+isDTDName
+>>>
+(checkForUniqueType$<getDTDAttrl)
+)
+where
+checkForUniqueType::Attributes->SLA[String]XmlTreeXmlTree
+checkForUniqueTypeal'
+=checkNamenmtoken$
+warn("Nmtoken \""++nmtoken++"\" should not "++
+"occur more than once in attribute \""++dtd_valueal++
+"\" for element \""++dtd_nameal++"\".")
+where
+nmtoken=dtd_nameal'
+
+--------------------------------------------------------------------------
+
+-- 4. Validate that there exists only one ID attribute for an element
+
+checkForUniqueId::Attributes->SLA[String]XmlTreeXmlTree
+checkForUniqueIdal
+=checkNameename$
+err("Element \""++ename++"\" already has attribute of type "++
+"ID, another attribute \""++dtd_valueal++"\" of type ID is "++
+"not permitted.")
+where
+ename=dtd_nameal
+
+--------------------------------------------------------------------------
+
+-- 5. Validate that there exists only one NOTATION attribute for an element
+
+checkForUniqueNotation::Attributes->SLA[String]XmlTreeXmlTree
+checkForUniqueNotational
+=checkNameename$
+err("Element \""++ename++"\" already has attribute of type "++
+"NOTATION, another attribute \""++dtd_valueal++"\" of type NOTATION "++
+"is not permitted.")
+where
+ename=dtd_nameal
+
+--------------------------------------------------------------------------
+
+-- 6. Validate that ID attributes have the type #IMPLIED or #REQUIRED
+
+checkIdKindConstraint::Attributes->XmlArrow
+checkIdKindConstraintal
+|attKind`elem`[k_implied,k_required]
+=none
+|otherwise
+=err("ID attribute \""++dtd_valueal++"\" must have a declared default "++
+"of \"#IMPLIED\" or \"REQUIRED\"")
+where
+attKind=dtd_kindal
+
+
+--------------------------------------------------------------------------
+
+-- 7. Validate that all referenced notations are declared
+
+checkNotationDeclaration::[String]->Attributes->XmlArrow
+checkNotationDeclarationnotationsal
+=getChildren
+>>>
+isDTDName
+>>>
+(checkNotations$<getDTDAttrl)
+where
+checkNotations::Attributes->XmlArrow
+checkNotationsal'
+|notation`elem`notations
+=none
+|otherwise
+=err("The notation \""++notation++"\" must be declared when "++
+"referenced in the notation type list for attribute \""++dtd_valueal++
+"\" of element \""++dtd_nameal++"\"."
+)
+where
+notation=dtd_nameal'
+
+--------------------------------------------------------------------------
+
+-- 8. Validate that notations are not declared for EMPTY elements
+
+checkNoNotationForEmptyElements::[String]->LAXmlTreesXmlTree
+checkNoNotationForEmptyElementsemptyElems
+=unlistA
+>>>
+isDTDAttlist
+>>>
+isNotationAttrType
+>>>
+(checkNoNotationForEmptyElement$<getDTDAttrl)
+where
+checkNoNotationForEmptyElement::Attributes->XmlArrow
+checkNoNotationForEmptyElemental
+|ename`elem`emptyElems
+=err("Attribute \""++dtd_valueal++"\" of type NOTATION must not be "++
+"declared on the element \""++ename++"\" declared EMPTY."
+)
+|otherwise
+=none
+where
+ename=dtd_nameal
+
+--------------------------------------------------------------------------
+
+-- 9. Validate that default values meet the lexical constraints of the attribute types
+
+checkDefaultValueTypes::XmlTrees->LAXmlTreesXmlTree
+checkDefaultValueTypesdtdPart'
+=unlistA>>>isDTDAttlist
+>>>
+isDefaultAttrKind
+>>>
+(checkAttributeValuedtdPart'$<this)
+
+-- ------------------------------------------------------------
+
+-- |
+-- 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::XmlArrow
+removeDoublicateDefs
+=replaceChildren
+(fromSLA[](getChildren
+>>>
+choiceA[isDTDAttlist:->(removeDoubleAttlist$<getDTDAttrl)
+,isDTDEntity:->(removeDoubleEntity$<getDTDAttrl)
+,this:->this
+]
+)
+)
+`when`
+isDTDDoctype
+where
+checkName'n'
+=ifA(getState
+>>>
+isA(n'`elem`)
+)
+none
+(this>>>perform(nextState(n':)))
+
+removeDoubleAttlist::Attributes->SLA[String]XmlTreeXmlTree
+removeDoubleAttlistal
+=checkName'elemAttr
+where
+elemAttr=elemName++"|"++attrName
+attrName=dtd_valueal
+elemName=dtd_nameal
+
+removeDoubleEntity::Attributes->SLA[String]XmlTreeXmlTree
+removeDoubleEntityal
+=checkName'(dtd_nameal)
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.DTDValidation.DocTransformation
+ Copyright : Copyright (C) 2008 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ 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.
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.DTDValidation.DocTransformation
+(transform
+)
+where
+
+importText.XML.HXT.DTDValidation.TypeDefs
+importText.XML.HXT.DTDValidation.AttributeValueValidation
+
+importData.Maybe
+importData.List
+importData.Ord
+
+-- ------------------------------------------------------------
+
+-- |
+-- Lookup-table which maps element names to their transformation functions. The
+-- transformation functions are XmlArrows.
+
+typeTransEnvTable=[TransEnv]
+typeTransEnv=(ElemName,TransFct)
+typeElemName=String
+typeTransFct=XmlArrow
+
+
+-- ------------------------------------------------------------
+
+-- |
+-- 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->XmlArrow
+transformdtdPart
+=traverseTreetransTable
+where
+transTable=buildAllTransformationFunctions(runLAgetChildrendtdPart)
+
+-- |
+-- 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->XmlArrow
+traverseTreetransEnv
+=processTopDown
+(((transFct$<getName)
+>>>
+processChildren(traverseTreetransEnv)
+)
+`when`
+isElem
+)
+where
+transFct::String->XmlArrow
+transFctname=fromMaybethis.lookupname$transEnv
+
+-- |
+-- 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::XmlTrees->TransEnvTable
+buildAllTransformationFunctionsdtdNodes
+=(t_root,this)
+:
+concatMap(buildTransformationFunctionsdtdNodes)dtdNodes
+
+-- |
+-- 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]
+
+buildTransformationFunctionsdtdPartdn
+|isDTDElementNodedn=[(name,transFct)]
+|otherwise=[]
+where
+al=getDTDAttributesdn
+name=dtd_nameal
+transFct=setDefaultAttributeValuesdtdPartdn
+>>>
+normalizeAttributeValuesdtdPartdn
+>>>
+lexicographicAttributeOrder
+
+-- ------------------------------------------------------------
+
+-- |
+-- 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::XmlArrow
+lexicographicAttributeOrder
+=setAttrl(getAttrl>>.sortAttrl)
+where
+sortAttrl::XmlTrees->XmlTrees
+sortAttrl=sortBy(comparingnameOfAttr)
+
+-- |
+-- Normalize attribute values.
+--
+-- * returns : a function which takes an element (XTag), normalizes its
+-- attribute values and returns the changed element
+
+normalizeAttributeValues::XmlTrees->XmlTree->XmlArrow
+normalizeAttributeValuesdtdPartdn
+|isDTDElementNodedn=processAttrl(normalizeAttr$<getName)
+|otherwise=this
+where
+al=getDTDAttributesdn
+elemName=dtd_nameal
+declaredAtts=isAttlistOfElementelemName$$dtdPart
+
+normalizeAttr::String->XmlArrow
+normalizeAttrnameOfAtt
+=normalizeAttrValue(ifnullattDescr
+thenNothing
+elseJust(headattDescr)
+)
+where
+attDescr=filter((==nameOfAtt).valueOfDTDa_value)declaredAtts
+
+normalizeAttrValue::MaybeXmlTree->XmlArrow
+normalizeAttrValuedescr
+=replaceChildren((xshowgetChildren>>^normalizeAttributeValuedescr)>>>mkText)
+
+-- |
+-- 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::XmlTrees->XmlTree->XmlArrow
+setDefaultAttributeValuesdtdPartdn
+|isDTDElementNodedn=seqA(mapsetDefaultdefaultAtts)
+|otherwise=this
+where
+elemName=dtd_name.getDTDAttributes$dn
+defaultAtts=(isAttlistOfElementelemName
+>>>
+(isFixedAttrKind-- select attributes with default values
+`orElse`
+isDefaultAttrKind
+)
+)$$dtdPart
+
+setDefault::XmlTree->XmlArrow
+setDefaultattrDescr-- add the default attributes
+=(addAttrattNamedefaultValue-- to tag nodes with missing attributes
+`whenNot`
+hasAttrattName
+)
+`when`
+isElem
+where
+al=getDTDAttributesattrDescr
+attName=dtd_valueal
+defaultValue=dtd_defaultal
+
+-- ------------------------------------------------------------
+
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.DTDValidation.TypeDefs
+ Copyright : Copyright (C) 2008 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ 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.
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.DTDValidation.DocValidation
+(validateDoc
+)
+where
+
+importText.XML.HXT.DTDValidation.TypeDefs
+
+importText.XML.HXT.DTDValidation.AttributeValueValidation
+importText.XML.HXT.DTDValidation.XmlRE
+
+importData.Maybe
+
+-- ------------------------------------------------------------
+
+-- |
+-- Lookup-table which maps element names to their validation functions. The
+-- validation functions are XmlArrows.
+
+typeValiEnvTable=[ValiEnv]
+typeValiEnv=(ElemName,ValFct)
+typeElemName=String
+typeValFct=XmlArrow
+
+
+-- ------------------------------------------------------------
+
+-- |
+-- 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->XmlArrow
+validateDocdtdPart
+=traverseTreevalTable
+where
+valTable=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->XmlArrow
+traverseTreevaliEnv
+=choiceA[isElem:->(valFct$<getQName)
+,this:->none
+]
+<+>
+(getChildren>>>traverseTreevaliEnv)
+where
+valFct::QName->XmlArrow
+valFctname=case(lookup(qualifiedNamename)valiEnv)of
+Nothing->err("Element "++show(qualifiedNamename)++" not declared in DTD.")
+Justf->f
+
+-- ------------------------------------------------------------
+
+-- |
+-- 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
+=concat$
+buildValidateRootdtdPart:-- construct a list of validation filters for all element declarations
+map(buildValidateFunctionsdtdNodes)dtdNodes
+where
+dtdNodes=runLAgetChildrendtdPart
+
+-- |
+-- 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]
+buildValidateRootdn
+|isDTDDoctypeNodedn=[(t_root,valFct)]
+|otherwise=[]
+where
+name=dtd_name.getDTDAttributes$dn
+
+valFct::XmlArrow
+valFct=isElem
+`guards`
+(checkRegex(re_symname)
+>>>
+msgToErr(("Root Element must be "++showname++". ")++)
+)
+
+checkRegex::REString->LAXmlTreeString
+checkRegexre=listAgetChildren
+>>>arr(\cs->checkRE(matchesrecs))
+
+-- |
+-- 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]
+
+buildValidateFunctionsdtdPartdn
+|isDTDElementNodedn=[(elemName,valFct)]
+|otherwise=[]
+where
+elemName=dtd_name.getDTDAttributes$dn
+
+valFct::XmlArrow
+valFct=buildContentValidationdn
+<+>
+buildAttributeValidationdtdPartdn
+
+-- ------------------------------------------------------------
+
+
+-- |
+-- 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->XmlArrow
+buildContentValidationnd
+=contentValidationattrTypend
+where
+attrType=dtd_type.getDTDAttributes$nd
+
+
+-- Delegates construction of the validation function on the basis of the
+-- content model type
+contentValidation::String->XmlTree->XmlArrow
+contentValidationtypdn
+|typ==k_pcdata=contentValidationPcdata
+|typ==k_empty=contentValidationEmpty
+|typ==k_any=contentValidationAny
+|typ==v_children=contentValidationChildrencs
+|typ==v_mixed=contentValidationMixedcs
+|otherwise=none
+where
+cs=runLAgetChildrendn
+
+-- Checks #PCDATA content models
+contentValidationPcdata::XmlArrow
+contentValidationPcdata
+=isElem`guards`(contentVal$<getQName)
+where
+contentValname
+=checkRegex(re_rep(re_symk_pcdata))
+>>>
+msgToErr(("The content of element "++
+show(qualifiedNamename)++
+" must match (#PCDATA). "
+)++
+)
+
+-- Checks EMPTY content models
+contentValidationEmpty::XmlArrow
+contentValidationEmpty
+=isElem`guards`(contentVal$<getQName)
+where
+contentValname
+=checkRegexre_unit
+>>>
+msgToErr(("The content of element "++
+show(qualifiedNamename)++
+" must match EMPTY. "
+)++
+)
+
+-- Checks ANY content models
+contentValidationAny::XmlArrow
+contentValidationAny
+=isElem`guards`(contentVal$<getName)
+where
+contentValname
+=checkRegex(re_rep(re_dot))
+>>>
+msgToErr(("The content of element "++
+showname++
+" must match ANY. "
+)++
+)
+
+-- Checks "children" content models
+contentValidationChildren::XmlTrees->XmlArrow
+contentValidationChildrencm
+=isElem`guards`(contentVal$<getName)
+where
+contentValname
+=checkRegexre
+>>>
+msgToErr(("The content of element "++
+showname++
+" must match "++printREre++". "
+)++
+)
+re=createRE(headcm)
+
+-- Checks "mixed content" content models
+contentValidationMixed::XmlTrees->XmlArrow
+contentValidationMixedcm
+=isElem`guards`(contentVal$<getName)
+where
+contentValname
+=checkRegexre
+>>>
+msgToErr(("The content of element "++
+showname++
+" must match "++printREre++". "
+)++
+)
+re=re_rep(re_alt(re_symk_pcdata)(createRE(headcm)))
+
+-- |
+-- 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
+createREdn
+|isDTDContentNodedn
+=processModifiermodifier
+|isDTDNameNodedn
+=re_symname
+|otherwise
+=error("createRE: illegeal parameter:\n"++showdn)
+where
+al=getDTDAttributesdn
+name=dtd_nameal
+modifier=dtd_modifieral
+kind=dtd_kindal
+cs=runLAgetChildrendn
+
+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)
+
+-- ------------------------------------------------------------
+
+-- |
+-- 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->XmlArrow
+buildAttributeValidationdtdPartnd=
+noDoublicateAttributes
+<+>
+checkNotDeclardAttributesattrDeclsnd
+<+>
+checkRequiredAttributesattrDeclsnd
+<+>
+checkFixedAttributesattrDeclsnd
+<+>
+checkValuesOfAttributesattrDeclsdtdPartnd
+where
+attrDecls=isDTDAttlist$$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::XmlArrow
+noDoublicateAttributes
+=isElem
+`guards`
+(noDoubles'$<getName)
+where
+noDoubles'elemName
+=listA(getAttrl>>>getName)
+>>>applyA(arr(catA.maptoErr.doubles.reverse))
+where
+toErrn1=err("Attribute "++shown1++
+" was already specified for element "++
+showelemName++"."
+)
+
+-- |
+-- 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->XmlArrow
+checkRequiredAttributesattrDeclsdn
+|isDTDElementNodedn
+=isElem
+`guards`
+(checkRequired$<getName)
+|otherwise
+=none
+where
+elemName=dtd_name.getDTDAttributes$dn
+requiredAtts=(isAttlistOfElementelemName>>>isRequiredAttrKind)$$attrDecls
+
+checkRequired::String->XmlArrow
+checkRequiredname
+=catA.mapcheckReq$requiredAtts
+where
+checkReq::XmlTree->XmlArrow
+checkReqattrDecl
+=neg(hasAttrattName)
+`guards`
+err("Attribute "++showattName++" must be declared for element type "++
+showname++".")
+where
+attName=dtd_value.getDTDAttributes$attrDecl
+
+-- |
+-- 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->XmlArrow
+checkFixedAttributesattrDeclsdn
+|isDTDElementNodedn
+=isElem
+`guards`
+(checkFixed$<getName)
+|otherwise
+=none
+where
+elemName=dtd_name.getDTDAttributes$dn
+fixedAtts=(isAttlistOfElementelemName>>>isFixedAttrKind)$$attrDecls
+
+checkFixed::String->XmlArrow
+checkFixedname
+=catA.mapcheckFix$fixedAtts
+where
+checkFix::XmlTree->XmlArrow
+checkFixan
+|isDTDAttlistNodean
+=checkFixedVal$<getAttrValueattName
+|otherwise
+=none
+where
+al'=getDTDAttributesan
+attName=dtd_valueal'
+defa=dtd_defaultal'
+fixedValue=normalizeAttributeValue(Justan)defa
+
+checkFixedVal::String->XmlArrow
+checkFixedValval
+=((hasAttrattName
+>>>
+isA(const(attValue/=fixedValue))
+)
+`guards`
+err("Attribute "++showattName++" of element "++showname++
+" with value "++showattValue++" must have a value of "++
+showfixedValue++".")
+)
+where
+attValue=normalizeAttributeValue(Justan)val
+
+-- |
+-- 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->XmlArrow
+checkNotDeclardAttributesattrDeclselemDescr
+=checkNotDeclared
+where
+elemName=valueOfDTDa_nameelemDescr
+decls=isAttlistOfElementelemName$$attrDecls
+
+checkNotDeclared::XmlArrow
+checkNotDeclared
+=isElem
+`guards`
+(getAttrl>>>searchForDeclaredAttelemNamedecls)
+
+searchForDeclaredAtt::String->XmlTrees->XmlArrow
+searchForDeclaredAttname(dn:xs)
+|isDTDAttlistNodedn
+=(getName>>>isA((dtd_value.getDTDAttributes$dn)/=))
+`guards`
+searchForDeclaredAttnamexs
+|otherwise
+=searchForDeclaredAttnamexs
+
+searchForDeclaredAttname[]
+=mkErr$<getName
+where
+mkErrn=err("Attribute "++shown++" of element "++
+showname++" is not declared in DTD.")
+
+-- |
+-- 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->XmlArrow
+checkValuesOfAttributesattrDeclsdtdPartelemDescr
+=checkValues
+where
+elemName=dtd_name.getDTDAttributes$elemDescr
+decls=isAttlistOfElementelemName$$attrDecls
+
+checkValues::XmlArrow
+checkValues
+=isElem
+`guards`
+(checkValue$<getAttrl)
+
+checkValueatt
+=catA.mapcheckVal$decls
+where
+checkVal::XmlTree->XmlArrow
+checkValattrDecl
+|isDTDAttlistNodeattrDecl
+&&
+nameOfAttratt==dtd_valueal'
+=checkAttributeValuedtdPartattrDecl
+|otherwise
+=none
+where
+al'=getDTDAttributesattrDecl
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.DTDValidation.IdValidation
+ Copyright : Copyright (C) 2008 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ 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.
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.DTDValidation.IdValidation
+(validateIds
+)
+where
+
+importData.Maybe
+
+importText.XML.HXT.DTDValidation.TypeDefs
+importText.XML.HXT.DTDValidation.AttributeValueValidation
+
+-- ------------------------------------------------------------
+
+-- |
+-- Lookup-table which maps element names to their validation functions. The
+-- validation functions are XmlFilters.
+
+typeIdEnvTable=[IdEnv]
+typeIdEnv=(ElemName,IdFct)
+typeElemName=String
+typeIdFct=XmlArrow
+
+-- ------------------------------------------------------------
+
+-- |
+-- 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->XmlArrow
+validateIdsdtdPart
+=validateIds'$<listA(traverseTreeidEnv)
+where
+idAttrTypes=runLA(getChildren>>>isIdAttrType)dtdPart
+elements=runLA(getChildren>>>isDTDElement)dtdPart
+atts=runLA(getChildren>>>isDTDAttlist)dtdPart
+idEnv=buildIdCollectorFctsidAttrTypes
+
+validateIds'::XmlTrees->XmlArrow
+validateIds'idNodeList
+=(constAidNodeList>>>checkForUniqueIdsidAttrTypes)
+<+>
+checkIdReferencesidRefEnv
+where
+idRefEnv=buildIdrefValidationFctsidAttrTypeselementsattsidNodeList
+
+
+
+-- |
+-- Traverse the XmlTree in preorder.
+--
+-- * 1.parameter idEnv : lookup-table which maps element names to their validation functions
+--
+-- - returns : list of errors
+
+traverseTree::IdEnvTable->XmlArrow
+traverseTreeidEnv
+=multi(isElem`guards`(idFct$<getName))
+where
+idFct::String->XmlArrow
+idFctname=fromMaybenone.lookupname$idEnv
+
+-- |
+-- 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
+getIdValuedns
+=concat.runLA(singlegetIdValue')
+where
+getIdValue'::LAXmlTreeString
+getIdValue'
+=isElem`guards`catA(mapgetIdValdns)
+where
+getIdValdn
+|isDTDAttlistNodedn=hasNameelemName
+`guards`
+(getAttrValue0attrName
+>>>
+arr(normalizeAttributeValue(Justdn))
+)
+|otherwise=none
+where
+al=getDTDAttributesdn
+elemName=dtd_nameal
+attrName=dtd_valueal
+
+-- ------------------------------------------------------------
+
+
+-- |
+-- 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
+buildIdCollectorFctsidAttrTypes
+=concatMapbuildIdCollectorFctidAttrTypes
+where
+buildIdCollectorFct::XmlTree->[IdEnv]
+buildIdCollectorFctdn
+|isDTDAttlistNodedn=[(elemName,hasAttrattrName)]
+|otherwise=[]
+where
+al=getDTDAttributesdn
+elemName=dtd_nameal
+attrName=dtd_valueal
+
+-- |
+-- 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->XmlTrees->XmlTrees->IdEnvTable
+buildIdrefValidationFctsidAttrTypeselementsattsidNodeList
+=concatMapbuildElemValidationFctelements
+where
+idValueList=map(getIdValueidAttrTypes)idNodeList
+
+buildElemValidationFct::XmlTree->[IdEnv]
+buildElemValidationFctdn
+|isDTDElementNodedn=[(elemName,buildIdrefValidationFctidRefAttrTypes)]
+|otherwise=[]
+where
+al=getDTDAttributesdn
+elemName=dtd_nameal
+idRefAttrTypes=(isAttlistOfElementelemName>>>isIdRefAttrType)$$atts
+
+buildIdrefValidationFct::XmlTrees->XmlArrow
+buildIdrefValidationFct
+=catA.mapbuildIdref
+
+buildIdref::XmlTree->XmlArrow
+buildIdrefdn
+|isDTDAttlistNodedn=isElem>>>(checkIdref$<getName)
+|otherwise=none
+where
+al=getDTDAttributesdn
+attrName=dtd_valueal
+attrType=dtd_typeal
+
+checkIdref::String->XmlArrow
+checkIdrefname
+=hasAttrattrName
+`guards`
+(checkIdVal$<getAttrValueattrName)
+where
+checkIdVal::String->XmlArrow
+checkIdValav
+|attrType==k_idref
+=checkValueDeclaredattrValue
+|nullvalueList
+=err("Attribute "++showattrName++
+" of Element "++showname++
+" must have at least one name."
+)
+|otherwise
+=catA.mapcheckValueDeclared$valueList
+where
+valueList=wordsattrValue
+attrValue=normalizeAttributeValue(Justdn)av
+
+checkValueDeclared::String->XmlArrow
+checkValueDeclaredattrValue
+=ifattrValue`elem`idValueList
+thennone
+elseerr("An Element with identifier "++showattrValue++
+" must appear in the document."
+)
+
+-- ------------------------------------------------------------
+
+
+-- |
+-- 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->LAXmlTreesXmlTree
+checkForUniqueIdsidAttrTypes-- idNodeList
+=fromSLA[](unlistA
+>>>
+isElem
+>>>
+(checkForUniqueId$<<getName&&&this)
+)
+where
+checkForUniqueId::String->XmlTree->SLA[String]XmlTreeXmlTree
+checkForUniqueIdnamex
+=ifA(getState
+>>>
+isA(attrValue`elem`)
+)
+(err("Attribute value "++showattrValue++" of type ID for element "++
+showname++" must be unique within the document."))
+(nextState(attrValue:)>>>none)
+where
+attrValue=getIdValue(isAttlistOfElementname$$idAttrTypes)x
+
+-- |
+-- 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->LAXmlTreeXmlTree
+checkIdReferencesidRefEnv
+=traverseTreeidRefEnv
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.DTDValidation.RE
+ Copyright : Copyright (C) 2008 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ 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.DTDValidation.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
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.DTDValidation.Validation
+ Copyright : Copyright (C) 2008 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ 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.
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.DTDValidation.Validation
+(getDTDSubset
+,validate
+,validateDTD
+,validateDoc
+,removeDoublicateDefs
+,transform
+)
+
+where
+
+importText.XML.HXT.DTDValidation.TypeDefs
+
+importqualifiedText.XML.HXT.DTDValidation.DTDValidationasDTDValidation
+importqualifiedText.XML.HXT.DTDValidation.DocValidationasDocValidation
+importqualifiedText.XML.HXT.DTDValidation.IdValidationasIdValidation
+importqualifiedText.XML.HXT.DTDValidation.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::XmlArrow
+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::XmlArrow
+validateDTD=choiceA
+[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::XmlArrow
+validateDoc
+=validateDoc'$<getDTD
+where
+validateDoc'[]=err"Can't validate document: There is no DOCTYPE declaration in the document."
+validateDoc'(dtdPart:_)=DocValidation.validateDocdtdPart
+<+>
+IdValidation.validateIdsdtdPart
+
+getDTD::XmlArrowS
+getDTD=listA(getDTDSubset
+>>>
+removeDoublicateDefs
+)
+
+-- |
+-- 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::XmlArrow
+transform=choiceA
+[isRoot:->(transformDoc$<getDTD)
+,this:->fatal"Can't transform document: No document root given"
+]
+where
+transformDoc[]=this
+transformDocdtd=DocTransformation.transform(headdtd)
+
+-- |
+-- 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::XmlArrow
+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::XmlArrow
+getDTDSubset=getChildren
+>>>
+(filterA$isDTDDoctype>>>getDTDAttrl>>>isA(hasEntrya_name))
+
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+--
+-- defaut uri computation
+-- this routine is platform dependent
+-- and must be exchanged when porting the toolbox e.g. to windows
+--
+-- Version : $Id: DefaultURI.hs,v 1.4 2006/03/02 10:13:57 hxml Exp $
+
+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.
+--
+-- Version : $Id: MainFunctions.hs,v 1.2 2004/11/20 16:53:15 hxml Exp $
+--
+--
+-- 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
+)
+)
+
+-- ------------------------------------------------------------
+
+
-- |
+-- UTF-8 character parser and simple XML token parsers
+--
+-- Version : $Id: XmlCharParser.hs,v 1.2 2005/05/31 16:01:12 hxml Exp $
+
+moduleText.XML.HXT.Parser.XmlCharParser
+(xmlChar-- xml char parsers
+,xmlNameChar
+,xmlNameStartChar
+,xmlNCNameChar
+,xmlNCNameStartChar
+,xmlLetter
+,xmlSpaceChar
+)
+where
+
+importText.XML.HXT.DOM.Unicode
+importText.ParserCombinators.Parsec
+
+-- ------------------------------------------------------------
+--
+-- Char (2.2)
+--
+
+-- |
+-- parse a single Unicode character
+
+xmlChar::GenParserCharstateUnicode
+xmlChar=satisfyisXmlChar<?>"legal XML character"
+
+-- |
+-- parse a XML name character
+
+xmlNameChar::GenParserCharstateUnicode
+xmlNameChar=satisfyisXmlNameChar<?>"legal XML name character"
+
+-- |
+-- parse a XML name start character
+
+xmlNameStartChar::GenParserCharstateUnicode
+xmlNameStartChar=satisfyisXmlNameStartChar<?>"legal XML name start character"
+
+-- |
+-- parse a XML NCName character
+
+xmlNCNameChar::GenParserCharstateUnicode
+xmlNCNameChar=satisfyisXmlNCNameChar<?>"legal XML NCName character"
+
+-- |
+-- parse a XML NCName start character
+
+xmlNCNameStartChar::GenParserCharstateUnicode
+xmlNCNameStartChar=satisfyisXmlNCNameStartChar<?>"legal XML NCName start character"
+
+-- |
+-- parse a XML letter character
+
+xmlLetter::GenParserCharstateUnicode
+xmlLetter=satisfyisXmlLetter<?>"legal XML letter"
+
+-- |
+-- White Space (2.3)
+--
+-- end of line handling (2.11)
+-- \#x0D and \#x0D\#x0A are mapped to \#x0A
+-- is done in XmlInput before parsing
+-- otherwise \#x0D in internal parsing, e.g. for entities would normalize,
+-- would be transformed
+
+xmlSpaceChar::GenParserCharstateChar
+xmlSpaceChar=satisfyisXmlSpaceChar<?>"white space"
+
+-- ------------------------------------------------------------
+
+
-- ------------------------------------------------------------
+--
+-- input functions
+-- implemented as filer
+--
+-- Version : $Id: XmlInput.hs,v 1.9 2006/03/03 14:20:17 hxml Exp $
+
+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)
+
+-- ------------------------------------------------------------
+
-- |
+-- exports helper functions for the integration of new datatype-libraries
+
+moduleText.XML.HXT.RelaxNG.DataTypeLibUtils
+(errorMsgEqual
+,errorMsgDataTypeNotAllowed
+,errorMsgDataTypeNotAllowed0
+,errorMsgDataTypeNotAllowed2
+,errorMsgDataLibQName
+,errorMsgParam
+
+,rng_length
+,rng_maxLength
+,rng_minLength
+,rng_maxExclusive
+,rng_minExclusive
+,rng_maxInclusive
+,rng_minInclusive
+
+,moduleControl.Arrow
+,moduleText.XML.HXT.DOM.Util
+,moduleText.XML.HXT.RelaxNG.Utils
+,moduleText.XML.HXT.RelaxNG.DataTypes
+
+,FunctionTable
+
+,stringValidFT-- generalized checkString
+,fctTableString-- minLength, maxLenght, length
+,fctTableList-- minLength, maxLenght, length
+
+,stringValid-- checkString
+,numberValid-- checkNumeric
+
+,numParamValid
+
+,CheckA-- Check datatype
+,CheckString-- CheckA String String
+,CheckInteger-- CheckA Integer Integer
+
+,performCheck-- run a CheckA
+,ok-- always true
+,failure-- create an error meesage
+,assert-- create a primitive check from a predicate
+,assertMaybe-- create a primitive check from a maybe
+,checkWith-- convert value before checking
+)
+
+where
+
+importText.XML.HXT.DOM.Util
+
+importText.XML.HXT.RelaxNG.DataTypes
+importText.XML.HXT.RelaxNG.Utils
+
+importControl.Arrow
+
+importData.Either
+importData.Maybe
+
+-- ------------------------------------------------------------
+
+newtypeCheckAab=C{runCheck::a->EitherStringb}
+
+instanceArrowCheckAwhere
+arrf=C(Right.f)-- unit: no check, always o.k., just a conversion
+
+f1>>>f2=C$-- logical and: f1 and f2 must hold
+\x->caserunCheckf1xof
+Righty->runCheckf2y
+Lefte->Lefte
+
+firstf1=C$-- check 1. component of a pair
+\~(x1,x2)->caserunCheckf1x1of
+Righty1->Right(y1,x2)
+Lefte->Lefte
+
+secondf2=C$-- check 2. component of a pair
+\~(x1,x2)->caserunCheckf2x2of
+Righty2->Right(x1,y2)
+Lefte->Lefte
+
+
+
+instanceArrowZeroCheckAwhere
+zeroArrow=C$const(Left"")-- always false: zero
+
+instanceArrowPlusCheckAwhere
+f1<+>f2=C$-- logical or
+\x->caserunCheckf1xof
+Righty1->Righty1
+Lefte1->caserunCheckf2xof
+Righty2->Righty2
+Lefte2->Left(ifnulle1
+thene2
+else
+ifnulle2
+thene1
+elsee1++" or "++e2
+)
+
+typeCheckString=CheckAStringString
+typeCheckInteger=CheckAIntegerInteger
+
+-- | run a check and deliver Just an error message or Nothing
+
+performCheck::CheckAab->a->MaybeString
+performCheckc=eitherJust(constNothing).runCheckc
+
+-- | always failure
+
+failure::(a->String)->CheckAab
+failuremsg=C(Left.msg)
+
+-- | every thing is fine
+
+ok::CheckAaa
+ok=arrid
+
+-- | perform a simple check with a predicate p,
+-- when the predicate holds, assert acts as identity,
+-- else an error message is generated
+
+assert::(a->Bool)->(a->String)->CheckAaa
+assertpmsg=C$\x->ifpxthenRightxelseLeft(msgx)
+
+-- | perform a simple check with a Maybe function, Nothing indicates error
+
+assertMaybe::(a->Maybeb)->(a->String)->CheckAab
+assertMaybefmsg
+=C$\x->casefxof
+Nothing->Left(msgx)
+Justy->Righty
+
+-- | perform a check, but convert the value before checking
+
+checkWith::(a->b)->CheckAbc->CheckAaa
+checkWithfc=C$
+\x->caserunCheckc(fx)of
+Right_->Rightx
+Lefte->Lefte
+
+-- ------------------------------------------------------------
+
+-- RelaxNG attribute names
+
+rng_length,rng_maxLength,rng_minLength
+,rng_maxExclusive,rng_minExclusive,rng_maxInclusive,rng_minInclusive::String
+
+rng_length="length"
+rng_maxLength="maxLength"
+rng_minLength="minLength"
+
+rng_maxExclusive="maxExclusive"
+rng_minExclusive="minExclusive"
+rng_maxInclusive="maxInclusive"
+rng_minInclusive="minInclusive"
+
+-- ------------------------------------------------------------
+
+-- | Function table type
+
+typeFunctionTable=[(String,String->String->Bool)]
+
+-- | Function table for numeric tests,
+-- XML document value is first operand, schema value second
+
+fctTableNum::(Orda,Numa)=>[(String,a->a->Bool)]
+fctTableNum
+=[(rng_maxExclusive,(<))
+,(rng_minExclusive,(>))
+,(rng_maxInclusive,(<=))
+,(rng_minInclusive,(>=))
+]
+
+-- | Function table for string tests,
+-- XML document value is first operand, schema value second
+fctTableString::FunctionTable
+fctTableString
+=[(rng_length,(numParamValid(==)))
+,(rng_maxLength,(numParamValid(<=)))
+,(rng_minLength,(numParamValid(>=)))
+]
+
+-- | Function table for list tests,
+-- XML document value is first operand, schema value second
+
+fctTableList::FunctionTable
+fctTableList
+=[(rng_length,(listParamValid(==)))
+,(rng_maxLength,(listParamValid(<=)))
+,(rng_minLength,(listParamValid(>=)))
+]
+
+{- |
+tests whether a string value matches a numeric param
+
+valid example:
+
+> <data type="CHAR"> <param name="maxLength">5</param> </data>
+
+invalid example:
+
+> <data type="CHAR"> <param name="minLength">foo</param> </data>
+
+-}
+
+numParamValid::(Integer->Integer->Bool)->String->String->Bool
+numParamValidfctab
+=isNumberb
+&&
+(toInteger(lengtha)`fct`(readb))
+
+{- |
+tests whether a list value matches a length constraint
+
+valid example:
+
+> <data type="IDREFS"> <param name="maxLength">5</param> </data>
+
+invalid example:
+
+> <data type="IDREFS"> <param name="minLength">foo</param> </data>
+
+-}
+
+listParamValid::(Integer->Integer->Bool)->String->String->Bool
+listParamValidfctab
+=isNumberb
+&&
+(toInteger(length.words$a)`fct`(readb))
+
+-- ------------------------------------------------------------
+-- new check functions
+
+{- |
+Tests whether a \"string\" datatype value is between the lower and
+upper bound of the datatype and matches all parameters.
+
+All tests are performed on the string value.
+
+ * 1.parameter : datatype
+
+ - 2.parameter : lower bound of the datatype range
+
+ - 3.parameter : upper bound of the datatype range (-1 = no upper bound)
+
+ - 4.parameter : list of parameters
+
+ - 5.parameter : datatype value to be checked
+
+ - return : Just \"Errormessage\" in case of an error, else Nothing
+
+-}
+
+stringValid::DatatypeName->Integer->Integer->ParamList->CheckString
+stringValid=stringValidFTfctTableString
+
+stringValidFT::FunctionTable->DatatypeName->Integer->Integer->ParamList->CheckString
+stringValidFTftdatatypelowerBoundupperBoundparams
+=assertboundsOKboundsErr
+>>>
+paramsStringValidparams
+where
+boundsOKv
+=((lowerBound==0)
+||
+(toInteger(lengthv)>=lowerBound)
+)
+&&
+((upperBound==(-1))
+||
+(toInteger(lengthv)<=upperBound)
+)
+
+boundsErrv
+="Length of "++v
+++" ("++(show$lengthv)++" chars) out of range: "
+++showlowerBound++" .. "++showupperBound
+++" for datatype "++datatype
+
+paramStringValid::(LocalName,String)->CheckString
+paramStringValid(pn,pv)
+=assertparamOK(errorMsgParampnpv)
+where
+paramOKv=paramFctpnvpv
+paramFctn=fromMaybe(const.const$True)$lookupnft
+
+paramsStringValid::ParamList->CheckString
+paramsStringValid
+=foldr(>>>)ok.mapparamStringValid
+
+-- ------------------------------------------------------------
+
+{- |
+Tests whether a \"numeric\" datatype value is between the lower and upper
+bound of the datatype and matches all parameters.
+
+First, the string value is parsed into a numeric representation.
+If no error occur, all following tests are performed on the numeric value.
+
+ * 1.parameter : datatype
+
+ - 2.parameter : lower bound of the datatype range
+
+ - 3.parameter : upper bound of the datatype range (-1 = no upper bound)
+
+ - 4.parameter : list of parameters
+
+ - 5.parameter : datatype value to be checked
+
+ - return : Just \"Errormessage\" in case of an error, else Nothing
+
+-}
+
+numberValid::DatatypeName->Integer->Integer->ParamList->CheckString
+numberValiddatatypelowerBoundupperBoundparams
+=assertisNumbernumErr
+>>>
+checkWithread(assertinRangerangeErr
+>>>
+paramsNumValidparams
+)
+where
+inRange::Integer->Bool
+inRangex=x>=lowerBound
+&&
+x<=upperBound
+
+rangeErrv=("Value = "++showv++" out of range: "
+++showlowerBound++" .. "++showupperBound
+++" for datatype "++datatype
+)
+numErrv
+="Value = "++v++" is not a number"
+
+paramsNumValid::ParamList->CheckInteger
+paramsNumValid
+=foldr(>>>)ok.mapparamNumValid
+
+paramNumValid::(LocalName,String)->CheckInteger
+paramNumValid(pn,pv)
+=assertparamOK(errorMsgParampnpv.show)
+where
+paramOKv=isNumberpv
+&&
+paramFctpnv(readpv)
+paramFctn=fromJust$lookupnfctTableNum
+
+-- ------------------------------------------------------------
+
+{- |
+Error Message for the equality test of two datatype values
+
+ * 1.parameter : datatype
+
+ - 2.parameter : datatype value
+
+ - 3.parameter : datatype value
+
+example:
+
+> errorMsgEqual "Int" "21" "42" -> "Datatype Int with value = 21 expected, but value = 42 found"
+
+-}
+
+errorMsgParam::LocalName->String->String->String
+errorMsgParampnpvv
+=("Parameter restriction: \""
+++pn++" = "++pv
+++"\" does not hold for value = \""++v++"\""
+)
+
+errorMsgEqual::DatatypeName->String->String->String
+errorMsgEqualds1s2
+=("Datatype"++showd++
+" with value = "++shows1++
+" expected, but value = "++shows2++" found"
+)
+errorMsgDataTypeNotAllowed::String->String->[(String,String)]->String->String
+errorMsgDataTypeNotAllowedltpv
+=("Datatype "++showt++" with parameter(s) "++
+formatStringListPairsp++" and value = "++showv++
+" not allowed for DatatypeLibrary "++showl
+)
+
+errorMsgDataTypeNotAllowed0::String->String->String
+errorMsgDataTypeNotAllowed0lt
+=("Datatype "++showt++
+" not allowed for DatatypeLibrary "++showl
+)
+errorMsgDataTypeNotAllowed2::String->String->String->String->String
+errorMsgDataTypeNotAllowed2ltv1v2
+=("Datatype "++showt++
+" with values = "++showv1++
+" and "++showv2++
+" not allowed for DatatypeLibrary "++showl
+)
+
+errorMsgDataLibQName::String->String->String->String
+errorMsgDataLibQNamelnv
+=showv++" is not a valid "++n++" for DatatypeLibrary "++l
+
+-- ------------------------------------------------------------
+
-- | This modul exports the list of supported datatype libraries.
+-- It also exports the main functions to validate an XML instance value
+-- with respect to a datatype.
+
+moduleText.XML.HXT.RelaxNG.DataTypeLibraries
+(datatypeLibraries
+,datatypeEqual
+,datatypeAllows
+)
+where
+
+importText.XML.HXT.DOM.Interface
+(relaxNamespace
+)
+
+importText.XML.HXT.RelaxNG.DataTypeLibUtils
+
+importText.XML.HXT.RelaxNG.DataTypeLibMysql
+(mysqlDatatypeLib)
+
+importText.XML.HXT.RelaxNG.XmlSchema.DataTypeLibW3C
+(w3cDatatypeLib)
+
+importData.Maybe
+(fromJust)
+
+-- ------------------------------------------------------------
+
+
+-- | List of all supported datatype libraries which can be
+-- used within the Relax NG validator modul.
+
+datatypeLibraries::DatatypeLibraries
+datatypeLibraries
+=[relaxDatatypeLib
+,relaxDatatypeLib'
+,mysqlDatatypeLib
+,w3cDatatypeLib
+]
+
+
+{- |
+Tests whether a XML instance value matches a value-pattern.
+
+The following tests are performed:
+
+ * 1. : does the uri exist in the list of supported datatype libraries
+
+ - 2. : does the library support the datatype
+
+ - 3. : does the XML instance value match the value-pattern
+
+The hard work is done by the specialized 'DatatypeEqual' function
+(see also: 'DatatypeCheck') of the datatype library.
+-}
+
+datatypeEqual::Uri->DatatypeEqual
+datatypeEqualurids1c1s2c2
+=ifelemuri(mapfstdatatypeLibraries)
+thendtEqFctds1c1s2c2
+elseJust("Unknown DatatypeLibrary "++showuri)
+where
+DTC_dtEqFct_=fromJust$lookupuridatatypeLibraries
+
+{- |
+Tests whether a XML instance value matches a data-pattern.
+
+The following tests are performed:
+
+ * 1. : does the uri exist in the list of supported datatype libraries
+
+ - 2. : does the library support the datatype
+
+ - 3. : does the XML instance value match the data-pattern
+
+ - 4. : does the XML instance value match all params
+
+The hard work is done by the specialized 'DatatypeAllows' function
+(see also: 'DatatypeCheck') of the datatype library.
+
+-}
+
+datatypeAllows::Uri->DatatypeAllows
+datatypeAllowsuridparamss1c1
+=ifelemuri(mapfstdatatypeLibraries)
+thendtAllowFctdparamss1c1
+elseJust("Unknown DatatypeLibrary "++showuri)
+where
+DTCdtAllowFct__=fromJust$lookupuridatatypeLibraries
+
+
+-- --------------------------------------------------------------------------------------
+-- Relax NG build in datatype library
+
+relaxDatatypeLib::DatatypeLibrary
+relaxDatatypeLib=(relaxNamespace,DTCdatatypeAllowsRelaxdatatypeEqualRelaxrelaxDatatypes)
+
+-- | if there is no datatype uri, the built in datatype library is used
+relaxDatatypeLib'::DatatypeLibrary
+relaxDatatypeLib'=("",DTCdatatypeAllowsRelaxdatatypeEqualRelaxrelaxDatatypes)
+
+-- | The build in Relax NG datatype lib supportes only the token and string datatype,
+-- without any params.
+
+relaxDatatypes::AllowedDatatypes
+relaxDatatypes
+=map((\x->(x,[])).fst)relaxDatatypeTable
+
+datatypeAllowsRelax::DatatypeAllows
+datatypeAllowsRelaxdpv_
+=maybenotAllowed'allowed.lookupd$relaxDatatypeTable
+where
+notAllowed'
+=Just$errorMsgDataTypeNotAllowedrelaxNamespacedpv
+allowed_
+=Nothing
+
+-- | If the token datatype is used, the values have to be normalized
+-- (trailing and leading whitespaces are removed).
+-- token does not perform any changes to the values.
+
+datatypeEqualRelax::DatatypeEqual
+datatypeEqualRelaxds1_s2_
+=maybenotAllowed'checkValues.lookupd$relaxDatatypeTable
+where
+notAllowed'
+=Just$errorMsgDataTypeNotAllowed2relaxNamespaceds1s2
+checkValuespredicate
+=ifpredicates1s2
+thenNothing
+elseJust$errorMsgEqualds1s2
+
+relaxDatatypeTable::[(String,String->String->Bool)]
+relaxDatatypeTable
+=[("string",(==))
+,("token",\s1s2->normalizeWhitespaces1==normalizeWhitespaces2)
+]
+
+
+-- --------------------------------------------------------------------------------------
+
moduleText.XML.HXT.RelaxNG.DataTypes
+where
+
+importText.XML.HXT.DOM.TypeDefs
+
+-- ------------------------------------------------------------
+
+relaxSchemaFile::String
+relaxSchemaFile="Text/XML/HXT/RelaxNG/SpecificationSchema.rng"
+
+
+relaxSchemaGrammarFile::String
+relaxSchemaGrammarFile="Text/XML/HXT/RelaxNG/SpecificationSchemaGrammar.rng"
+
+-- ------------------------------------------------------------
+-- datatypes for the simplification process
+
+a_numberOfErrors,
+a_relaxSimplificationChanges,
+defineOrigName::String
+
+a_numberOfErrors="numberOfErrors"
+a_relaxSimplificationChanges="relaxSimplificationChanges"
+defineOrigName="RelaxDefineOriginalName"
+
+
+typeEnv=[(String,XmlTree)]
+
+-- | Start of a context attribute value
+-- (see also: 'Text.XML.HXT.RelaxNG.Simplification.simplificationStep1')
+--
+-- The value is always followed by the original attribute name and value
+
+contextAttributes::String
+contextAttributes="RelaxContext:"
+
+
+-- | Start of base uri attribute value
+-- (see also: 'simplificationStep1' in "Text.XML.HXT.RelaxNG.Simplification")
+
+contextBaseAttr::String
+contextBaseAttr="RelaxContextBaseURI"
+
+
+-- see simplificationStep5 in Text.XML.HXT.RelaxNG.Simplification
+
+typeOldName=String
+typeNewName=String
+typeNamePair=(OldName,NewName)
+typeRefList=[NamePair]
+
+
+-- ------------------------------------------------------------
+-- datatype library handling
+
+-- | Type of all datatype libraries functions that tests whether
+-- a XML instance value matches a value-pattern.
+--
+-- Returns Just \"errorMessage\" in case of an error else Nothing.
+
+typeDatatypeEqual=DatatypeName->String->Context->String->Context->MaybeString
+
+
+-- | Type of all datatype libraries functions that tests whether
+-- a XML instance value matches a data-pattern.
+--
+-- Returns Just \"errorMessage\" in case of an error else Nothing.
+
+typeDatatypeAllows=DatatypeName->ParamList->String->Context->MaybeString
+
+
+-- | List of all supported datatype libraries
+
+typeDatatypeLibraries=[DatatypeLibrary]
+
+
+-- | Each datatype library is identified by a URI.
+
+typeDatatypeLibrary=(Uri,DatatypeCheck)
+
+typeDatatypeName=String
+
+typeParamName=String
+
+
+-- | List of all supported params for a datatype
+
+typeAllowedParams=[ParamName]
+
+
+-- | List of all supported datatypes and there allowed params
+
+typeAllowedDatatypes=[(DatatypeName,AllowedParams)]
+
+
+-- | The Constructor exports the list of supported datatypes for a library.
+-- It also exports the specialized datatype library functions to validate
+-- a XML instance value with respect to a datatype.
+
+dataDatatypeCheck
+=DTC{dtAllowsFct::DatatypeAllows-- ^ function to test whether a value matches a data-pattern
+,dtEqualFct::DatatypeEqual-- ^ function to test whether a value matches a value-pattern
+,dtAllowedTypes::AllowedDatatypes-- ^ list of all supported params for a datatype
+}
+
+-- ------------------------------------------------------------
+-- datatypes for the validation process
+
+typeUri=String
+
+typeLocalName=String
+
+
+-- | List of parameters; each parameter is a pair consisting of a local name and a value.
+
+typeParamList=[(LocalName,String)]
+
+typePrefix=String
+
+
+-- | A Context represents the context of an XML element.
+-- It consists of a base URI and a mapping from prefixes to namespace URIs.
+
+typeContext=(Uri,[(Prefix,Uri)])
+
+-- | A Datatype identifies a datatype by a datatype library name and a local name.
+
+typeDatatype=(Uri,LocalName)
+
+showDatatype::Datatype->String
+showDatatype(u,ln)
+|nullu=ln
+|otherwise="{"++u++"}"++ln
+
+-- | Represents a name class
+
+dataNameClass=AnyName
+|AnyNameExceptNameClass
+|NameUriLocalName
+|NsNameUri
+|NsNameExceptUriNameClass
+|NameClassChoiceNameClassNameClass
+|NCErrorString
+derivingEq
+
+instanceShowNameClass
+where
+showAnyName="AnyName"
+show(AnyNameExceptnameClass)
+="AnyNameExcept: "++shownameClass
+show(NameurilocalName)
+|nulluri=localName
+|otherwise="{"++uri++"}"++localName
+show(NsNameuri)="{"++uri++"}AnyName"
+show(NsNameExcepturinameClass)
+="NsNameExcept: {"++uri++"}"++shownameClass
+show(NameClassChoicenameClass1nameClass2)
+="NameClassChoice: "++shownameClass1++"|"++shownameClass2
+show(NCErrorstring)
+="NCError: "++string
+
+
+-- | Represents a pattern after simplification
+
+dataPattern=Empty
+|NotAllowedErrMessage
+|Text
+|ChoicePatternPattern
+|InterleavePatternPattern
+|GroupPatternPattern
+|OneOrMorePattern
+|ListPattern
+|DataDatatypeParamList
+|DataExceptDatatypeParamListPattern
+|ValueDatatypeStringContext
+|AttributeNameClassPattern
+|ElementNameClassPattern
+|AfterPatternPattern
+
+instanceShowPatternwhere
+showEmpty="empty"
+show(NotAllowede)=showe
+showText="text"
+show(Choicep1p2)="( "++showp1++" | "++showp2++" )"
+show(Interleavep1p2)="( "++showp1++" & "++showp2++" )"
+show(Groupp1p2)="( "++showp1++" , "++showp2++" )"
+show(OneOrMorep)=showp++"+"
+show(Listp)="list { "++showp++" }"
+show(Datadtpl)=showDatatypedt++showPLpl
+where
+showPL[]=""
+showPLl=" {"++concatMapshowPl++" }"
+showP(ln,v)=" "++ln++" = "++showv
+show(DataExceptdtplp)=show(Datadtpl)++" - ("++showp++" )"
+show(Valuedtv_cx)=showDatatypedt++" "++showv
+show(Attributencp)="attribute "++shownc++" { "++showp++" }"
+show(Elementncp)="element "++shownc++" { "++showp++" }"
+show(Afterp1p2)="( "++showp1++" ; "++showp2++" )"
+
+dataErrMessage=ErrMsgErrLevel[String]
+-- deriving Show
+
+instanceShowErrMessagewhere
+show(ErrMsg_leves)=foldr1(\xy->x++"\n"++y)es
+
+typeErrLevel=Int
+
+-- ------------------------------------------------------------
+
+-- smart constructor funtions for Pattern
+
+-- | smart constructor for NotAllowed
+
+notAllowed::String->Pattern
+notAllowed=notAllowedN0
+
+notAllowed1::String->Pattern
+notAllowed1=notAllowedN1
+
+notAllowed2::String->Pattern
+notAllowed2=notAllowedN2
+
+notAllowedN::ErrLevel->String->Pattern
+notAllowedNls=NotAllowed(ErrMsgl[s])
+
+-- | merge error messages
+--
+-- If error levels are different, the more important is taken,
+-- if level is 2 (max level) both error messages are taken
+-- else the 1. error mesage is taken
+
+mergeNotAllowed::Pattern->Pattern->Pattern
+mergeNotAllowedp1@(NotAllowed(ErrMsgl1s1))p2@(NotAllowed(ErrMsgl2s2))
+|l1<l2=p2
+|l1>l2=p1
+|l1==2=NotAllowed$ErrMsg2(s1++s2)
+|otherwise=p1
+
+-- TODO : weird error when collecting error messages errors are duplicated
+
+mergeNotAllowed_p1_p2
+=notAllowed2"mergeNotAllowed with wrong patterns"
+
+-- | smart constructor for Choice
+
+choice::Pattern->Pattern->Pattern
+choicep1@(NotAllowed_)p2@(NotAllowed_)=mergeNotAllowedp1p2
+choicep1(NotAllowed_)=p1
+choice(NotAllowed_)p2=p2
+choicep1p2=Choicep1p2
+
+-- | smart constructor for Group
+
+group::Pattern->Pattern->Pattern
+groupp1@(NotAllowed_)p2@(NotAllowed_)=mergeNotAllowedp1p2
+group_n@(NotAllowed_)=n
+groupn@(NotAllowed_)_=n
+grouppEmpty=p
+groupEmptyp=p
+groupp1p2=Groupp1p2
+
+-- | smart constructor for OneOrMore
+
+oneOrMore::Pattern->Pattern
+oneOrMoren@(NotAllowed_)=n
+oneOrMorep=OneOrMorep
+
+-- | smart constructor for Interleave
+
+interleave::Pattern->Pattern->Pattern
+interleavep1@(NotAllowed_)p2@(NotAllowed_)=mergeNotAllowedp1p2
+interleave_p2@(NotAllowed_)=p2
+interleavep1@(NotAllowed_)_=p1
+interleavep1Empty=p1
+interleaveEmptyp2=p2
+interleavep1p2=Interleavep1p2
+
+-- | smart constructor for After
+
+after::Pattern->Pattern->Pattern
+afterp1@(NotAllowed_)p2@(NotAllowed_)=mergeNotAllowedp1p2
+after_p2@(NotAllowed_)=p2
+afterp1@(NotAllowed_)_=p1
+afterp1p2=Afterp1p2
+
+
+-- | Possible content types of a Relax NG pattern.
+-- (see also chapter 7.2 in Relax NG specification)
+
+dataContentType=CTEmpty
+|CTComplex
+|CTSimple
+|CTNone
+deriving(Show,Eq,Ord)
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.RelaxNG.Simplification
+ Copyright : Copyright (C) 2008 Torben Kuseler, Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : stable
+ Portability: portable
+
+ The modul creates the simplified form of a Relax NG schema.
+ See also chapter 4 of the Relax NG specification.
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.RelaxNG.Simplification
+(createSimpleForm
+,getErrors
+)
+
+where
+
+
+importControl.Arrow.ListArrows
+
+importText.XML.HXT.DOM.Interface
+importqualifiedText.XML.HXT.DOM.XmlNodeasXN
+(mkAttr
+,mkText
+)
+
+importText.XML.HXT.Arrow.XmlArrow
+importText.XML.HXT.Arrow.XmlIOStateArrow
+
+importText.XML.HXT.Arrow.Namespace
+(processWithNsEnv
+,propagateNamespaces
+)
+
+importText.XML.HXT.Arrow.Edit
+(removeWhiteSpace
+)
+
+importText.XML.HXT.RelaxNG.DataTypes
+importText.XML.HXT.RelaxNG.BasicArrows
+importText.XML.HXT.RelaxNG.CreatePattern
+importText.XML.HXT.RelaxNG.DataTypeLibraries
+importText.XML.HXT.RelaxNG.Utils
+importText.XML.HXT.RelaxNG.Validation
+importText.XML.HXT.RelaxNG.SchemaasS
+importText.XML.HXT.RelaxNG.SchemaGrammarasSG
+
+importData.Maybe
+importData.Char
+importData.List
+
+importSystem.Directory
+(doesFileExist)
+
+
+-- ------------------------------------------------------------
+
+{-
+- 4.1. Annotations: Foreign attributes and elements are removed.
+- 4.2. Whitespace:
+ - For each element other than value and param, each child that is a string
+ containing only whitespace characters is removed. -> fertig
+ - Leading and trailing whitespace characters are removed from the value of each name,
+ type and combine attribute and from the content of each name element. -> fertig
+- 4.3. datatypeLibrary attribute:
+ - The value of each datatypeLibary attribute is transformed by escaping disallowed characters
+ - For any data or value element that does not have a datatypeLibrary attribute,
+ a datatypeLibrary attribute is added.
+ - Any datatypeLibrary attribute that is on an element other than data or value is removed.
+- 4.4. type attribute of value element
+-}
+simplificationStep1::IOSArrowXmlTreeXmlTree
+simplificationStep1
+=({-
+ - 4.5. href attribute
+ - The value of the href attribute on an externalRef or include element is first
+ - transformed by escaping disallowed characters
+ - The URI reference is then resolved into an absolute form
+ - The value of the href attribute will be used to construct an element.
+ -}
+(processHref$<getBaseURI)
+>>>
+-- 4.10 QNames
+processWithNsEnvprocessEnvNames[("xml",xmlNamespace)]
+>>>
+-- 4.4 For any data or value element that does not have a datatypeLibrary attribute,
+-- a datatypeLibrary attribute is added.
+-- Wird vorgezogen, da danach der Rest in einem Baumdurchlauf erledigt werden kann
+processdatatypeLib""
+>>>
+processTopDownWithAttrl
+(
+(-- 4.1 Foreign attributes and elements are removed
+none
+`when`
+((isElem>>>negisRoot
+>>>
+getNamespaceUri
+>>>
+isA(\uri->(not$compareURIurirelaxNamespace))
+)
+`orElse`
+(isAttr
+>>>
+getNamespaceUri
+>>>
+isA(\uri->(uri/=""&&(not$compareURIurirelaxNamespace)))
+)
+)
+)
+>>>
+(-- 4.2 For each element other than value and param, each child that
+-- is a string containing only whitespace characters is removed.
+(processChildrenremoveWhiteSpace
+`whenNot`
+(isRngParam`orElse`isRngValue)
+)
+`when`isElem
+)
+>>>
+(-- 4.2 Leading and trailing whitespace characters are removed from the value
+-- of each name, type and combine attribute ...
+changeAttrValuenormalizeWhitespace
+`when`
+(isRngAttrName`orElse`isRngAttrType`orElse`isRngAttrCombine)
+)
+>>>
+(-- 4.2 ... and from the content of each name element.
+processChildren(changeTextnormalizeWhitespace)
+`when`
+isRngName
+)
+>>>
+(-- 4.3 The value of each datatypeLibary attribute is transformed
+-- by escaping disallowed characters
+changeAttrValueescapeURI
+`when`
+isRngAttrDatatypeLibrary
+)
+>>>
+(-- The value of the datatypeLibary attribute has to be a valid URI
+(mkRelaxError""$<(getRngAttrDatatypeLibrary
+>>>
+arr(\a->("datatypeLibrary attribute: "++
+a++" is not a valid URI"
+)
+)
+)
+)
+`when`
+(isElem
+>>>
+hasRngAttrDatatypeLibrary
+>>>
+getRngAttrDatatypeLibrary>>>isA(not.isRelaxAnyURI)
+)
+)
+>>>
+(-- 4.3 Any datatypeLibrary attribute that is on an element
+-- other than data or value is removed.
+removeAttr"datatypeLibrary"
+`when`
+(isElem
+>>>
+neg(isRngData`orElse`isRngValue)
+>>>
+hasRngAttrDatatypeLibrary
+)
+)
+>>>
+(-- 4.4 For any value element that does not have a type attribute,
+-- a type attribute is added with value token and the value of
+-- the datatypeLibrary attribute is changed to the empty string.
+(addAttr"type""token"
+>>>
+addAttr"datatypeLibrary"""
+)
+`when`
+(isRngValue>>>neghasRngAttrType)
+)
+)
+)`when`collectErrors
+where
+processHref::String->IOSArrowXmlTreeXmlTree
+processHrefuri
+=processChildren
+(choiceA
+[(isElem>>>hasAttr"xml:base")
+:->(ifA(isExternalRefInclude>>>hasRngAttrHref)
+(-- The value of the href attribute is transformed by
+-- escaping disallowed characters
+(processAttrl(changeAttrValueescapeURI`when`isRngAttrHref))
+>>>-- compute the new base uri from the old uri and the href attribute
+(addAttr"href"$<(absURI"href"$<(absURI"xml:base"uri)))
+>>>
+(processHref$<absURI"xml:base"uri)
+)-- element without a href attribute, just compute the new base uri
+(processHref$<absURI"xml:base"uri)
+)
+,(isExternalRefInclude>>>hasRngAttrHref)
+:->(-- The value of the href attribute is transformed by
+-- escaping disallowed characters
+(processAttrl(changeAttrValueescapeURI`when`isRngAttrHref))
+>>>
+(addAttr"href"$<absURI"href"uri)
+)
+,this
+:->processHrefuri
+]
+)
+where
+absURI::String->String->IOSArrowXmlTreeString
+absURIattrNameu
+=(getAttrValueattrName
+>>>
+arr(\a->fromMaybe""(expandURIStringau))
+>>>-- the uri should not have a fragment-identifier (4.5)
+((arr(++", it is not a valid URI for text/xml"))
+`whenNot`
+(getFragmentFromURI>>>isAnull)
+)
+)
+
+processEnvNames::[(String,String)]->IOSArrowXmlTreeXmlTree
+processEnvNamesenv
+=(((replaceQNamesenv$<getAttrValue"name")
+`when`
+((isRngElement`orElse`isRngAttribute)
+>>>
+getRngAttrName
+>>>
+isA(elem':')
+)
+)
+>>>
+((addAttrl(getBaseURI>>>createAttrL))
+`when`
+isRngValue
+)
+)
+where
+createAttrL::IOSArrowStringXmlTree
+createAttrL
+=setBaseUri&&&constA(mapcreateAttrenv)>>>arr2L(:)
+where
+
+createAttr::(String,String)->XmlTree
+createAttr(pre,uri)
+=XN.mkAttr(mkNamenm)[XN.mkTexturi]
+where
+nm|nullpre="RelaxContextDefault"
+|otherwise=contextAttributes++pre
+
+setBaseUri::IOSArrowStringXmlTree
+setBaseUri=mkAttr(mkNamecontextBaseAttr)(txt$<this)
+
+replaceQNames::[(String,String)]->String->IOSArrowXmlTreeXmlTree
+replaceQNamesename
+|isNothinguri
+=mkRelaxError""("No Namespace-Mapping for the prefix "++showpre++
+" in the Context of Element: "++showname
+)
+|otherwise
+=addAttr"name"("{"++(fromJusturi)++"}"++local)
+where
+(pre,local')=span(/=':')name
+local=taillocal'
+uri::MaybeString
+uri=lookuppree
+
+-- The value of the added datatypeLibrary attribute is the value of the
+-- datatypeLibrary attribute of the nearest ancestor element that
+-- has a datatypeLibrary attribute, or the empty string
+-- if there is no such ancestor.
+processdatatypeLib::(ArrowXmla)=>String->aXmlTreeXmlTree
+processdatatypeLiblib
+=processChildren$
+choiceA
+[(isElem>>>hasRngAttrDatatypeLibrary
+-- set the new datatypeLibrary value
+)
+:->
+(processdatatypeLib$<getRngAttrDatatypeLibrary)
+,((isRngData`orElse`isRngValue)
+>>>
+neghasRngAttrDatatypeLibrary
+-- add a datatypeLibrary attribute
+)
+:->
+(addAttr"datatypeLibrary"lib>>>processdatatypeLiblib)
+,this
+:->
+processdatatypeLiblib
+]
+
+-- ------------------------------------------------------------
+
+
+{-
+- 4.5. href attribute
+ - see simplificationStep1
+- 4.6. externalRef element
+ - An element is constructed using the URI reference
+ that is the value of href attribute
+ - This element must match the syntax for pattern.
+ - The element is transformed by recursively applying the rules from
+ this subsection and from previous subsections of this section.
+ - This must not result in a loop.
+ - Any ns attribute on the externalRef element is transferred
+ to the referenced element if the referenced element does
+ not already have an ns attribute.
+ - The externalRef element is then replaced by the referenced element.
+- 4.7. include element
+ - An element is constructed using the URI reference that is the
+ value of href attribute
+ - This element must be a grammar element, matching the syntax for grammar.
+ - This grammar element is transformed by recursively applying the rules
+ from this subsection and from previous subsections of this section.
+ - This must not result in a loop.
+
+ - If the include element has a start component, then the grammar element
+ must have a start component.
+ - If the include element has a start component, then all start components
+ are removed from the grammar element.
+ - If the include element has a define component, then the grammar element
+ must have a define component with the same name.
+ - For every define component of the include element, all define components
+ with the same name are removed from the grammar element.
+
+ - The include element is transformed into a div element.
+ - The attributes of the div element are the attributes of the
+ include element other than the href attribute.
+ - The children of the div element are the grammar element
+ - The grammar element is then renamed to div.
+-}
+
+simplificationStep2::Attributes->Bool->Bool->[Uri]->[Uri]->IOSArrowXmlTreeXmlTree
+simplificationStep2readOptionsvalidateExternalRefvalidateIncludeextHRefsincludeHRefs=
+(processTopDown(
+((importExternalRef$<<(getRngAttrNs&&&getRngAttrHref))
+`when`
+isRngExternalRef
+)
+>>>
+((importInclude$<getAttrValue"href")
+`when`
+isRngInclude
+)
+)
+)`when`collectErrors
+where
+importExternalRef::String->String->IOSArrowXmlTreeXmlTree
+importExternalRefnshref
+=ifA(-- test whether the referenced schema exists
+neg$constAhref>>>getPathFromURI>>>isIOAdoesFileExist
+)
+(mkRelaxError""
+("Can't read "++showhref++
+", referenced in externalRef-Pattern"
+)
+)
+(ifP(const$elemhrefextHRefs)
+-- if the referenced name already exists in the list of processed ref attributes
+-- we have found a loop
+(mkRelaxError""
+("loop in externalRef-Pattern, "++
+formatStringListArr(reverse$href:extHRefs)
+)
+)
+(ifA(ifvalidateExternalRef-- if validation parameters are set
+thenvalidateDocWithRelaxS.relaxSchemaArrow[]href-- the referenced schema is validated with respect to
+elsenone-- the Relax NG spezification
+)
+(mkRelaxError""
+("The content of the schema "++showhref++
+", referenced in externalRef does not "++
+"match the syntax for pattern"
+)
+)
+(readForRelaxreadOptionshref
+>>>
+simplificationStep1-- perform the transformations from previous steps
+>>>
+simplificationStep2readOptionsvalidateExternalRefvalidateInclude(href:extHRefs)includeHRefs
+>>>
+getChildren-- remove the root node
+>>>
+(-- Any ns attribute on the externalRef element
+-- is transferred to the referenced element
+addAttr"ns"ns
+`when`
+(getRngAttrNs>>>isA(\a->a==""&&ns/=""))
+)
+)
+)
+)
+
+importInclude::String->IOSArrowXmlTreeXmlTree
+importIncludehref
+=ifA(-- test whether the referenced schema exists
+neg$constAhref>>>getPathFromURI>>>isIOAdoesFileExist
+)
+(mkRelaxError""
+("Can't read "++showhref++
+", referenced in include-Pattern"
+)
+)
+(ifP(const$elemhrefincludeHRefs)
+-- if the referenced name still exists in the list of processed
+-- ref attributes we have found a loop
+(mkRelaxError""
+("loop in include-Pattern, "++
+formatStringListArr(reverse$href:includeHRefs)
+)
+)
+(ifA(ifvalidateInclude-- if the parameter is set
+thenvalidateDocWithRelaxSG.relaxSchemaArrow[]href-- the referenced schema is validated with respect to
+elsenone-- the Relax NG grammar element
+)
+(mkRelaxError""
+("The content of the schema "++showhref++
+", referenced in include does not match "++
+"the syntax for grammar"
+)
+)
+(processIncludehref$<(readForRelaxreadOptionshref
+>>>
+simplificationStep1-- perform the transformations from previous steps
+>>>
+simplificationStep2readOptionsvalidateExternalRefvalidateIncludeextHRefs(href:includeHRefs)
+>>>
+getChildren-- remove the root node
+)
+)
+)
+)
+
+processInclude::String->XmlTree->IOSArrowXmlTreeXmlTree
+processIncludehrefnewDoc
+=-- The include element is transformed into a div element.
+setRngNameDiv
+>>>
+-- The attributes of the div element are the attributes of
+-- the include element other than the href attribute.
+removeAttr"href"
+>>>
+checkIncludehrefnewDoc
+
+
+insertNewDoc::XmlTree->Bool->[String]->IOSArrowXmlTreeXmlTree
+insertNewDocnewDochasStartdefNames
+=insertChildrenAt0$
+constAnewDoc
+>>>
+-- If the include element has a start component, then all start components
+-- are removed from the grammar element.
+(removeStartComponent`whenP`(consthasStart))
+>>>
+-- For every define component of the include element, all define components
+-- with the same name are removed from the grammar element.
+((removeDefineComponentdefNames)`whenP`(const$defNames/=[]))
+>>>
+-- The grammar element is then renamed to div.
+setRngNameDiv
+
+
+checkInclude::String->XmlTree->IOSArrowXmlTreeXmlTree
+checkIncludehrefnewDoc
+=ifA(-- If the include element has a start component, then the grammar element
+-- must have a start component.
+hasStartComponent&&&(constAnewDoc>>>hasStartComponent)
+>>>
+isA(\(a,b)->ifathenbelseTrue)
+)
+(ifA(-- If the include element has a define component, then the grammar element
+-- must have a define component with the same name.
+getDefineComponents&&&(constAnewDoc>>>getDefineComponents)
+>>>
+isA(\(a,b)->(diffab)==[])
+)
+(insertNewDocnewDoc$<<hasStartComponent&&&getDefineComponents)
+(mkRelaxError""
+("Define-pattern missing in schema "++showhref++
+", referenced in include-pattern"
+)
+)
+)
+(mkRelaxError""
+("Grammar-element without a start-pattern in schema "++
+showhref++", referenced in include-pattern"
+)
+)
+where
+diffab=(noDoublesa)\\(noDoublesb)
+
+removeStartComponent::IOSArrowXmlTreeXmlTree
+removeStartComponent
+=processChildren$
+choiceA[
+isRngStart:->none,
+isRngDiv:->removeStartComponent,
+this:->this
+]
+
+removeDefineComponent::[String]->IOSArrowXmlTreeXmlTree
+removeDefineComponentdefNames
+=processChildren$
+choiceA[
+(isRngDefine
+>>>
+getRngAttrName
+>>>
+isA(\n->elemndefNames)):->none,
+(isElem>>>getName>>>isA(=="div")):->(removeDefineComponentdefNames),
+(constA"foo">>>isA(=="foo")):->this
+]
+
+hasStartComponent::IOSArrowXmlTreeBool
+hasStartComponent=listAhasStartComponent'>>>arr(anyid)
+where
+hasStartComponent'::IOSArrowXmlTreeBool
+hasStartComponent'
+=getChildren
+>>>
+choiceA[
+isRngStart:->(constATrue),
+isRngDiv:->hasStartComponent',
+this:->(constAFalse)
+]
+
+getDefineComponents::IOSArrowXmlTree[String]
+getDefineComponents=listAgetDefineComponents'
+>>>
+arr(\xs->[x|x<-xs,x/=""])
+where
+getDefineComponents'::IOSArrowXmlTreeString
+getDefineComponents'
+=getChildren
+>>>
+choiceA
+[isRngDefine:->getRngAttrName
+,isRngDiv:->getDefineComponents'
+,this:->constA""
+]
+
+
+-- ------------------------------------------------------------
+
+
+{-
+- 4.8. name attribute of element and attribute elements
+ - The name attribute on an element or attribute element
+ is transformed into a name child element.
+ - If an attribute element has a name attribute but no ns attribute,
+ then an ns="" attribute is added to the name child element.
+- 4.9. ns attribute
+ - For any name, nsName or value element that does not have
+ an ns attribute, an ns attribute is added.
+ - any ns attribute that is on an element other than name,
+ nsName or value is removed.
+- 4.10. QNames
+ - For any name element containing a prefix, the prefix is removed
+ and an ns attribute is added replacing any existing ns attribute.
+ - The value of the added ns attribute is the value to which the
+ namespace map of the context of the name element maps the prefix.
+ - The context must have a mapping for the prefix.
+-}
+simplificationStep3::IOSArrowXmlTreeXmlTree
+simplificationStep3=
+(processTopDown(
+(-- 4.8 The name attribute on an element or attribute
+-- element is transformed into a name child element
+(insertChildrenAt0(mkRngNamenone(txt$<getRngAttrName))
+)
+>>>
+(-- 4.8 If an attribute element has a name attribute but no ns attribute,
+-- then an ns="" attribute is added to the name child element
+(processChildren(addAttr"ns"""`when`isRngName))
+`when`
+(isRngAttribute>>>hasRngAttrName>>>neghasRngAttrNs)
+)
+>>>
+removeAttr"name"
+)
+`when`
+((isRngElement`orElse`isRngAttribute)>>>hasRngAttrName)
+)
+>>>
+-- 4.9 For any name, nsName or value element that does not have
+-- an ns attribute, an ns attribute is added.
+processnsAttribute""
+>>>
+processTopDown(
+(-- 4.9 any ns attribute that is on an element other than name,
+-- nsName or value is removed.
+(removeAttr"ns")
+`when`
+(isElem>>>neg(isRngName`orElse`isRngNsName`orElse`isRngValue))
+)
+>>>
+(-- 4.10 For any name element containing a prefix, the prefix is removed and an ns attribute
+-- is added replacing any existing ns attribute.
+(replaceNameAttr$<(getChildren>>>isText>>>getText))
+`when`
+isRngName
+)
+)
+)`when`collectErrors
+where
+replaceNameAttr::(ArrowXmla)=>String->aXmlTreeXmlTree
+replaceNameAttrname
+=(addAttr"ns"pre>>>processChildren(changeText$constlocal))
+`whenP`
+(const$elem'}'name)
+where
+(pre',local')=span(/='}')name
+pre=tailpre'
+local=taillocal'
+
+processnsAttribute::String->IOSArrowXmlTreeXmlTree
+processnsAttributename
+=processChildren$
+choiceA[
+-- set the new ns attribute value
+(isElem>>>hasRngAttrNs)
+:->(processnsAttribute$<getRngAttrNs),
+-- For any name, nsName or value element that does not have
+-- an ns attribute, an ns attribute is added.
+(isNameNsNameValue>>>neghasRngAttrNs)
+:->(addAttr"ns"name>>>processnsAttributename),
+this:->(processnsAttributename)
+]
+
+
+-- ------------------------------------------------------------
+
+
+{-
+- 4.11 Each div element is replaced by its children
+- 4.12 Number of child elements
+ - A define, oneOrMore, zeroOrMore, optional, list or mixed element
+ is transformed so that it has exactly one child element
+ - An element element is transformed so that it has exactly two child elements
+ - A except element is transformed so that it has exactly one child element
+ - If an attribute element has only one child element (a name class), then a text element is added.
+ - A choice, group or interleave element is transformed so that it has exactly two child elements.
+- 4.13 A mixed element is transformed into an interleaving with a text element
+- 4.14 An optional element is transformed into a choice with empty
+- 4.15 A zeroOrMore element is transformed into a choice between oneOrMore and empty
+- 4.16. Constraints: no transformation is performed, but various constraints are checked.
+ - An except element that is a child of an anyName element must not have any anyName descendant elements.
+ - An except element that is a child of an nsName element must not have any nsName or anyName
+ descendant elements.
+ - A name element that occurs as the first child of an attribute element or as the descendant of the
+ first child of an attribute element and that has an ns attribute with value equal to the empty
+ string must not have content equal to xmlns.
+ - A name or nsName element that occurs as the first child of an attribute element or as the
+ descendant of the first child of an attribute element must not have an ns attribute with
+ value http://www.w3.org/2000/xmlns.
+ - A data or value element must be correct in its use of datatypes.
+-}
+simplificationStep4::IOSArrowXmlTreeXmlTree
+simplificationStep4=
+(processTopDown(
+(-- Each div element is replaced by its children.
+(getChildren>>>simplificationStep4)
+`when`
+isRngDiv
+)
+>>>
+(-- A define, oneOrMore, zeroOrMore, optional, list or mixed element
+-- is transformed so that it has exactly one child element
+(replaceChildren
+(mkRngGroup
+(setChangesAttr$<(getName>>>arr("group-Pattern: "++)))
+getChildren
+)
+)
+`when`
+(isDefineOneOrMoreZeroOrMoreOptionalListMixed
+>>>
+noOfChildren(>1)
+)
+)
+>>>
+(-- An element element is transformed so that it has exactly two child elements
+(replaceChildren
+((getChildren>>>isNameAnyNameNsName)
+<+>
+(mkRngGroupnone
+(getChildren
+>>>
+negisNameAnyNameNsName
+)
+)
+)
+)
+`when`
+(isRngElement>>>noOfChildren(>2))
+)
+>>>
+(-- A except element is transformed so that it has exactly one child element.
+replaceChildren(mkRngChoicenonegetChildren)
+`when`
+(isRngExcept>>>noOfChildren(>1))
+)
+>>>
+(-- If an attribute element has only one child element
+-- (a name class), then a text element is added.
+insertChildrenAt1(mkRngTextnone)
+`when`
+(isRngAttribute>>>noOfChildren(==1))
+)
+>>>
+(-- A choice, group or interleave element is transformed so
+-- that it has exactly two child elements.
+((wrapPattern2Two$<getName)>>>simplificationStep4)
+`when`
+(isChoiceGroupInterleave
+>>>
+noOfChildren(\i->i>2||i==1)
+)
+)
+>>>
+(-- A mixed element is transformed into an interleaving with a text element
+(mkRngInterleave
+(setChangesAttr"mixed is transformed into an interleave")
+(getChildren
+<+>
+mkRngText
+(setChangesAttr("new text-Pattern: mixed is transformed into "++
+" an interleave with text"
+)
+)
+)
+)
+`when`
+isRngMixed
+)
+>>>
+(-- An optional element is transformed into a choice with empty
+(mkRngChoice
+(setChangesAttr"optional is transformed into a choice")
+(getChildren
+<+>
+mkRngEmpty
+(setChangesAttr("new empty-Pattern: optional is transformed "++
+" into a choice with empty"
+)
+)
+)
+)
+`when`
+isRngOptional
+)
+>>>
+(-- A zeroOrMore element is transformed into a choice between oneOrMore and empty
+(mkRngChoice
+(setChangesAttr"zeroOrMore is transformed into a choice")
+((mkRngOneOrMore
+(setChangesAttr("zeroOrMore is transformed into a "++
+"choice between oneOrMore and empty"
+)
+)
+getChildren
+)
+<+>
+(mkRngEmpty
+(setChangesAttr("new empty-Pattern: zeroOrMore is transformed "++
+"into a choice between oneOrMore and empty"
+)
+)
+)
+)
+)
+`when`
+isRngZeroOrMore
+)
+)
+)`when`collectErrors
+
+
+-- ------------------------------------------------------------
+
+
+restrictionsStep1::IOSArrowXmlTreeXmlTree
+restrictionsStep1=
+(processTopDown(
+((mkRelaxError""
+("An except element that is a child of an anyName "++
+"element must not have any anyName descendant elements"
+)
+)
+`when`
+(isRngAnyName
+>>>
+getChildren
+>>>
+isRngExcept
+>>>
+deepisRngAnyName
+)
+)
+>>>
+((mkRelaxError""
+("An except element that is a child of an nsName element "++
+"must not have any nsName or anyName descendant elements."
+)
+)
+`when`
+(isRngNsName
+>>>
+getChildren
+>>>
+isRngExcept
+>>>
+deep(isRngAnyName`orElse`isRngNsName)
+)
+)
+>>>
+((mkRelaxError""
+("A name element that occurs as the first child or descendant of "++
+"an attribute and has an ns attribute with an empty value must "++
+"not have content equal to \"xmlns\""
+)
+)
+`when`
+(isRngAttribute
+>>>
+firstChild
+>>>
+(multi(isRngName>>>hasRngAttrNs))
+>>>
+((getRngAttrNs>>>isAnull)
+`guards`
+(getChildren>>>getText>>>isA(=="xmlns"))
+)
+)
+)
+>>>
+((mkRelaxError""
+("A name or nsName element that occurs as the first child or "++
+"descendant of an attribute must not have an ns attribute "++
+"with value http://www.w3.org/2000/xmlns"
+)
+)
+`when`
+(isRngAttribute
+>>>
+firstChild
+>>>
+(multi(isNameNsName>>>hasRngAttrNs))
+>>>
+getRngAttrNs
+>>>
+isA(compareURIxmlnsNamespace)
+)
+)
+>>>-- A data or value element must be correct in its use of datatypes.
+((checkDatatype$<<getRngAttrDatatypeLibrary&&&getRngAttrType)
+`when`
+(isRngData`orElse`isRngValue)
+)
+)
+)`when`collectErrors
+where
+
+-- the datatypeLibrary attribute must identify a valid datatype library
+
+checkDatatype::Uri->DatatypeName->IOSArrowXmlTreeXmlTree
+checkDatatypelibNametypeName
+=ifP(const$elemlibName$mapfstdatatypeLibraries)
+(checkTypelibNametypeNameallowedDataTypes)
+(mkRelaxError""
+("DatatypeLibrary "++showlibName++" not found")
+)
+where
+DTC__allowedDataTypes=fromJust$lookuplibNamedatatypeLibraries
+
+-- the type attribute must identify a datatype within the datatype library identified
+-- by the value of the datatypeLibrary attribute.
+
+checkType::Uri->DatatypeName->AllowedDatatypes->IOSArrowXmlTreeXmlTree
+checkTypelibNametypeNameallowedTypes
+=ifP(const$elemtypeName$mapfstallowedTypes)
+(checkParamstypeNamelibNamegetParams$<
+(listA(getChildren>>>isRngParam>>>getRngAttrName))
+)
+(mkRelaxError""
+("Datatype "++showtypeName++
+" not declared for DatatypeLibrary "++showlibName
+)
+)
+where
+getParams=fromJust$lookuptypeNameallowedTypes
+
+-- For a data element, the parameter list must be one that is allowed by the datatype
+
+checkParams::DatatypeName->Uri->AllowedParams->[ParamName]->IOSArrowXmlTreeXmlTree
+checkParamstypeNamelibNameallowedParamsparamNames
+=(mkRelaxError""
+("Param(s): "++formatStringListQuotdiff++
+" not allowed for Datatype "++showtypeName++
+" in Library "++
+show(ifnulllibName
+thenrelaxNamespace
+elselibName
+)
+)
+)
+`when`
+(isRngData>>>isA(const$diff/=[]))
+where
+diff=filter(\param->not$elemparamallowedParams)paramNames
+
+
+-- ------------------------------------------------------------
+
+
+{-
+- 4.17. combine attribute
+ - For each grammar element, all define elements with the same name are combined together.
+ - Similarly, for each grammar element all start elements are combined together.
+- 4.18. grammar element
+ - A grammar must have a start child element.
+ - Transform the top-level pattern p into <grammar><start>p</start></grammar>.
+ - Rename define elements so that no two define elements anywhere in the schema
+ have the same name. To rename a define element, change the value of its name
+ attribute and change the value of the name attribute of all ref and parentRef
+ elements that refer to that define element.
+ - Move all define elements to be children of the top-level grammar element
+ - Replace each nested grammar element by the child of its start element
+ - Rename each parentRef element to ref.
+-}
+simplificationStep5::IOSArrowXmlTreeXmlTree
+simplificationStep5
+=(processTopDown
+(((((deepisRngRelaxError)
+<+>
+(mkRelaxError"""A grammar must have a start child element")
+)
+`when`
+(neg(getChildren>>>isRngStart))
+)
+>>>
+-- For each grammar element, all define elements with the same
+-- name are combined together.
+(combinePatternList"define"$<(getPatternNamesInGrammar"define">>>arrnub))
+>>>
+-- Similarly, for each grammar element all start elements
+-- are combined together.
+(combinePatternList"start"$<(getPatternNamesInGrammar"start">>>arrnub))
+)
+`when`
+isRngGrammar
+)
+>>>
+(-- transform the top-level pattern p into <grammar><start>p</start></grammar>.
+(replaceChildren
+(mkRngGrammarnone
+(mkRngStartnonegetChildren)
+)
+)
+`when`
+neg(getChildren>>>isRngGrammar)
+)
+>>>
+(renameDefines$<<
+(getPatternNamesInGrammar"define"
+>>>
+(createUniqueNames$<(getAndSetCounter"define_id">>>arrread))
+&&&
+constA[]
+)
+)
+>>>
+-- Move all define elements to be children of the top-level grammar element
+(processChildren
+(-- root node
+processChildren
+(-- the first grammar pattern remains unchanged
+(deleteAllDefines
+<+>
+(getAllDefines>>>processChildrendeleteAllDefines)
+)
+>>>
+processTopDown
+((-- Replace each nested grammar element by the child of its start element
+(getChildren>>>isRngStart>>>getChildren)
+`when`
+isRngGrammar
+)
+>>>
+(-- Rename each parentRef element to ref.
+(setRngNameRef
+`when`
+isRngParentRef
+)
+)
+)
+)
+)
+)
+)`when`collectErrors
+where
+getPatternNamesInGrammar::(ArrowXmla)=>String->aXmlTree[String]
+getPatternNamesInGrammarpattern
+=processChildren
+(processTopDown(none`when`isRngGrammar))
+>>>
+listA((multi(isElem>>>hasRngNamepattern))
+>>>
+getRngAttrName
+)
+
+createUniqueNames::Int->IOSArrow[String]RefList
+createUniqueNamesnum
+=arr(\l->uniquelnum)
+>>>
+perform(setParamInt"define_id"$<arr(maxnum.getNextValue))
+where
+unique::[String]->Int->RefList
+unique[]_=[]
+unique(x:xs)num'=(x,(shownum')):(uniquexs(num'+1))
+getNextValue::RefList->Int
+getNextValue[]=0
+getNextValuerl=maximum(map(read.snd)rl)+1
+
+renameDefines::RefList->RefList->IOSArrowXmlTreeXmlTree
+renameDefinesrefparentRef
+=processChildren
+(choiceA
+[isRngDefine
+:->(-- the original name is needed for error messages
+addAttrdefineOrigName$<getRngAttrName
+>>>
+-- rename the define-pattern
+-- the new name is looked up in the ref table
+addAttr"name"$<(getRngAttrName
+>>>
+arr(\n->fromJust$lookupnref)
+)
+>>>
+renameDefinesrefparentRef
+)
+,isRngGrammar
+:->(renameDefines$<<((-- compute all define names in the grammar
+getPatternNamesInGrammar"define"
+>>>
+-- create a new (unique) name for all define names
+(createUniqueNames$<(getParamInt0"define_id"))
+)
+&&&
+-- set the old ref list to be the new parentRef list
+constAref
+)
+)
+,isRngRef
+:->(ifA(getRngAttrName
+>>>
+isA(\name->(elemname(mapfstref)))
+)
+(-- the original name is needed for error messages
+addAttrdefineOrigName$<getRngAttrName
+>>>
+-- rename the ref-pattern
+-- the new name is looked up in the ref table
+addAttr"name"$<(getRngAttrName
+>>>
+arr(\n->fromJust$lookupnref)
+)
+)
+(-- the referenced pattern does not exist in the schema
+mkRelaxError""$<(getRngAttrName
+>>>
+arr(\n->("Define-Pattern with name "++shown++
+" referenced in ref-Pattern not "++
+"found in schema"
+)
+)
+)
+)
+)
+,isRngParentRef-- same as ref, but the parentRef list is used
+:->(ifA(getRngAttrName
+>>>
+isA(\name->(elemname(mapfstparentRef)))
+)
+(addAttrdefineOrigName$<getRngAttrName
+>>>
+addAttr"name"$<(getRngAttrName
+>>>
+arr(\n->fromJust$lookupnparentRef)
+)
+)
+(mkRelaxError""$<
+(getRngAttrName
+>>>
+arr(\n->("Define-Pattern with name "++shown++
+" referenced in parentRef-Pattern "++
+"not found in schema"
+)
+)
+)
+)
+)
+,this
+:->renameDefinesrefparentRef
+]
+)
+
+
+getAllDefines::IOSArrowXmlTreeXmlTree
+getAllDefines=multiisRngDefine
+
+deleteAllDefines::IOSArrowXmlTreeXmlTree
+deleteAllDefines=processTopDown$none`when`isRngDefine
+
+combinePatternList::String->[String]->IOSArrowXmlTreeXmlTree
+combinePatternList_[]=this
+combinePatternListpattern(x:xs)
+=(replaceChildren$combinePatternpatternx)
+>>>
+combinePatternListpatternxs
+
+-- combine a define- or start-pattern (first parameter) with a
+-- specific name (second parameter)
+combinePattern::String->String->IOSArrowXmlTreeXmlTree
+combinePatternpatternname
+=createPatternElemspatternname
+<+>
+(getChildren>>>deletePatternElemspatternname)
+
+createPatternElems::String->String->IOSArrowXmlTreeXmlTree
+createPatternElemspatternname
+=(((listA(getElemspatternname>>>getRngAttrCombine))
+>>>
+checkPatternCombinepatternname
+)
+-- After determining this unique value, the combine attributes are removed.
+&&&
+(listA(getElemspatternname>>>removeAttr"combine")))
+>>>-- ((errorCode::Int,errorMessage::String), result::XmlTrees)
+choiceA
+[isA(\((code,_),_)->code==0)
+:->
+(mkRelaxError""$<arr(snd.fst))
+,isA(\((code,str),_)->code==1&&str=="")
+:->
+arrLsnd
+,isA(\((code,str),_)->code==1&&str/="")
+:->
+(createPatternElempatternname$<<
+(arr(snd.fst)&&&(arrsnd))
+)
+,this
+:->
+(mkRelaxError""
+("Can't create Pattern: "++showpattern++
+" with name "++showname++" in createPatternElems"
+)
+)
+]
+
+createPatternElem::(ArrowXmla)=>String->String->String->XmlTrees->anXmlTree
+createPatternElempatternnamecombinetrees
+=mkRngElementpattern(mkAttr(mkName"name")(txtname))
+((mkRngElementcombinenone
+(arrL(consttrees)>>>getChildren)
+)
+>>>
+wrapPattern2Twocombine
+)
+
+checkPatternCombine::(ArrowXmla)=>String->String->a[String](Int,String)
+checkPatternCombinepatternname
+=choiceA
+[-- just one pattern with that name -> ok, no combine is needed
+(isA(\cl->lengthcl==1))
+:->
+constA(1,"")
+,(isA(\cl->(length$elemIndices""cl)>1))
+:->
+constA(0
+,"More than one "++pattern++"-Pattern: "++showname++
+" without an combine-attribute in the same grammar"
+)
+,(isA(\cl->(length$nub$deleteBy(==)""cl)>1))
+:->
+arr(\cl->(0
+,"Different combine-Attributes: "++
+(formatStringListQuot$noDoublescl)++
+" for the "++pattern++"-Pattern "++
+showname++" in the same grammar"
+)
+)
+,-- ok -> combine value is returned
+this
+:->
+arr(\cl->(1,fromJust$find(/="")cl))
+]
+
+isElemWithNameValue::(ArrowXmla)=>String->String->aXmlTreeXmlTree
+isElemWithNameValueenamenvalue
+=(isElem
+>>>
+hasRngNameename
+>>>
+getRngAttrName
+>>>
+isA(==nvalue)
+)
+`guards`this
+
+getElems::(ArrowXmla)=>String->String->aXmlTreeXmlTree
+getElemspatternname
+=getChildren
+>>>
+choiceA
+[isElemWithNameValuepatternname
+:->
+(this<+>getElemspatternname)
+,isRngGrammar
+:->none
+,this
+:->
+getElemspatternname
+]
+
+deletePatternElems::(ArrowXmla)=>String->String->aXmlTreeXmlTree
+deletePatternElemspatternname
+=choiceA
+[isElemWithNameValuepatternname
+:->
+none
+,isRngGrammar
+:->this
+,this
+:->
+processChildren(deletePatternElemspatternname)
+]
+
+
+-- ------------------------------------------------------------
+
+
+{-
+- 4.19. define and ref elements
+ - Remove any define element that is not reachable.
+ - Now, for each element element that is not the child of a define element,
+ add a define element to the grammar element,
+ and replace the element element by a ref element referring
+ to the added define element.
+ - For each ref element that is expandable and is a descendant
+ of a start element or an element element, expand it by replacing
+ the ref element by the child of the define element to which it refers
+ - This must not result in a loop.
+ - Remove any define element whose child is not an element element.
+-}
+simplificationStep6::IOSArrowXmlTreeXmlTree
+simplificationStep6=
+(-- Remove any define element that is not reachable.
+(removeUnreachableDefines$<<<getAllDeepDefines
+&&&
+constA[]
+&&&
+getRefsFromStartPattern
+)
+>>>
+-- for each element element that is not the child of a define element,
+-- add a define element to the grammar element,
+(processElementsFalse
+>>>
+processChildren(insertChildrenAt1(getParam"elementTable"))
+)
+>>>
+-- For each ref element that is expandable...
+-- Remove any define element whose child is not an element element
+(replaceExpandableRefs[]$<getExpandableDefines>>>deleteExpandableDefines)
+)`when`collectErrors
+where
+replaceExpandableRefs::RefList->Env->IOSArrowXmlTreeXmlTree
+replaceExpandableRefsfoundNamesdefTable
+=choiceA[
+isRngRef
+:->(ifA(getRngAttrName
+>>>
+isA(\name->elemname(mapfstfoundNames))
+)
+-- we have found a loop if the name is in the list
+(mkRelaxError""$<(getAttrValuedefineOrigName
+>>>
+arr(\n->("Recursion in ref-Pattern: "++
+formatStringListArr(reverse$(n:)$mapsndfoundNames)
+)
+)
+)
+)
+(replaceRef$<<getRngAttrName&&&getAttrValuedefineOrigName)
+),
+this:->(processChildren$replaceExpandableRefsfoundNamesdefTable)
+]
+where
+replaceRef::NewName->OldName->IOSArrowXmlTreeXmlTree
+replaceRefnameoldname
+=(constA(fromJust$lookupnamedefTable)
+>>>
+getChildren
+>>>
+replaceExpandableRefs((name,oldname):foundNames)defTable
+)
+`whenP`
+(const$elemname$mapfstdefTable)
+
+
+processElements::Bool->IOSArrowXmlTreeXmlTree
+processElementsparentIsDefine
+=processChildren
+(choiceA
+[isRngElement
+:->(ifP(constparentIsDefine)
+(processElementsFalse)
+(processElements'$<<(getAndSetCounter"define_id"
+&&&
+getDefineName
+)
+)
+)
+,isRngDefine
+:->processElementsTrue
+,this
+:->processElementsFalse
+])
+where
+getDefineName::IOSArrowXmlTreeString
+getDefineName
+=firstChild
+>>>
+fromLAcreateNameClass
+>>>
+arrshow
+
+processElements'::NewName->OldName->IOSArrowXmlTreeXmlTree
+processElements'nameoldname
+=storeElementnameoldname
+>>>
+mkRngRef(createAttrnameoldname)none
+
+storeElement::NewName->OldName->IOSArrowXmlTreeXmlTree
+storeElementnameoldname
+=perform$
+(mkRngDefine
+(createAttrnameoldname)(processElementsFalse)
+)
+&&&
+(listA$getParam"elementTable")
+>>>
+arr2(:)
+>>>
+setParamList"elementTable"
+
+createAttr::NewName->OldName->IOSArrowXmlTreeXmlTree
+createAttrnameoldname
+=mkAttr(mkName"name")(txtname)
+<+>
+mkAttr(mkNamedefineOrigName)(txt$"created for element "++oldname)
+
+getExpandableDefines::(ArrowXmla)=>aXmlTreeEnv
+getExpandableDefines
+=listA$(multi((isRngDefine
+>>>
+getChildren
+>>>
+negisRngElement
+)
+`guards`
+this
+)
+)
+>>>
+(getRngAttrName&&&this)
+
+deleteExpandableDefines::(ArrowXmla)=>aXmlTreeXmlTree
+deleteExpandableDefines
+=processTopDown$none
+`when`
+(isRngDefine
+>>>
+getChildren
+>>>
+negisRngElement
+)
+
+
+-- ------------------------------------------------------------
+
+
+{-
+- 4.20. notAllowed element
+ - An attribute, list, group, interleave, or oneOrMore element that has
+ a notAllowed child element is transformed into a notAllowed element.
+ - A choice element that has two notAllowed child elements
+ is transformed into a notAllowed element
+ - A choice element that has one notAllowed child element
+ is transformed into its other child element.
+ - An except element that has a notAllowed child element is removed.
+ - The preceding transformations are applied repeatedly
+ until none of them is applicable any more.
+ - Any define element that is no longer reachable is removed.
+- 4.21. empty element
+ - A group, interleave or choice element that has two empty child
+ elements is transformed into an empty element.
+ - A group or interleave element that has one empty child element
+ is transformed into its other child element.
+ - A choice element whose second child element is an empty element
+ is transformed by interchanging its two child elements.
+ - A oneOrMore element that has an empty child element
+ is transformed into an empty element.
+ - The preceding transformations are applied repeatedly
+ until none of them is applicable any more.
+-}
+
+simplificationStep7::IOSArrowXmlTreeXmlTree
+simplificationStep7
+=(markTreeChanged0-- 0 = no changes, 1 = changes performed
+>>>
+processTopDownWithAttrl
+((-- An attribute, list, group, interleave, or oneOrMore element that has a
+-- notAllowed child element is transformed into a notAllowed element.
+((mkRngNotAllowednonenone
+>>>
+markTreeChanged1
+)
+`whenNot`-- keep all errors
+(deepisRngRelaxError)
+)
+`when`
+(isAttributeListGroupInterleaveOneOrMore
+>>>
+getChildren
+>>>
+isRngNotAllowed
+)
+)
+>>>
+(-- A choice element that has two notAllowed child elements is
+-- transformed into a notAllowed element
+(mkRngNotAllowednonenone
+>>>
+markTreeChanged1
+)
+`when`
+(isRngChoice
+>>>
+listA(getChildren>>>isRngNotAllowed)
+>>>
+isA(\s->lengths==2)
+)
+)
+>>>
+(-- A choice element that has one notAllowed child element is
+-- transformed into its other child element.
+(getChildren>>>negisRngNotAllowed
+>>>
+markTreeChanged1
+)
+`when`
+(isRngChoice>>>getChildren>>>isRngNotAllowed)
+)
+>>>
+(-- An except element that has a notAllowed child element is removed.
+((markTreeChanged1
+>>>
+none
+)
+`whenNot`-- keep all errors
+deepisRngRelaxError
+)
+`when`
+(isRngExcept>>>getChildren>>>isRngNotAllowed)
+)
+>>>-- transforming the empty pattern (4.21)
+(-- A group, interleave or choice element that has two empty child elements
+-- is transformed into an empty element.
+(mkRngEmptynone
+>>>
+markTreeChanged1
+)
+`when`
+(isChoiceGroupInterleave
+>>>
+listA(getChildren>>>isRngEmpty)
+>>>
+isA(\s->lengths==2)
+)
+)
+>>>
+(-- A group or interleave element that has one empty child element
+-- is transformed into its other child element.
+(getChildren
+>>>
+negisRngEmpty
+>>>
+markTreeChanged1
+)
+`when`
+(isGroupInterleave>>>getChildren>>>isRngEmpty)
+)
+>>>
+(-- A choice element whose second child element is an empty element is transformed
+-- by interchanging its two child elements.
+changeChoiceChildren
+`when`
+(isRngChoice>>>getChildren>>>isRngEmpty)
+)
+>>>
+(-- A oneOrMore element that has an empty child element
+-- is transformed into an empty element.
+(mkRngEmptynone
+>>>
+markTreeChanged1
+)
+`when`
+(isRngOneOrMore>>>getChildren>>>isRngEmpty)
+)
+)
+>>>
+-- The preceding transformations are applied repeatedly
+-- until none of them is applicable any more.
+(simplificationStep7
+`when`
+hasTreeChanged
+)
+)`when`collectErrors
+where
+changeChoiceChildren::IOSArrowXmlTreeXmlTree
+changeChoiceChildren
+=((replaceChildren
+(mkRngEmptynone
+<+>
+(getChildren>>>negisRngEmpty)
+)
+>>>
+markTreeChanged1
+)
+`when`
+(single(getChildren>>>isElem)-- first child not "empty" elem
+>>>
+negisRngEmpty
+)
+)
+
+hasTreeChanged::IOSArrowbInt
+hasTreeChanged
+=getParamInt0"rng:changeTree"
+>>>
+isA(==1)
+
+markTreeChanged::Int->IOSArrowbb
+markTreeChangedi
+=perform(setParamInt"rng:changeTree"i)
+
+-- ------------------------------------------------------------
+
+
+simplificationStep8::IOSArrowXmlTreeXmlTree
+simplificationStep8-- Remove any define element that is not reachable.
+=((removeUnreachableDefines$<<<
+(getAllDeepDefines
+&&&
+constA[]
+&&&
+getRefsFromStartPattern
+)
+)
+`when`collectErrors
+)
+
+
+-- ------------------------------------------------------------
+
+
+restrictionsStep2::IOSArrowXmlTreeXmlTree
+restrictionsStep2=
+processTopDown(
+choiceA[
+-- 7.1.1. attribute pattern, the following paths are prohibited:
+-- attribute//(ref | attribute)
+isRngAttribute:->
+((deepisRngRelaxError
+<+>
+(mkRelaxError$<<(getChangesAttr
+&&&
+(listA(getChildren
+>>>
+deepisAttributeRef
+>>>
+(getName&&&getChangesAttr>>>arr2(++))
+)
+>>>
+arr(\n->formatStringListPattn++
+"Pattern not allowed as descendent(s)"++
+" of a attribute-Pattern"
+)
+)
+)
+)
+)
+`when`
+(getChildren>>>deepisAttributeRef)
+),
+
+-- 7.1.2. oneOrMore pattern, the following paths are prohibited:
+-- oneOrMore//(group | interleave)//attribute
+isRngOneOrMore:->
+((deepisRngRelaxError
+<+>
+(mkRelaxError$<<(getChangesAttr
+&&&
+(listA(getChildren
+>>>
+deepisGroupInterleave
+>>>
+(getName&&&getChangesAttr>>>arr2(++))
+)
+&&&
+getChangesAttr
+>>>
+arr2(\nc->(formatStringListPattn++
+"Pattern not allowed as descendent(s) "++
+"of a oneOrMore-Pattern"++
+(ifnullcthen""else" "++showc)++
+" followed by an attribute descendent"
+)
+)
+)
+)
+)
+)
+`when`
+(getChildren>>>deepisGroupInterleave
+>>>
+getChildren>>>deepisRngAttribute
+)
+),
+
+-- 7.1.3. list pattern, the following paths are prohibited:
+-- list//( list | ref | attribute | text | interleave)
+isRngList:->
+((deepisRngRelaxError
+<+>
+(mkRelaxError$<<(getChangesAttr
+&&&
+(listA(getChildren
+>>>
+deepisAttributeRefTextListInterleave
+>>>
+(getName&&&getChangesAttr>>>arr2(++))
+)
+>>>
+arr(\n->formatStringListPattn++
+"Pattern not allowed as descendent(s) of a list-Pattern")
+)
+)
+)
+)
+`when`
+(getChildren
+>>>
+deepisAttributeRefTextListInterleave
+)
+),
+
+-- 7.1.4. except in data pattern, the following paths are prohibited:
+-- data/except//(attribute | ref | text | list | group | interleave | oneOrMore | empty)
+isRngData:->
+((deepisRngRelaxError
+<+>
+(mkRelaxError$<<(getChangesAttr
+&&&
+(listA(getChildren
+>>>
+deepisAttributeRefTextListGroupInterleaveOneOrMoreEmpty
+>>>
+(getName&&&getChangesAttr>>>arr2(++))
+)
+>>>
+arr(\n->formatStringListPattn++
+"Pattern not allowed as descendent(s) of a data/except-Pattern")
+)
+)
+)
+)
+`when`
+(getChildren
+>>>
+isRngExcept
+>>>
+deepisAttributeRefTextListGroupInterleaveOneOrMoreEmpty
+)
+),
+
+-- 7.1.5. start element, the following paths are prohibited:
+-- start//(attribute | data | value | text | list | group | interleave | oneOrMore | empty)
+isRngStart:->
+((deepisRngRelaxError
+<+>
+(mkRelaxError$<<(getChangesAttr
+&&&
+(listA(getChildren
+>>>
+deep(checkElemName["attribute","data","value","text","list",
+"group","interleave","oneOrMore","empty"])
+>>>
+(getName&&&getChangesAttr>>>arr2(++))
+)
+>>>
+arr(\n->formatStringListPattn++
+"Pattern not allowed as descendent(s) of a start-Pattern")
+)
+)
+)
+)
+`when`
+(getChildren
+>>>
+deep(checkElemName["attribute","data","value","text","list",
+"group","interleave","oneOrMore","empty"])
+)
+),
+
+this:->this
+]
+)`when`collectErrors
+
+
+-- ------------------------------------------------------------
+
+
+restrictionsStep3::IOSArrowXmlTreeXmlTree
+restrictionsStep3
+=processTopDown
+((deepisRngRelaxError
+<+>
+(mkRelaxError""$<
+(-- getRngAttrName
+(getChildren>>>isRngName>>>getChildren>>>getText)
+>>>
+arr(\n->("Content of element "++shown++" contains a pattern that can match "++
+"a child and a pattern that matches a single string"
+)
+)
+)
+)
+)
+`when`
+(isRngElement
+>>>
+(getChildren>>.(take1.reverse))
+>>>
+getContentType>>>isA(==CTNone)
+)
+)`when`collectErrors
+
+
+
+getContentType::IOSArrowXmlTreeContentType
+getContentType
+=choiceA
+[isRngValue:->(constACTSimple)
+,isRngData:->processData
+,isRngList:->(constACTSimple)
+,isRngText:->(constACTComplex)
+,isRngRef:->(constACTComplex)
+,isRngEmpty:->(constACTEmpty)
+,isRngAttribute:->processAttribute
+,isRngGroup:->processGroup
+,isRngInterleave:->processInterleave
+,isRngOneOrMore:->processOneOrMore
+,isRngChoice:->processChoice
+]
+where
+processData::IOSArrowXmlTreeContentType
+processData
+=ifA(neg(getChildren>>>isRngExcept))
+(constACTSimple)
+(getChildren
+>>>
+isRngExcept
+>>>
+getChildren
+>>>
+getContentType
+>>>
+ifP(/=CTNone)(constACTSimple)(constACTNone)
+)
+processAttribute::IOSArrowXmlTreeContentType
+processAttribute
+=ifA(lastChild
+>>>
+getContentType
+>>>
+isA(/=CTNone)
+)
+(constACTEmpty)
+(constACTNone)
+
+processGroup::IOSArrowXmlTreeContentType
+processGroup
+=get2ContentTypes
+>>>
+arr2(\ab->ifisGroupableabthenmaxabelseCTNone)
+
+processInterleave::IOSArrowXmlTreeContentType
+processInterleave
+=get2ContentTypes
+>>>
+arr2(\ab->ifisGroupableabthenmaxabelseCTNone)
+
+processOneOrMore::IOSArrowXmlTreeContentType
+processOneOrMore
+=ifA(getChildren
+>>>
+getContentType>>>isA(/=CTNone)
+>>>
+isA(\t->isGroupablett)
+)
+(getChildren>>>getContentType)
+(constACTNone)
+
+processChoice::IOSArrowXmlTreeContentType
+processChoice
+=get2ContentTypes
+>>>
+arr2max
+
+isGroupable::ContentType->ContentType->Bool
+isGroupableCTEmpty_=True
+isGroupable_CTEmpty=True
+isGroupableCTComplexCTComplex=True
+isGroupable__=False
+
+
+checkPattern::IOSArrow(XmlTree,([NameClass],[NameClass]))XmlTree
+checkPattern
+=(\(_,(a,b))->isInab)`guardsP`(arrfst)
+where
+isIn::[NameClass]->[NameClass]->Bool
+isIn_[]=False
+isIn[]_=False
+isIn(x:xs)ys=(any(overlapx)ys)||isInxsys
+
+
+occur::String->IOSArrowXmlTreeXmlTree->IOSArrowXmlTreeXmlTree
+occurnamefct
+=choiceA
+[(isElem>>>hasRngNamename)
+:->
+fct
+,isChoiceGroupInterleaveOneOrMore
+:->
+(getChildren>>>occurnamefct)
+]
+
+get2ContentTypes::IOSArrowXmlTree(ContentType,ContentType)
+get2ContentTypes
+=((firstChild>>>getContentType)
+&&&
+(lastChild>>>getContentType)
+)
+
+-- ------------------------------------------------------------
+
+
+-- Duplicate attributes are not allowed. -> fertig
+-- Attributes using infinite name classes must be repeated; an attribute element that
+-- has an anyName or nsName descendant element must have a oneOrMore ancestor element. -> fertig
+
+-- berechnet alle define-Namen (fuer ref-Pattern) und Nameclasses der element-Pattern
+
+restrictionsStep4::IOSArrowXmlTreeXmlTree
+restrictionsStep4
+=(restrictionsStep4'$<
+listA(deepisRngDefine-- get all defines
+>>>
+(getRngAttrName-- get define name
+&&&
+(single(getChildren
+>>>
+getChildren
+>>>
+fromLAcreateNameClass-- compute the name class from 1. grandchild
+)
+`orElse`
+(constAAnyName)
+)
+)
+)
+)`when`collectErrors
+
+restrictionsStep4'::[(String,NameClass)]->IOSArrowXmlTreeXmlTree
+restrictionsStep4'nc=
+processTopDown(
+(
+(deepisRngRelaxError
+<+>
+(mkRelaxError""$<
+(getRngAttrName
+>>>
+arr(\n->("Both attribute-pattern occuring in an "++
+shown++" belong to the same name-class"
+)
+)
+)
+)
+)
+`when`
+((isRngGroup`orElse`isRngInterleave)
+>>>
+(getChildren
+&&&
+(firstChild
+>>>
+listA(occur"attribute"(singlegetChildren)
+>>>
+fromLAcreateNameClass
+)
+)
+&&&
+(lastChild
+>>>
+listA(occur"attribute"(singlegetChildren)
+>>>
+fromLAcreateNameClass
+)
+)
+)
+>>>checkPattern
+)
+)
+>>>
+(
+(deepisRngRelaxError
+<+>
+(mkRelaxError""
+("An attribute that has an anyName or nsName descendant element "++
+"must have a oneOrMore ancestor element"
+)
+)
+)
+`when`
+(isRngElement>>>checkInfiniteAttribute)
+)
+>>>
+((deepisRngRelaxError
+<+>
+(mkRelaxError""
+("Both element-pattern occuring in an interleave "++
+"belong to the same name-class"
+)
+)
+)
+`when`
+(isRngInterleave
+>>>
+(getChildren
+&&&
+(firstChild>>>listA(occur"ref"this>>>getRngAttrName))
+&&&
+(lastChild>>>listA(occur"ref"this>>>getRngAttrName))
+)
+>>>
+checkNames
+)
+)
+>>>
+((deepisRngRelaxError
+<+>
+(mkRelaxError"""A text pattern must not occur in both children of an interleave")
+)
+`when`
+(isRngInterleave>>>checkText)
+)
+)
+where
+checkInfiniteAttribute::IOSArrowXmlTreeXmlTree
+checkInfiniteAttribute
+=getChildren
+>>>
+choiceA
+[isRngOneOrMore:->none
+,(isRngAttribute
+>>>
+deep(isRngAnyName`orElse`isRngNsName)
+):->this
+,this:->checkInfiniteAttribute
+]
+
+checkNames::IOSArrow(XmlTree,([String],[String]))XmlTree
+checkNames=(arrfst)
+&&&
+(arr(\(_,(a,_))->getNameClassesnca))
+&&&
+(arr(\(_,(_,b))->getNameClassesncb))
+>>>
+checkPattern
+where
+getNameClasses::[(String,NameClass)]->[String]->[NameClass]
+getNameClassesnc'l=map(\x->fromJust$lookupxnc')l
+
+checkText::IOSArrowXmlTreeXmlTree
+checkText
+=(firstChild>>>occur"text"this)
+`guards`
+(lastChild>>>occur"text"this)
+
+-- ------------------------------------------------------------
+
+
+overlap::NameClass->NameClass->Bool
+overlapnc1nc2
+=any(bothContainnc1nc2)(representativesnc1++representativesnc2)
+
+bothContain::NameClass->NameClass->QName->Bool
+bothContainnc1nc2qn
+=containsnc1qn&&containsnc2qn
+
+illegalLocalName::LocalName
+illegalLocalName=""
+
+illegalUri::Uri
+illegalUri="\x1"
+
+representatives::NameClass->[QName]
+representativesAnyName
+=[mkQName""illegalLocalNameillegalUri]
+
+representatives(AnyNameExceptnc)
+=(mkQName""illegalLocalNameillegalUri):(representativesnc)
+
+representatives(NsNamens)
+=[mkQName""illegalLocalNamens]
+
+representatives(NsNameExceptnsnc)
+=(mkQName""illegalLocalNamens):(representativesnc)
+
+representatives(Namensln)
+=[mkQName""lnns]
+
+representatives(NameClassChoicenc1nc2)
+=(representativesnc1)++(representativesnc2)
+
+representatives_
+=[]
+
+-- -------------------------------------------------------------------------------------------------------
+resetStates::IOSArrowXmlTreeXmlTree
+resetStates
+=(perform(constA$setParamInt"define_id"0)
+>>>
+perform(constA[]>>>setParamList"elementTable")
+>>>
+perform(constA$setParamInta_numberOfErrors0)
+)
+
+
+getAllDeepDefines::IOSArrowXmlTreeEnv
+getAllDeepDefines
+=listA$deepisRngDefine
+>>>
+(getRngAttrName&&&this)
+
+
+-- | Return all reachable defines from the start pattern
+
+getRefsFromStartPattern::IOSArrowXmlTree[String]
+getRefsFromStartPattern
+=listA
+(getChildren
+>>>
+isRngGrammar
+>>>
+getChildren
+>>>
+isRngStart
+>>>
+deepisRngRef
+>>>
+getRngAttrName
+)
+
+removeUnreachableDefines::Env->[String]->[String]->IOSArrowXmlTreeXmlTree
+removeUnreachableDefinesallDefsprocessedDefsreachableDefs
+=ifP(const$unprocessedDefs/=[])
+(removeUnreachableDefinesallDefs(nextTreeName:processedDefs)$<newReachableDefs)
+(processChildren$-- root node
+processChildren$-- first grammar
+(none
+`when`
+(isRngDefine
+>>>
+getRngAttrName
+>>>
+isA(\n->not$elemnreachableDefs)
+)
+)
+)
+where
+unprocessedDefs::[String]
+unprocessedDefs
+=reachableDefs\\processedDefs
+
+newReachableDefs::IOSArrown[String]
+newReachableDefs
+=constAgetTree
+>>>
+listA(deepisRngRef
+>>>
+getRngAttrName
+)
+>>>
+arr(noDoubles.(reachableDefs++))
+
+getTree::XmlTree
+getTree
+=fromJust$lookupnextTreeNameallDefs
+
+nextTreeName::String
+nextTreeName
+=headunprocessedDefs
+
+
+-- -------------------------------------------------------------------------------------------------------
+
+
+checkElemName::[String]->IOSArrowXmlTreeXmlTree
+checkElemNamel
+=(isElem>>>getLocalPart>>>isA(\s->elemsl))
+`guards`
+this
+
+wrapPattern2Two::(ArrowXmla)=>String->aXmlTreeXmlTree
+wrapPattern2Twoname
+=choiceA
+[noOfChildren(>2)
+:->(replaceChildren((mkRngElementnamenone
+(getChildren>>.take2)
+)
+<+>
+(getChildren>>.drop2)
+)
+>>>
+wrapPattern2Twoname
+)
+,noOfChildren(==1)
+:->getChildren
+,this
+:->this
+]
+
+mkRelaxError::String->String->IOSArrownXmlTree
+mkRelaxErrorchangesStrerrStr
+=perform(getAndSetCountera_numberOfErrors)
+>>>
+mkRngRelaxErrornonenone
+>>>
+addAttr"desc"errStr
+>>>
+(addAttr"changes"changesStr
+`whenP`
+(const$changesStr/="")
+)
+
+collectErrors::IOSArrowXmlTreeXmlTree
+collectErrors
+=none
+`when`
+(stopAfterFirstError
+>>>
+getParamInt0a_numberOfErrors>>>isA(>0)
+)
+where
+stopAfterFirstError=getParamStringa_do_not_collect_errors
+>>>
+isA(=="1")
+
+
+-- | Returns the list of simplification errors or 'none'
+getErrors::IOSArrowXmlTreeXmlTree
+getErrors=(getParamInt0a_numberOfErrors>>>isA(>0))
+`guards`
+(root[][multiisRngRelaxError])
+
+setChangesAttr::String->IOSArrowXmlTreeXmlTree
+setChangesAttrstr
+=ifA(hasAttra_relaxSimplificationChanges)
+(processAttrl$
+changeAttrValue(++(", "++str))
+`when`
+(hasRngNamea_relaxSimplificationChanges)
+)
+(mkAttr(mkNamea_relaxSimplificationChanges)(txtstr))
+
+
+getChangesAttr::IOSArrowXmlTreeString
+getChangesAttr
+=getAttrValuea_relaxSimplificationChanges
+&&&
+getParamStringa_output_changes
+>>>
+ifP(\(changes,param)->changes/=""&¶m=="1")
+(arr2$\l_->" ("++l++")")
+(constA"")
+
+
+getAndSetCounter::String->IOSArrowbString
+getAndSetCountername
+=genNewId$<getParamInt0name
+where
+genNewId::Int->IOSArrowbString
+genNewIdi=setParamIntname(i+1)>>>constA(showi)
+
+
+-- -------------------------------------------------------------------------------------------------------
+
+-- | Creates the simple form of a Relax NG schema
+-- (see also: 'relaxOptions')
+
+createSimpleForm::Attributes->Bool->Bool->Bool->IOSArrowXmlTreeXmlTree
+createSimpleFormremainingOptionscheckRestrictionsvalidateExternalRefvalidateInclude
+=traceMsg2("createSimpleForm: "++show(remainingOptions,checkRestrictions,validateExternalRef,validateInclude))
+>>>
+(ifcheckRestrictions
+thencreateSimpleWithRest
+elsecreateSimpleWithoutRest
+)
+where
+
+createSimpleWithRest::IOSArrowXmlTreeXmlTree
+createSimpleWithRest
+=seqA$concat[simplificationPart1
+,return$traceDoc"relax NG: simplificationPart1 done"
+,restrictionsPart1
+,return$traceDoc"relax NG: restrictionsPart1 done"
+,simplificationPart2
+,return$traceDoc"relax NG simplificationPart2 done"
+,restrictionsPart2
+,return$traceDoc"relax NG: restrictionsPart2 done"
+,finalCleanUp
+,return$traceDoc"relax NG: finalCleanUp done"
+]
+
+createSimpleWithoutRest::IOSArrowXmlTreeXmlTree
+createSimpleWithoutRest
+=seqA$concat[simplificationPart1
+,simplificationPart2
+,finalCleanUp
+]
+simplificationPart1::[IOSArrowXmlTreeXmlTree]
+simplificationPart1
+=[propagateNamespaces
+,simplificationStep1
+,simplificationStep2remainingOptionsvalidateExternalRefvalidateInclude[][]
+,simplificationStep3
+,simplificationStep4
+]
+
+simplificationPart2::[IOSArrowXmlTreeXmlTree]
+simplificationPart2
+=[simplificationStep5
+,simplificationStep6
+,simplificationStep7
+,simplificationStep8
+]
+
+restrictionsPart1::[IOSArrowXmlTreeXmlTree]
+restrictionsPart1
+=[restrictionsStep1]
+
+restrictionsPart2::[IOSArrowXmlTreeXmlTree]
+restrictionsPart2
+=[restrictionsStep2
+,restrictionsStep3
+,restrictionsStep4
+]
+
+finalCleanUp::[IOSArrowXmlTreeXmlTree]
+finalCleanUp
+=[cleanUp
+,resetStates
+]
+
+cleanUp::IOSArrowXmlTreeXmlTree
+cleanUp=processTopDown$
+removeAttra_relaxSimplificationChanges
+>>>
+removeAttrdefineOrigName
+
+-- -------------------------------------------------------------------------------------------------------
+
-- |
+-- This module exports the core functions from the basic validation und simplification libraries.
+-- It also exports some helper functions for easier access to the validation functionality.
+
+moduleText.XML.HXT.RelaxNG.Validator
+(validateDocumentWithRelaxSchema
+,validateDocumentWithRelax
+
+,validate
+,validateSchema
+,validateWithSpezification
+,validateSchemaWithSpezification
+,validateWithoutSpezification
+,moduleText.XML.HXT.RelaxNG.Validation
+,moduleText.XML.HXT.RelaxNG.Simplification
+)
+where
+
+importControl.Arrow.ListArrows
+
+importText.XML.HXT.DOM.Interface
+importText.XML.HXT.Arrow.XmlArrow
+importText.XML.HXT.Arrow.XmlIOStateArrow
+
+importText.XML.HXT.RelaxNG.Validation
+importText.XML.HXT.RelaxNG.Simplification
+importText.XML.HXT.RelaxNG.SchemaasS
+
+-- ------------------------------------------------------------
+
+{- |
+ validate a document with a Relax NG schema
+
+ * 1.parameter : the option list for validation
+
+ - 2.parameter : the URI of the Relax NG Schema
+
+ - arrow-input : the document to be validated, namespaces must have been processed
+
+ - arrow-output : the input document, or in case of validation errors, an empty document with status information in the root
+
+options evaluated by validateDocumentWithRelaxSchema:
+
+ * 'a_check_restrictions' : check Relax NG schema restrictions when simplifying the schema (default: on)
+
+ - 'a_validate_externalRef' : validate a Relax NG schema referenced by a externalRef-Pattern (default: on)
+
+ - 'a_validate_include' : validate a Relax NG schema referenced by a include-Pattern (default: on)
+
+all other options are propagated to the read functions for schema input
+
+example:
+
+> validateDocumentWithRelaxSchema [(a_check_restrictions, "0")] "testSchema.rng"
+
+
+-}
+
+validateDocumentWithRelaxSchema::Attributes->String->IOStateArrowsXmlTreeXmlTree
+validateDocumentWithRelaxSchemauserOptionsrelaxSchema
+=withOtherUserState()
+$
+((validate'$<validSchema)-- try to validate, only possible if schema is o.k.
+`orElse`
+this
+)
+`when`
+documentStatusOk-- only do something when document status is ok
+where
+validate'schema
+=setDocumentStatusFromSystemState"read and build Relax NG schema"
+>>>
+validateDocumentWithRelaxschema
+
+validSchema
+=traceMsg2("read Relax NG schema document: "++showrelaxSchema)
+>>>
+readForRelaxremainingOptionsrelaxSchema
+>>>
+perform(letcheckSchema=Truein-- test option in al
+ifcheckSchema
+thenvalidateWithRelaxAndHandleErrorsS.relaxSchemaArrow
+elsenone
+)
+>>>
+traceMsg2"create simplified schema"
+>>>
+createSimpleFormremainingOptions
+(hasOptiona_check_restrictions)
+(hasOptiona_validate_externalRef)
+(hasOptiona_validate_include)
+>>>
+traceDoc"simplified schema"
+>>>
+perform(getErrors
+>>>
+handleSimplificationErrors
+)
+hasOptionn
+=optionIsSetnoptions
+
+options=addEntriesuserOptionsdefaultOptions
+
+defaultOptions
+=[(a_check_restrictions,v_1)
+,(a_validate_externalRef,v_1)
+,(a_validate_include,v_1)
+]
+
+remainingOptions
+=filter(not.fliphasEntrydefaultOptions.fst)options
+
+
+
+handleSimplificationErrors::IOSArrowXmlTreeXmlTree
+handleSimplificationErrors
+=traceDoc"simplification errors"
+>>>
+getChildren>>>getAttrValue"desc"
+>>>
+arr("Relax NG validation: "++)
+>>>
+mkErrorc_err
+>>>
+filterErrorMsg
+
+
+{- | validate an XML document with respect to a Relax NG schema
+
+ * 1.parameter : the valid and simplified schema as XML tree
+
+ - arrow-input : the document to be validated
+
+ - arrow-output : the validated and unchanged document or the empty document with status information set in the root node
+-}
+
+validateDocumentWithRelax::XmlTree->IOSArrowXmlTreeXmlTree
+validateDocumentWithRelaxschema
+=(traceMsg1"validate document with Relax NG schema"
+>>>
+perform(validateWithRelaxAndHandleErrors(constAschema))
+>>>
+setDocumentStatusFromSystemState"validate document with Relax NG schema"
+)
+`when`documentStatusOk-- only do something when document status is ok
+
+
+{- |
+ normalize a document for Relax NG validation,
+ call the 'Text.XML.HXT.RelaxNG.Validation.validateRelax' function for doing the hard work,
+ and issue errors
+
+ * 1.parameter : the arrow for computing the schema
+
+ - arrow-input : the document to be validated
+
+ - arrow-output : nothing
+-}
+
+-- ------------------------------------------------------------
+
+{- | Document validation
+
+Validates a xml document with respect to a Relax NG schema.
+
+First, the schema is validated with respect to the Relax NG Spezification. If no error is found, the xml document is validated with respect to the schema.
+
+ * 1.parameter : list of options; namespace progagation is always done
+
+ - 2.parameter : XML document
+
+ - 3.parameter : Relax NG schema file
+
+available options:
+
+ * 'a_do_not_check_restrictions' : do not check Relax NG schema restrictions (includes do-not-validate-externalRef, do-not-validate-include)
+
+ - 'a_do_not_validate_externalRef' : do not validate a Relax NG schema referenced by a externalRef-Pattern
+
+ - 'a_validate_externalRef' : validate a Relax NG schema referenced by a externalRef-Pattern (default)
+
+ - 'a_do_not_validate_include' : do not validate a Relax NG schema referenced by a include-Pattern
+
+ - 'a_validate_include' : validate a Relax NG schema referenced by a include-Pattern (default)
+
+ - 'a_output_changes' : output Pattern transformations in case of an error
+
+ - 'a_do_not_collect_errors' : stop Relax NG simplification after the first error has occurred
+
+ - all 'Text.XML.HXT.Arrow.ReadDocument.readDocument' options
+
+example:
+
+> validate [(a_do_not_check_restrictions, "1")] "test.xml" "testSchema.rng"
+
+-}
+validate::Attributes->String->String->IOSArrownXmlTree
+validatealxmlDocumentrelaxSchema
+=S.relaxSchemaArrow
+>>>
+validateWithSpezificationalxmlDocumentrelaxSchema
+
+
+
+
+{- | Relax NG schema validation
+
+Validates a Relax NG schema with respect to the Relax NG Spezification.
+
+ * 1.parameter : list of available options (see also: 'validate')
+
+ - 2.parameter : Relax NG schema file
+
+-}
+validateSchema::Attributes->String->IOSArrownXmlTree
+validateSchemaalrelaxSchema
+=validateal""relaxSchema
+
+
+
+{- | Document validation
+
+Validates a xml document with respect to a Relax NG schema. Similar to 'validate', but the Relax NG Specification is not created. Can be used, to check a list of documents more efficiently.
+
+ * 1.parameter : list of available options (see also: 'validate')
+
+ - 2.parameter : XML document
+
+ - 3.parameter : Relax NG schema file
+
+ - arrow-input : Relax NG Specification in simple form
+
+example:
+
+> Text.XML.HXT.RelaxNG.Schema.relaxSchemaArrow
+> >>>
+> ( validateWithSpezification [] "foo.xml" "foo.rng"
+> &&&
+> validateWithSpezification [] "bar.xml" "bar.rng"
+> )
+
+
+-}
+validateWithSpezification::Attributes->String->String->IOSArrowXmlTreeXmlTree
+validateWithSpezificationalxmlDocumentrelaxSchema
+=-- validation of the schema with respect to the specification
+-- returns a list of errors or none if the schema is correct
+
+(validateRelax$<(readForRelaxalrelaxSchema
+>>>
+getChildren
+)
+)
+`orElse`
+
+-- validation of the xml document with respect to the schema
+-- returns a list of errors or none if the xml document is correct
+
+validateWithoutSpezificationalxmlDocumentrelaxSchema
+
+{- | Relax NG schema validation
+
+ see 'validateSchema' and 'validateWithSpezification'
+
+ * 1.parameter : list of available options (see also: 'validate')
+
+ - 2.parameter : Relax NG schema file
+
+ - arrow-input : Relax NG Specification in simple form
+-}
+
+validateSchemaWithSpezification::Attributes->String->IOSArrowXmlTreeXmlTree
+validateSchemaWithSpezificationalrelaxSchema
+=validateWithSpezificational""relaxSchema
+
+
+
+{- | Document validation
+
+Validates a xml document with respect to a Relax NG schema, but the schema is @not@ validated with respect to a specification first. Should be used only for valid Relax NG schemes.
+
+ * 1.parameter : list of available options (see also: 'validate')
+
+ - 2.parameter : XML document
+
+ - 3.parameter : Relax NG schema file
+
+-}
+
+
+validateWithoutSpezification::Attributes->String->String->IOSArrownXmlTree
+validateWithoutSpezificationalxmlDocumentrelaxSchema
+=readForRelaxalrelaxSchema
+>>>
+createSimpleFormalTrueTrueTrue
+>>>
+((getErrors>>>performhandleSimplificationErrors)-- issue errors in schema simplification
+`orElse`
+(ifnullxmlDocument-- no errors: validate document
+thennone
+elsevalidateRelax$<(readForRelaxalxmlDocument
+>>>
+normalizeForRelaxValidation
+>>>
+getChildren
+)
+)
+)
+
-- |
+-- This helper module exports elements from the basic Relax NG libraries:
+-- Validator, CreatePattern, PatternToString and DataTypes.
+-- It is the main entry point to the Relax NG schema validator of the Haskell
+-- XML Toolbox.
+--
+-- Author : Torben Kuseler
+--
+-- Version : $Id: RelaxNG.hs,v 1.1 2005/09/02 17:09:39 hxml Exp $
+
+moduleText.XML.HXT.RelaxNG
+(moduleText.XML.HXT.RelaxNG.PatternToString
+,moduleText.XML.HXT.RelaxNG.Validator
+,moduleText.XML.HXT.RelaxNG.DataTypes
+,moduleText.XML.HXT.RelaxNG.CreatePattern
+)
+where
+
+importText.XML.HXT.RelaxNG.PatternToString
+importText.XML.HXT.RelaxNG.Validator
+importText.XML.HXT.RelaxNG.DataTypes
+importText.XML.HXT.RelaxNG.CreatePattern
+
-- |
+-- 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
+--
+-- Version : $Id: AttributeValueValidation.hs,v 1.1 2004/09/02 19:12:02 hxml Exp $
+--
+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
+-- Version : $Id: DTDValidation.hs,v 1.1 2004/09/02 19:12:02 hxml Exp $
+
+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
+-- Version : $Id: DocTransformation.hs,v 1.1 2004/09/02 19:12:03 hxml Exp $
+
+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
+-- Version : $Id: DocValidation.hs,v 1.1 2004/09/02 19:12:03 hxml Exp $
+
+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
+-- Version : $Id: IdValidation.hs,v 1.1 2004/09/02 19:12:03 hxml Exp $
+
+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>.
+--
+-- Version : $Id: RE.hs,v 1.1 2004/09/02 19:12:03 hxml Exp $
+
+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
+-- Version : $Id: Validation.hs,v 1.2 2004/11/23 15:50:23 hxml Exp $
+
+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
+-- Version : $Id: ValidationFilter.hs,v 1.1 2004/11/23 15:50:23 hxml Exp $
+
+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
+
+-- Version : $Id: XmlRE.hs,v 1.1 2004/09/02 19:12:03 hxml Exp $
+
+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
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.XPath.XPathDataTypes
+ Copyright : Copyright (C) 2006 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ The core data types of XPath.
+ The Type NodeSet is based on the module "NavTree" which was adapted from
+ HXML (<http://www.flightlab.com/~joe/hxml/>)
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.XPath.XPathDataTypes
+(moduleText.XML.HXT.XPath.XPathDataTypes
+,moduleText.XML.HXT.XPath.NavTree
+)
+where
+
+importText.XML.HXT.XPath.NavTree
+importText.XML.HXT.DOM.Interface
+
+-- -----------------------------------------------------------------------------
+--
+-- Expr
+
+-- | Represents expression
+--
+
+dataExpr=GenExprOp[Expr]-- ^ generic expression with an operator and one or more operands
+|PathExpr(MaybeExpr)(MaybeLocationPath)
+-- ^ a path expression contains an optional filter-expression
+-- or an optional locationpath. one expression is urgently
+-- necessary, both are possible
+|FilterExpr[Expr]-- ^ filter-expression with zero or more predicates
+|VarExprVarName-- ^ variable
+|LiteralExprLiteral-- ^ string
+|NumberExprXPNumber-- ^ number
+|FctExprFctNameFctArguments-- ^ a function with a name and an optional list of arguments
+deriving(Show,Eq)
+
+
+-- -----------------------------------------------------------------------------
+--
+-- Op
+
+-- | Represents XPath operators
+
+dataOp=Or|And|Eq|NEq|Less|Greater|LessEq
+|GreaterEq|Plus|Minus|Div|Mod|Mult|Unary|Union
+deriving(Show,Eq)
+
+
+-- -----------------------------------------------------------------------------
+--
+-- |
+-- Represents a floating-point number according the IEEE 754 standard
+--
+-- The standard includes a special Not-a-Number (NaN) value,
+-- positive and negative infinity, positive and negative zero.
+
+dataXPNumber=FloatFloat-- ^ floating-point number
+|NaN-- ^ not-a-number
+|NegInf-- ^ negative infinity
+|Neg0-- ^ negative zero
+|Pos0-- ^ positive zero
+|PosInf-- ^ positive infinity
+
+
+instanceShowXPNumber
+where
+showNaN="NaN"
+showNegInf="-Infinity"
+showNeg0="-0"
+showPos0="0"
+show(Floatf)=showf
+showPosInf="Infinity"
+
+
+
+-- Negative zero is equal to positive zero,
+-- equality test with NaN-value is always false
+instanceEqXPNumber
+where
+NegInf==NegInf=True
+Pos0==Neg0=True
+Neg0==Pos0=True
+Pos0==Pos0=True
+Neg0==Neg0=True
+Floatf==Floatg=f==g
+PosInf==PosInf=True
+_==_=False
+
+
+instanceOrdXPNumber
+where
+a<=b=(a<b)||(a==b)
+a>=b=(a>b)||(a==b)
+a>b=b<a
+
+NaN<_=False
+_<NaN=False
+
+_<NegInf=False
+NegInf<_=True
+
+Neg0<Neg0=False
+Pos0<Pos0=False
+Pos0<Neg0=False
+Neg0<Pos0=False
+
+Neg0<Floatf=0<f
+Pos0<Floatf=0<f
+Floatf<Neg0=f<0
+Floatf<Pos0=f<0
+
+Floatf<Floatg=f<g
+
+PosInf<_=False
+_<PosInf=True
+
+
+-- -----------------------------------------------------------------------------
+-- | Represents location path
+--
+-- A location path consists of a sequence of one or more location steps.
+
+dataLocationPath=LocPathPath[XStep]
+deriving(Show,Eq)
+
+
+-- -----------------------------------------------------------------------------
+-- |
+-- A location path is either a relative or an absolute path.
+
+dataPath=Rel|Abs
+deriving(Show,Eq)
+
+
+-- | Represents location step
+--
+-- A location step consists of an axis, a node-test and zero or more predicates.
+
+dataXStep=StepAxisSpecNodeTest[Expr]
+deriving(Show,Eq)
+
+
+-- -----------------------------------------------------------------------------
+--
+-- AxisSpec
+
+-- | Represents XPath axis
+
+dataAxisSpec=Ancestor|AncestorOrSelf|Attribute|Child|Descendant
+|DescendantOrSelf|Following|FollowingSibling
+|Namespace|Parent|Preceding|PrecedingSibling|Self
+deriving(Show,Eq)
+
+
+-- -----------------------------------------------------------------------------
+--
+-- NodeTest
+
+-- | Represents XPath node-tests
+
+--data NodeTest = NameTest Name -- ^ name-test
+dataNodeTest=NameTestQName-- ^ name-test
+|PIString-- ^ processing-instruction-test with a literal argument
+|TypeTestXPathNode-- ^ all nodetype-tests
+deriving(Show,Eq)
+
+
+
+
+
+-- -----------------------------------------------------------------------------
+--
+-- XPathNode
+
+-- | Represents nodetype-tests
+
+dataXPathNode=XPNode-- ^ all 7 nodetypes
+-- (root, element, attribute, namespace, pi, comment, text)
+|XPCommentNode-- ^ comment-nodes
+|XPPINode-- ^ processing-instruction-nodes
+|XPTextNode-- ^ text-nodes: cdata, character data
+deriving(Show,Eq)
+
+
+-- -----------------------------------------------------------------------------
+--
+-- useful type definitions
+
+typeName=(NamePrefix,LocalName)
+typeNamePrefix=String
+typeLocalName=String
+
+-- | Variable name
+typeVarName=Name
+
+-- | a string
+typeLiteral=String
+
+-- | Function name
+typeFctName=String
+
+-- | Function arguments
+typeFctArguments=[Expr]
+
+-- | Evaluation context
+typeContext=(ConPos,ConLen,ConNode)
+
+-- | Context position
+typeConPos=Int
+
+-- | Context length
+typeConLen=Int
+
+-- | Context node
+typeConNode=NavXmlTree
+
+
+
+-- -----------------------------------------------------------------------------
+--
+-- XPathValue
+
+-- | Represents XPath results
+
+dataXPathValue=XPVNodeNodeSet-- ^ node-set
+|XPVBoolBool-- ^ boolean value
+|XPVNumberXPNumber-- ^ number according the IEEE 754 standard
+|XPVStringString-- ^ string value
+|XPVErrorString-- ^ error message with text
+deriving(Show,Eq,Ord)
+
+
+-- -----------------------------------------------------------------------------
+--
+-- Basic types for navigable tree and filters
+
+-- | Node of navigable tree representation
+
+typeNavXmlTree=NavTreeXNode
+
+-- | List of nodes of navigable tree representation
+
+typeNavXmlTrees=[NavXmlTree]
+
+-- | Type synonym for a list of navigable tree representation
+
+typeNodeSet=NavXmlTrees
+
+-- | A functions that takes a XPath result and returns a XPath result
+
+typeXPathFilter=XPathValue->XPathValue
+
+
+
+-- -----------------------------------------------------------------------------
+--
+-- Env
+
+-- | XPath environment
+--
+-- All variables are stored in the environment,
+-- each variable name is bound to a value.
+
+typeVarTab=[(VarName,XPathValue)]
+typeKeyTab=[(QName,String,NavXmlTree)]
+
+typeEnv=(VarTab,KeyTab)
+
+varEnv::Env
+varEnv=([(("","name"),XPVNumberNaN)]
+,[]
+)
+
+-- -----------------------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.XPath.XPathEval
+ Copyright : Copyright (C) 2006 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id: XPathEval.hs,v 1.8 2006/10/12 11:51:29 hxml Exp $
+
+ The core functions for evaluating the different types of XPath expressions.
+ Each 'Expr'-constructor is mapped to an evaluation function.
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.XPath.XPathEval
+(getXPath
+,getXPathWithNsEnv
+,getXPathSubTrees
+,getXPathSubTreesWithNsEnv
+,getXPathNodeSet
+,getXPathNodeSetWithNsEnv
+,evalExpr
+)
+where
+
+importText.XML.HXT.XPath.XPathFct
+importText.XML.HXT.XPath.XPathDataTypes
+importText.XML.HXT.XPath.XPathArithmetic
+(xPathAdd
+,xPathDiv
+,xPathMod
+,xPathMulti
+,xPathUnary
+)
+importText.XML.HXT.XPath.XPathParser
+(parseXPath)
+
+importText.XML.HXT.XPath.XPathToString
+(xPValue2XmlTrees)
+
+importText.XML.HXT.XPath.XPathToNodeSet
+(xPValue2NodeSet
+,emptyNodeSet
+)
+
+importText.ParserCombinators.Parsec
+(runParser)
+
+importData.Maybe
+(fromJust)
+
+-- ----------------------------------------
+
+-- the DOM functions
+
+importText.XML.HXT.DOM.Interface
+importqualifiedText.XML.HXT.DOM.XmlNodeasXN
+
+-- ----------------------------------------
+
+-- the list arrow functions
+
+importControl.Arrow((>>>),(>>^))
+importControl.Arrow.ArrowList(arrL,isA)
+importControl.Arrow.ArrowIf(filterA)
+importControl.Arrow.ListArrow(runLA)
+importqualified
+Control.Arrow.ArrowTreeasAT
+importText.XML.HXT.Arrow.XmlArrow(ArrowDTD,isDTD,getDTDAttrl)
+importText.XML.HXT.Arrow.Edit(canonicalizeForXPath)
+
+-- -----------------------------------------------------------------------------
+
+-- |
+-- Select parts of a document by an XPath expression.
+--
+-- The main filter for selecting parts of a document via XPath.
+-- The string argument must be a XPath expression with an absolute location path,
+-- the argument tree must be a complete document tree.
+-- Result is a possibly empty list of XmlTrees forming the set of selected XPath values.
+-- XPath values other than XmlTrees (numbers, attributes, tagnames, ...)
+-- are convertet to text nodes.
+
+getXPath::String->XmlTree->XmlTrees
+getXPath=getXPathWithNsEnv[]
+
+-- |
+-- Select parts of a document by a namespace aware XPath expression.
+--
+-- Works like 'getXPath' but the prefix:localpart names in the XPath expression
+-- are interpreted with respect to the given namespace environment
+
+getXPathWithNsEnv::NsEnv->String->XmlTree->XmlTrees
+getXPathWithNsEnvenvs=runLA(canonicalizeForXPath
+>>>
+arrL(getXPathValuesxPValue2XmlTreesxPathErrenvs)
+)
+
+-- |
+-- Select parts of an XML tree by a XPath expression.
+--
+-- The main filter for selecting parts of an arbitrary XML tree via XPath.
+-- The string argument must be a XPath expression with an absolute location path,
+-- There are no restrictions on the arument tree.
+--
+-- No canonicalization is performed before evaluating the query
+--
+-- Result is a possibly empty list of XmlTrees forming the set of selected XPath values.
+-- XPath values other than XmlTrees (numbers, attributes, tagnames, ...)
+-- are convertet to text nodes.
+
+getXPathSubTrees::String->XmlTree->XmlTrees
+getXPathSubTrees=getXPathSubTreesWithNsEnv[]
+
+-- | Same as 'getXPathSubTrees' but with namespace aware XPath expression
+
+getXPathSubTreesWithNsEnv::NsEnv->String->XmlTree->XmlTrees
+getXPathSubTreesWithNsEnvnsEnvxpStr
+=getXPathValuesxPValue2XmlTreesxPathErrnsEnvxpStr
+
+-- | compute the node set of an XPath query
+
+getXPathNodeSet::String->XmlTree->XmlNodeSet
+getXPathNodeSet=getXPathNodeSetWithNsEnv[]
+
+-- | compute the node set of a namespace aware XPath query
+
+getXPathNodeSetWithNsEnv::NsEnv->String->XmlTree->XmlNodeSet
+getXPathNodeSetWithNsEnvnsEnvxpStr
+=getXPathValuesxPValue2NodeSet(const(constemptyNodeSet))nsEnvxpStr
+
+-- | parse xpath, evaluate xpath expr and prepare results
+
+getXPathValues::(XPathValue->a)->(String->String->a)->NsEnv->String->XmlTree->a
+getXPathValuescvRescvErrnsEnvxpStrt
+=case(runParserparseXPathnsEnv""xpStr)of
+LeftparseError
+->cvErrxpStr(showparseError)
+RightxpExpr
+->evalXPxpExpr
+where
+evalXPxpe
+=cvResxpRes
+where
+t'=addRoott-- we need a root node for starting xpath eval
+idAttr=(("","idAttr")-- id attributes from DTD (if there)
+,idAttributesToXPathValue.getIdAttributes$t'
+)
+navTD=ntreet'
+xpRes=evalExpr(idAttr:(getVarTabvarEnv),[])(1,1,navTD)xpe(XPVNode[navTD])
+
+addRoot::XmlTree->XmlTree
+addRoott
+|XN.isRoott
+=t
+|otherwise
+=XN.mkRoot[][t]
+
+xPathErr::String->String->[XmlTree]
+xPathErrxpStrparseError
+=[XN.mkErrorc_err("Syntax error in XPath expression "++showxpStr++": "++showparseError)]
+
+-- |
+-- The main evaluation entry point.
+-- Each XPath-'Expr' is mapped to an evaluation function. The 'Env'-parameter contains the set of global variables
+-- for the evaluator, the 'Context'-parameter the root of the tree in which the expression is evaluated.
+--
+
+evalExpr::Env->Context->Expr->XPathFilter
+evalExprenvcont(GenExprOrex)
+=boolEvalenvcontOrex
+evalExprenvcont(GenExprAndex)
+=boolEvalenvcontAndex
+
+evalExprenvcont(GenExprEqex)
+=relEqEvalenvcontEq.evalExprLenvcontex
+evalExprenvcont(GenExprNEqex)
+=relEqEvalenvcontNEq.evalExprLenvcontex
+evalExprenvcont(GenExprLessex)
+=relEqEvalenvcontLess.evalExprLenvcontex
+evalExprenvcont(GenExprLessEqex)
+=relEqEvalenvcontLessEq.evalExprLenvcontex
+evalExprenvcont(GenExprGreaterex)
+=relEqEvalenvcontGreater.evalExprLenvcontex
+evalExprenvcont(GenExprGreaterEqex)
+=relEqEvalenvcontGreaterEq.evalExprLenvcontex
+
+evalExprenvcont(GenExprPlusex)
+=numEvalxPathAddPlus.toXValuexnumbercontenv.evalExprLenvcontex
+evalExprenvcont(GenExprMinusex)
+=numEvalxPathAddMinus.toXValuexnumbercontenv.evalExprLenvcontex
+evalExprenvcont(GenExprDivex)
+=numEvalxPathDivDiv.toXValuexnumbercontenv.evalExprLenvcontex
+evalExprenvcont(GenExprModex)
+=numEvalxPathModMod.toXValuexnumbercontenv.evalExprLenvcontex
+evalExprenvcont(GenExprMultex)
+=numEvalxPathMultiMult.toXValuexnumbercontenv.evalExprLenvcontex
+
+evalExprenvcont(GenExprUnaryex)
+=xPathUnary.xnumbercontenv.evalExprLenvcontex
+
+evalExprenvcont(GenExprUnionex)
+=unionEval.evalExprLenvcontex
+
+evalExprenvcont(FctExprnameargs)
+=fctEvalenvcontnameargs
+
+evalExprenv_(PathExprNothing(Justlp))
+=locPathEvalenvlp
+evalExprenvcont(PathExpr(Justfe)(Justlp))
+=locPathEvalenvlp.evalExprenvcontfe
+
+evalExprenvcont(FilterExprex)
+=filterEvalenvcontex
+evalExprenv_ex
+=evalSpezExprenvex
+
+
+
+evalExprL::Env->Context->[Expr]->XPathValue->[XPathValue]
+evalExprLenvcontexns
+=map(\e->evalExprenvcontens)ex
+
+evalSpezExpr::Env->Expr->XPathFilter
+evalSpezExpr_(NumberExpr(Float0))_
+=XPVNumberPos0
+evalSpezExpr_(NumberExpr(Floatf))_
+=XPVNumber(Floatf)
+evalSpezExpr_(LiteralExprs)_
+=XPVStrings
+evalSpezExprenv(VarExprname)v
+=getVariableenvnamev
+evalSpezExpr___
+=XPVError"Call to evalExpr with a wrong argument"
+
+
+-- -----------------------------------------------------------------------------
+
+-- |
+-- filter for evaluating a filter-expression
+filterEval::Env->Context->[Expr]->XPathFilter
+filterEvalenvcont(prim:predicates)ns
+=caseevalExprenvcontprimnsof
+new_ns@(XPVNode_)->evalPredLenvpredicatesnew_ns
+_->XPVError"Return of a filterexpression is not a nodeset"
+filterEval____
+=XPVError"Call to filterEval without an expression"
+
+
+
+-- |
+-- returns the union of its arguments, the arguments have to be node-sets.
+unionEval::[XPathValue]->XPathValue
+unionEval
+=createDocumentOrder.remDups.unionEval'
+where
+unionEval'(e@(XPVError_):_)=e
+unionEval'(_:e@(XPVError_):_)=e
+unionEval'[n@(XPVNode_)]=n
+unionEval'((XPVNoden):(XPVNodem):xs)=unionEval((XPVNode(n++m)):xs)
+unionEval'_=XPVError"The value of a union ( | ) is not a nodeset"
+
+
+
+-- |
+-- Equality or relational test for node-sets, numbers, boolean values or strings,
+-- each computation of two operands is done by relEqEv'
+relEqEval::Env->Context->Op->[XPathValue]->XPathValue
+relEqEvalenvcontop
+=foldl1(relEqEv'envcontop)
+
+
+
+relEqEv'::Env->Context->Op->XPathValue->XPathFilter
+relEqEv'___e@(XPVError_)_=e
+relEqEv'____e@(XPVError_)=e
+
+-- two node-sets
+relEqEv'envcontopa@(XPVNode_)b@(XPVNode_)
+=relEqTwoNodesenvcontopab
+
+-- one node-set
+relEqEv'envcontopab@(XPVNode_)
+=relEqOneNodeenvcont(fromJust$getOpFctop)ab
+relEqEv'envcontopa@(XPVNode_)b
+=relEqOneNodeenvcont(flip$fromJust$getOpFctop)ba
+
+
+-- test without a node-set and equality or not-equality operator
+relEqEv'envcontEqab=eqEvenvcont(==)ab
+relEqEv'envcontNEqab=eqEvenvcont(/=)ab
+
+-- test without a node-set and less, less-equal, greater or greater-equal operator
+relEqEv'envcontopab
+=XPVBool((fromJust$getOpFctop)(toXNumbera)(toXNumberb))
+where
+toXNumberx=xnumbercontenv[x]
+
+
+
+-- |
+-- Equality or relational test for two node-sets.
+-- The comparison will be true if and only if there is a node in the first node-set
+-- and a node in the second node-set such that the result of performing the
+-- comparison on the string-values of the two nodes is true
+relEqTwoNodes::Env->Context->Op->XPathValue->XPathFilter
+relEqTwoNodes__op(XPVNodens)(XPVNodems)
+=XPVBool(foldr(\n->(any(fctopn)(getStrValuesms)||))Falsens)
+where
+fctop'n'=(fromJust$getOpFctop')(stringValuen')
+getStrValues=mapstringValue
+relEqTwoNodes_____
+=XPVError"Call to relEqTwoNodes without a nodeset"
+
+
+-- |
+-- Comparison between a node-set and different type.
+-- The node-set is converted in a boolean value if the second argument is of type boolean.
+-- If the argument is of type number, the node-set is converted in a number, otherwise it is converted
+-- in a string value.
+relEqOneNode::Env->Context->(XPathValue->XPathValue->Bool)->XPathValue->XPathFilter
+relEqOneNodeenvcontfctarg(XPVNodens)
+=XPVBool(any(fctarg)(getStrValuesargns))
+where
+getStrValuesarg'=map((fromJust$getConvFctarg')contenv.wrap).mapstringValue
+wrapx=[x]
+relEqOneNode_____
+=XPVError"Call to relEqOneNode without a nodeset"
+
+
+
+-- |
+-- No node-set is involved and the operator is equality or not-equality.
+-- The arguments are converted in a common type. If one argument is a boolean value
+-- then it is the boolean type. If a number is involved, the arguments have to converted in numbers,
+-- else the string type is the common type.
+eqEv::Env->Context->(XPathValue->XPathValue->Bool)->XPathValue->XPathFilter
+eqEvenvcontfctf@(XPVBool_)g
+=XPVBool(f`fct`xbooleancontenv[g])
+eqEvenvcontfctfg@(XPVBool_)
+=XPVBool(xbooleancontenv[f]`fct`g)
+
+eqEvenvcontfctf@(XPVNumber_)g
+=XPVBool(f`fct`xnumbercontenv[g])
+eqEvenvcontfctfg@(XPVNumber_)
+=XPVBool(xnumbercontenv[f]`fct`g)
+
+eqEvenvcontfctfg
+=XPVBool(xstringcontenv[f]`fct`xstringcontenv[g])
+
+
+getOpFct::Op->Maybe(XPathValue->XPathValue->Bool)
+getOpFctEq=Just(==)
+getOpFctNEq=Just(/=)
+getOpFctLess=Just(<)
+getOpFctLessEq=Just(<=)
+getOpFctGreater=Just(>)
+getOpFctGreaterEq=Just(>=)
+getOpFct_=Nothing
+
+
+
+-- |
+-- Filter for accessing the root element of a document tree
+getRoot::XPathFilter
+getRoot(XPVNode(n:_))
+=XPVNode[getRoot'n]
+where
+getRoot'tree
+=caseupNTtreeof
+Nothing->tree
+Justt->getRoot't
+getRoot_
+=XPVError"Call to getRoot without a nodeset"
+
+
+
+-- |
+-- Filter for accessing all nodes of a XPath-axis
+--
+-- * 1.parameter as : axis specifier
+--
+getAxisNodes::AxisSpec->XPathFilter
+getAxisNodesas(XPVNodens)
+=XPVNode(concat$map(fromJust$lookupasaxisFctL)ns)
+getAxisNodes__
+=XPVError"Call to getAxis without a nodeset"
+
+
+
+-- |
+-- Axis-Function-Table.
+-- Each XPath axis-specifier is mapped to the corresponding axis-function
+axisFctL::[(AxisSpec,(NavXmlTree->NavXmlTrees))]
+axisFctL=[(Ancestor,ancestorAxis)
+,(AncestorOrSelf,ancestorOrSelfAxis)
+,(Attribute,attributeAxis)
+,(Child,childAxis)
+,(Descendant,descendantAxis)
+,(DescendantOrSelf,descendantOrSelfAxis)
+,(Following,followingAxis)
+,(FollowingSibling,followingSiblingAxis)
+,(Parent,parentAxis)
+,(Preceding,precedingAxis)
+,(PrecedingSibling,precedingSiblingAxis)
+,(Self,selfAxis)
+]
+
+
+-- |
+-- evaluates a location path,
+-- evaluation of an absolute path starts at the document root,
+-- the relative path at the context node
+locPathEval::Env->LocationPath->XPathFilter
+locPathEvalenv(LocPathRelsteps)
+=evalStepsenvsteps
+locPathEvalenv(LocPathAbssteps)
+=evalStepsenvsteps.getRoot
+
+
+
+
+evalSteps::Env->[XStep]->XPathFilter
+evalStepsenvstepsns
+=foldl(evalStepenv)nssteps
+
+
+-- |
+-- evaluate a single XPath step
+-- namespace-axis is not supported
+evalStep::Env->XPathValue->XStep->XPathValue
+evalStep__(StepNamespace__)=XPVError"namespace-axis not supported"
+evalStep_ns(StepAttributent_)=evalAttrnt(getAxisNodesAttributens)
+evalStepenvns(StepaxisSpecntpr)=evalStep'envprnt(getAxisNodesaxisSpecns)
+
+
+
+evalAttr::NodeTest->XPathFilter
+evalAttrnt(XPVNodens)
+=XPVNode(foldr(\n->(evalAttrNodeTestntn++))[]ns)
+evalAttr__
+=XPVError"Call to evalAttr without a nodeset"
+
+
+evalAttrNodeTest::NodeTest->NavXmlTree->NavXmlTrees
+evalAttrNodeTest(NameTestqn)ns@(NT(NTree(XAttrqn1)_)___)
+=if((uri==uri1&&lp==lp1)
+||
+((uri==""||uri==uri1)&&lp=="*")
+)
+then[ns]
+else[]
+where
+uri=namespaceUriqn
+uri1=namespaceUriqn1
+lp=localPartqn
+lp1=localPartqn1
+
+evalAttrNodeTest(TypeTestXPNode)ns@(NT(NTree(XAttr_)_)___)
+=[ns]
+
+evalAttrNodeTest__
+=[]
+
+evalStep'::Env->[Expr]->NodeTest->XPathFilter
+evalStep'envprnt
+=evalPredLenvpr.nodeTestnt
+
+
+evalPredL::Env->[Expr]->XPathFilter
+evalPredLenvprn@(XPVNodens)
+=remDups$foldl(evalPredenv1(lengthns))npr
+evalPredL___
+=XPVError"Call to evalPredL without a nodeset"
+
+
+evalPred::Env->Int->Int->XPathValue->Expr->XPathValue
+evalPred___ns@(XPVNode[])_=ns
+evalPredenvposlen(XPVNode(x:xs))ex
+=casetestPredicateenv(pos,len,x)ex(XPVNode[x])of
+e@(XPVError_)->e
+XPVBoolTrue->XPVNode(x:n)
+XPVBoolFalse->nextNode
+_->XPVError"Value of testPredicate is not a boolean"
+wherenextNode@(XPVNoden)=evalPredenv(pos+1)len(XPVNodexs)ex
+evalPred_____
+=XPVError"Call to evalPred without a nodeset"
+
+
+
+testPredicate::Env->Context->Expr->XPathFilter
+testPredicateenvcontext@(pos,_,_)exns
+=caseevalExprenvcontextexnsof
+XPVNumber(Floatf)->XPVBool(f==fromIntegralpos)
+XPVNumber_->XPVBoolFalse
+_->xbooleancontextenv[evalExprenvcontextexns]
+
+
+-- |
+-- filter for selecting a special type of nodes from the current fragment tree
+--
+-- the filter works with namespace activated and without namespaces.
+-- If namespaces occur in XPath names, the uris are used for matching,
+-- else the name prefix
+--
+-- Bugfix : "*" (or any other name-test) must not match the root node
+
+nodeTest::NodeTest->XPathFilter
+
+-- nodeTest (NameTest (QN "" "*" "")) = filterNodes (\n -> isXTagNode n && not (isRootNode n))
+-- nodeTest (NameTest (QN _ "*" uri)) = filterNodes (filterd uri)
+
+nodeTest(NameTestq)
+|isWildcardTest
+=filterNodes(wildcardTestq)
+|otherwise
+=filterNodes(nameTestq)-- old: (isOfTagNode1 q)
+where
+isWildcardTest=localPartq=="*"
+
+nodeTest(PIn)=filterNodesisPiNode
+where
+isPiNode=maybeFalse((==n).qualifiedName).XN.getPiName
+
+nodeTest(TypeTestt)=typeTestt
+
+nameTest::QName->XNode->Bool
+nameTestxpName(XTagelemName_)
+|namespaceAware
+=localPartxpName==localPartelemName
+&&
+namespaceUrixpName==namespaceUrielemName
+|otherwise
+=qualifiedNamexpName==qualifiedNameelemName
+where
+namespaceAware=not.null.namespaceUri$xpName
+
+nameTest__=False
+
+wildcardTest::QName->XNode->Bool
+wildcardTestxpName(XTagelemName_)
+|namespaceAware
+=namespaceUrixpName==namespaceUrielemName
+|prefixMatch
+=namePrefixxpName==namePrefixelemName
+|otherwise
+=localPartelemName/=t_root-- all names except the root name "/"
+where
+namespaceAware=not.null.namespaceUri$xpName
+prefixMatch=not.null.namePrefix$xpName
+
+wildcardTest__=False
+
+-- |
+-- tests whether a node is of a special type
+--
+typeTest::XPathNode->XPathFilter
+typeTestXPNode=id
+typeTestXPCommentNode=filterNodesXN.isCmt
+typeTestXPPINode=filterNodesXN.isPi
+typeTestXPTextNode=filterNodesXN.isText
+
+-- |
+-- the filter selects the NTree part of a navigable tree and
+-- tests whether the node is of the necessary type
+--
+-- * 1.parameter fct : filter function from the XmlTreeFilter module which tests the type of a node
+--
+filterNodes::(XNode->Bool)->XPathFilter
+filterNodesfct(XPVNodens)
+=XPVNode([n|n@(NT(NTreenode_)___)<-ns,fctnode])
+filterNodes__
+=XPVError"Call to filterNodes without a nodeset"
+
+-- |
+-- evaluates a boolean expression, the evaluation is non-strict
+boolEval::Env->Context->Op->[Expr]->XPathFilter
+boolEval__op[]_
+=XPVBool(op==And)
+boolEvalenvcontOr(x:xs)ns
+=casexbooleancontenv[evalExprenvcontxns]of
+e@(XPVError_)->e
+XPVBoolTrue->XPVBoolTrue
+_->boolEvalenvcontOrxsns
+
+boolEvalenvcontAnd(x:xs)ns
+=casexbooleancontenv[evalExprenvcontxns]of
+e@(XPVError_)->e
+XPVBoolTrue->boolEvalenvcontAndxsns
+_->XPVBoolFalse
+boolEval_____
+=XPVError"Call to boolEval with a wrong argument"
+
+
+
+-- |
+-- returns the value of a variable
+getVariable::Env->VarName->XPathFilter
+getVariableenvname_
+=caselookupname(getVarTabenv)of
+Nothing->XPVError("Variable: "++showname++" not found")
+Justv->v
+
+
+-- |
+-- evaluates a function,
+-- computation is done by 'XPathFct.evalFct' which is defined in "XPathFct".
+fctEval::Env->Context->FctName->[Expr]->XPathFilter
+fctEvalenvcontnameargs
+=evalFctnameenvcont.evalExprLenvcontargs
+
+
+
+-- |
+-- evaluates an arithmetic operation.
+--
+-- 1.parameter f : arithmetic function from "XPathArithmetic"
+--
+numEval::(Op->XPathValue->XPathValue->XPathValue)->Op->[XPathValue]->XPathValue
+numEvalfop=foldl1(fop)
+
+
+
+-- |
+-- Convert list of ID attributes from DTD into a space separated 'XPVString'
+--
+
+idAttributesToXPathValue::XmlTrees->XPathValue
+idAttributesToXPathValuets
+=XPVString(foldr(\n->((valueOfDTDa_valuen++" ")++))[]ts)
+
+-- |
+-- Extracts all ID-attributes from the document type definition (DTD).
+--
+
+getIdAttributes::XmlTree->XmlTrees
+getIdAttributes
+=runLA$
+AT.getChildren
+>>>
+isDTD
+>>>
+AT.deep(isIdAttrType)
+
+-- ----------------------------------------
+
+isIdAttrType::ArrowDTDa=>aXmlTreeXmlTree
+isIdAttrType=hasDTDAttrValuea_type(==k_id)
+
+valueOfDTD::String->XmlTree->String
+valueOfDTDn=concat.runLA(getDTDAttrl>>^lookup1n)
+
+hasDTDAttrValue::ArrowDTDa=>String->(String->Bool)->aXmlTreeXmlTree
+hasDTDAttrValueanp=filterA$
+getDTDAttrl>>>isA(p.lookup1an)
+
+-- ------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.XPath.XPathFct
+ Copyright : Copyright (C) 2008 Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+
+ The module contains the core-functions of the XPath function library.
+ All functions are implemented as XFct. Each XFct contains the evaluation context,
+ the variable environment and the function arguments.
+
+-}
+
+-- ------------------------------------------------------------
+
+moduleText.XML.HXT.XPath.XPathFct
+(XFct
+,evalFct
+,toXValue
+,xnumber
+,xboolean
+,xstring
+,getConvFct
+,stringValue
+,remDups
+,isNotInNodeList
+,createDocumentOrder
+,createDocumentOrderReverse
+,getVarTab
+,getKeyTab
+)
+where
+
+importText.XML.HXT.XPath.XPathDataTypes
+importText.XML.HXT.XPath.XPathParser
+(parseNumber
+)
+importText.XML.HXT.XPath.XPathArithmetic
+(xPathAdd
+)
+
+importControl.Arrow((>>>),(<+>))
+importControl.Arrow.ArrowList(constA)
+importControl.Arrow.ArrowIf(ifA)
+importControl.Arrow.ArrowTree(deep)
+importControl.Arrow.ListArrow(LA,runLA)
+importText.XML.HXT.Arrow.XmlArrow
+importText.XML.HXT.Arrow.ReadDocument(readDocument)
+importText.XML.HXT.Arrow.XmlIOStateArrow(runX)
+
+importText.XML.HXT.DOM.Interface
+importqualifiedText.XML.HXT.DOM.XmlNodeasXN
+
+importSystem.IO.Unsafe
+(unsafePerformIO
+)
+
+importData.Char
+(isAscii
+,isUpper
+,isLower
+,isDigit
+,ord
+)
+
+importData.List
+(sortBy
+)
+
+importData.Maybe
+
+-- -----------------------------------------------------------------------------
+
+-- added by Tim Walkenhorst to fix Pos0 vs. Float 0.0 problems...
+
+int2XPNumber::Int->XPNumber
+int2XPNumber0=Pos0
+int2XPNumberi=Float$fromIntegrali
+
+-- |
+-- Type signature for all functions which can be used in the XPath module.
+
+typeXFct=(Context->Env->[XPathValue]->XPathValue)
+
+-- |
+-- All functions are stored in a function table.
+
+typeFctTable=[(FctName,FctTableElem)]
+
+-- |
+-- Each table entry consists of the function and the expected function arguments.
+
+typeFctTableElem=(XFct,CheckArgCount)
+
+-- |
+-- Tests whether the number of current function arguments is correct
+
+typeCheckArgCount=([XPathValue]->Bool)
+
+zero,zeroOrOne,one,two,twoOrM,twoOrThree,three::CheckArgCount
+zeroex=lengthex==0
+zeroOrOneex=lengthex==0||lengthex==1
+oneex=lengthex==1
+twoex=lengthex==2
+twoOrMex=lengthex>=2
+twoOrThreeex=lengthex==2||lengthex==3
+threeex=lengthex==3
+
+
+-- |
+-- The core-functions library
+
+fctTable::FctTable
+fctTable=[
+("last",(xlast,zero)),-- nodeset functions
+("position",(xposition,zero)),
+("count",(xcount,one)),
+("id",(xid,one)),
+("local-name",(xlocalName,zeroOrOne)),
+("namespace-uri",(xnamespaceUri,zeroOrOne)),
+("name",(xname,zeroOrOne)),
+
+("string",(xstring,zeroOrOne)),-- string functions
+("concat",(xconcat,twoOrM)),
+("starts-with",(xstartsWith,two)),
+("contains",(xcontains,two)),
+("substring-before",(xsubstringBefore,two)),
+("substring-after",(xsubstringAfter,two)),
+("substring",(xsubstring,twoOrThree)),
+("string-length",(xstringLength,zeroOrOne)),
+("normalize-space",(xnormalizeSpace,zeroOrOne)),
+("translate",(xtranslate,three)),
+
+("boolean",(xboolean,one)),-- boolean functions
+("not",(xnot,one)),
+("true",(xtrue,zero)),
+("false",(xfalse,zero)),
+("lang",(xlang,one)),
+
+("number",(xnumber,zeroOrOne)),-- number functions
+("sum",(xsum,one)),
+("floor",(xfloor,one)),
+("ceiling",(xceiling,one)),
+("round",(xround,one)),
+("key",(xkey,two)),
+("format-number",(xformatNumber,twoOrThree)),
+
+("document",(xdocument,one)),-- extension functions for xslt 1.0
+("generate-id",(xgenerateId,zeroOrOne))
+
+]
+
+-- -----------------------------------------------------------------------------
+
+-- some helper functions
+
+-- |
+-- Returns the table of keys, needed by xslt, from the environment
+
+getKeyTab::Env->KeyTab
+getKeyTab(_,keyTab)=keyTab
+
+
+-- |
+-- Returns the table of variables from the environment
+
+getVarTab::Env->VarTab
+getVarTab(varTab,_)=varTab
+
+
+-- |
+-- Returns the conversion function for the XPath results: string, boolean and number
+-- A nodeset can not be converted.
+
+getConvFct::XPathValue->MaybeXFct
+getConvFct(XPVNumber_)=Justxnumber
+getConvFct(XPVString_)=Justxstring
+getConvFct(XPVBool_)=Justxboolean
+getConvFct_=Nothing
+
+
+-- |
+-- Filter for ordering a list of Nodes in document order
+
+createDocumentOrder::XPathFilter
+createDocumentOrder(XPVNoden)=XPVNode(sortBydocumentOrdern)
+where
+documentOrder::NavXmlTree->NavXmlTree->Ordering
+documentOrderab=compare(documentPosa)(documentPosb)
+
+createDocumentOrdere@(XPVError_)=e
+createDocumentOrder_=XPVError"Call to createDocumentOrder without a nodeset"
+
+
+-- |
+-- Filter for ordering a list of Nodes in reverse document order
+
+createDocumentOrderReverse::XPathFilter
+createDocumentOrderReverse(XPVNoden)=XPVNode(sortBydocumentOrderReversen)
+where
+documentOrderReverse::NavXmlTree->NavXmlTree->Ordering
+documentOrderReverseab=compare(documentPosb)(documentPosa)
+
+createDocumentOrderReversee@(XPVError_)=e
+createDocumentOrderReverse_=XPVError"Call to createDocumentOrderReverse without a nodeset"
+
+-- |
+-- Filter for removing identical fragment trees in a nodeset
+
+remDups::XPathFilter
+remDupse@(XPVError_)=e
+remDups(XPVNode[])=XPVNode[]
+remDups(XPVNode(x:xs))
+|isNotInNodeListxxs=XPVNode(x:y)
+|otherwise=remDups(XPVNodexs)
+where
+(XPVNodey)=remDups(XPVNodexs)
+remDups_=XPVError"Call to remDups without a nodeset"
+
+-- |
+-- Check whether a node is not a part of a node list. Needed to implement matching & testing in xslt.
+
+isNotInNodeList::NavXmlTree->[NavXmlTree]->Bool
+isNotInNodeListnxs'=nodeID(Justn)`notElem`map(nodeID.Just)xs'
+
+
+-- |
+-- calculate an ID for a NODE
+--
+-- - returns : a list of numbers, one number for each level of the tree
+
+-- Tim Walkenhorst:
+-- - Attributes are identified by their QName (they do not have previous siblings)
+-- - Elements are identified by their relative position (# of previous siblings)
+
+dataIdPathStep=IdRootString|IdPosInt|IdAttrQNamederiving(Show,Eq,Ord)
+
+nodeID::Maybe(NavXmlTree)->[IdPathStep]
+nodeIDNothing=[]
+nodeID(Justt@(NT(NTree(XAttrqn)_)___))=IdAttrqn:nodeID(upNTt)
+nodeID(Justt@(NTnode_prev_))
+|XN.isRootnode
+=return$IdRoot(getRootIdnode)
+|otherwise
+=IdPos(lengthprev):nodeID(upNTt)
+where
+getRootId=concat.runLA(getAttrValue"rootId")
+
+-- |
+-- Calculates the position of a node in a tree (in document order)
+
+documentPos::NavXmlTree->[IdPathStep]
+documentPostree=reverse$nodeID(Justtree)
+
+
+-- |
+-- Evaluates a function.
+-- Calculation of the function value is done by looking up the function name in the function table,
+-- check the number of arguments and calculate the funtion, if no
+-- argument evaluation returns an error.
+--
+-- - returns : the function value as 'XPathValue'
+
+evalFct::FctName->Env->Context->[XPathValue]->XPathValue
+evalFctnameenvcontargs
+=case(lookupnamefctTable)of
+Nothing->XPVError("Call to undefined function "++name)
+Just(fct,checkArgCount)->
+ifnot(checkArgCountargs)
+thenXPVError("Call to function "++name++" with wrong arguments")
+elsecase(checkArgErrorsargs)of
+Juste->e
+Nothing->fctcontenvargs
+where
+checkArgErrors[]=Nothing
+checkArgErrors((XPVErrorr):_)=Just(XPVErrorr)
+checkArgErrors(_:xs)=checkArgErrorsxs
+
+
+-- |
+-- Converts a list of different 'XPathValue' types in a list of one 'XPathValue' type.
+--
+-- * 1.parameter fct : the conversion function
+--
+
+toXValue::XFct->Context->Env->[XPathValue]->[XPathValue]
+toXValuefctcenvargs=[fctcenv[x]|x<-args]
+
+
+-- -----------------------------------------------------------------------------
+-- core-funktions library
+
+-- nodeset functions
+
+-- |
+-- number last(): returns a number equal to the context size from the expression evaluation context
+
+xlast::XFct
+xlast(_,len,_)__=XPVNumber$int2XPNumberlen
+
+
+-- |
+-- number position(): returns a number equal to the context position from the expression evaluation context
+
+xposition::XFct
+xposition(pos,_,_)__=XPVNumber$int2XPNumberpos
+
+
+-- |
+-- number count(node-set): returns the number of nodes in the argument node-set
+
+xcount::XFct
+xcount__[XPVNodens]=XPVNumber$int2XPNumber$lengthns
+xcount___=XPVError"Call to function count with wrong arguments"
+
+
+-- |
+-- node-set id(object): selects elements by their unique ID
+
+xid::XFct
+xid(_,_,cn)env[XPVNodens]
+=isInId(getIdsenv)(strValuesns)[cn]
+where
+strValues=map((\(XPVStringstr)->str).stringValue)
+
+xidc@(_,_,cn)envarg
+=isInId(getIdsenv)((\(XPVStrings)->wordss)(xstringcenvarg))[cn]
+
+
+
+-- |
+-- returns all IDs from the variable environment as a list of strings.
+-- the IDs are stored in the variable: idAttr
+
+getIds::Env->[String]
+getIdsenv
+-- hier muss noch auf prefix getestet werden
+=words$(\(XPVStringstr)->str).fromJust$lookup("","idAttr")$getVarTabenv
+
+
+isInId::[String]->[String]->NavXmlTrees->XPathValue
+isInIdidsstrns
+=remDups(XPVNode(concat$map(filterNSidsstr.descendantOrSelfAxis)ns))
+
+
+filterNS::[String]->[String]->NavXmlTrees->NavXmlTrees
+filterNSidsstrns
+=[n|n@(NTa@(NTree__)___)<-ns,or$map(idInIdListastr)ids]
+where
+idInIdList::XmlTree->[String]->String->Bool
+idInIdListalstr'b=(getValuebal)`elem`str'
+
+
+-- |
+-- string local-name(node-set?):
+-- returns the local part of the expanded-name of the node in the argument node-set
+-- that is first in document order.
+-- If the argument node-set is empty or the first node has no expanded-name, an empty string is returned.
+-- If the argument is omitted, it defaults to a node-set with the context node as its only member
+
+-- Bugfix: name(\/) is "" not "\/"!
+
+xlocalName::XFct
+xlocalName(_,_,cn)_[]=XPVString(xpLocalPartOf$subtreeNTcn)
+xlocalName__[XPVNode[]]=XPVString""
+xlocalName__[XPVNodens]=XPVString(xpLocalPartOf$subtreeNT$head$ns)
+xlocalName___=XPVError"Call to function local-name with wrong arguments"
+
+-- |
+-- string namespace-uri(node-set?):
+-- returns the namespace URI of the expanded-name of the node in the argument node-set
+-- that is first in document order.
+-- If the argument node-set is empty, the first node has no expanded-name,
+-- or the namespace URI of the expanded-name
+-- is null, an empty string is returned. If the argument is omitted,
+-- it defaults to a node-set with the context node as its only member
+
+xnamespaceUri::XFct
+xnamespaceUri(_,_,cn)_[]=XPVString(xpNamespaceOf$subtreeNTcn)
+xnamespaceUri__[XPVNode[]]=XPVString""
+xnamespaceUri__[XPVNodens]=XPVString(xpNamespaceOf$subtreeNT$head$ns)
+xnamespaceUri___=XPVError"Call to function namespace-uri with wrong arguments"
+
+
+-- |
+-- string name(node-set?):
+-- returns a string containing a QName representing the expanded-name of the node
+-- in the argument node-set
+-- that is first in document order. If the argument node-set is empty or the first
+-- node has no expanded-name,
+-- an empty string is returned. If the argument it omitted, it defaults to a node-set
+-- with the context node as its only member.
+-- Tim Walkenhorst:
+
+-- Bugfix: name(\/) is "" not "\/"!
+
+xname::XFct
+xname(_,_,cn)_[]=XPVString(xpNameOf$subtreeNTcn)
+xname__[XPVNode[]]=XPVString""
+xname__[XPVNodens]=XPVString(xpNameOf$subtreeNT$head$ns)
+xname___=XPVError"Call to function name with wrong arguments"
+
+-- ------------------------------------------------------------
+-- string functions
+
+-- |
+-- some helper functions
+getFirstPos::String->String->Int
+getFirstPosssub
+=if(getFirstPos'ssub)>lengths
+then-1
+elsegetFirstPos'ssub
+
+getFirstPos'::String->String->Int
+getFirstPos'[]_=2
+getFirstPos'(x:xs)sub
+=ifstrStartsWith(x:xs)sub
+then0
+else1+getFirstPos'xssub
+
+strStartsWith::String->String->Bool
+strStartsWithab
+=take(lengthb)a==b
+
+
+
+-- |
+-- Returns the string-value of a node,
+-- the value of a namespace node is not supported
+
+stringValue::NavXmlTree->XPathValue
+stringValue(NTa___)
+=XPVString$xpTextOfa
+
+{-
+ textFilter
+ = getXCmt `orElse`
+-- getXNamespace `orElse`
+ multi isXText
+
+-- = (isXTag `guards` multi isXText) `orElse`
+-- (isXPi `guards` multi isXText) `orElse`
+-- (isXAttr `guards` multi isXText) `orElse`
+-- (isXText `guards` multi isXText) `orElse`
+-- getXCmt
+-}
+
+
+-- |
+-- string string(object?): converts an object to a string
+
+xstring::XFct
+xstring__[XPVNode[]]=XPVString""
+xstring__[XPVNode(x:_)]=stringValuex
+xstring(_,_,cn)_[]=stringValuecn
+
+xstring__[XPVNumber(Floata)]
+|a==(fromInteger$rounda)=XPVString(show((rounda)::Integer))
+|otherwise=XPVString(showa)
+xstring__[XPVNumbers]=XPVString(shows)
+
+xstring__[XPVBoolTrue]=XPVString"true"
+xstring__[XPVBoolFalse]=XPVString"false"
+
+xstring__[XPVStrings]=XPVStrings
+xstring__[XPVErrore]=XPVErrore
+xstring___=XPVError"Call to xstring with a wrong argument"
+
+
+
+-- |
+-- string concat(string, string, string*): returns the concatenation of its arguments
+
+xconcat::XFct
+xconcatcenvargs
+=XPVString(foldr(\(XPVStrings)->(s++))""(toXValuexstringcenvargs))
+
+
+-- |
+-- boolean starts-with(string, string):
+-- returns true if the first argument string starts
+-- with the second argument string, and otherwise returns false
+
+xstartsWith::XFct
+xstartsWithcenvargs
+=XPVBool((\((XPVStringa):[XPVStringb])->strStartsWithab)(toXValuexstringcenvargs))
+
+
+-- |
+-- boolean contains(string, string):
+-- returns true if the first argument string contains the second argument string,
+-- and otherwise returns false
+
+xcontains::XFct
+xcontainscenvargs
+=XPVBool((\((XPVStrings):[XPVStringsub])->getFirstPosssub/=-1)(toXValuexstringcenvargs))
+
+
+-- |
+-- string substring-before(string, string):
+-- returns the substring of the first argument string that precedes the first occurrence of
+-- the second argument string
+-- in the first argument string, or the empty string if the first argument string does not
+-- contain the second argument string
+
+xsubstringBefore::XFct
+xsubstringBeforecenvargs
+=xsubstringBefore'cenv(toXValuexstringcenvargs)
+
+xsubstringBefore'::XFct
+xsubstringBefore'__((XPVString_):[XPVString[]])=XPVString""
+xsubstringBefore'__((XPVStrings):[XPVStringsub])=XPVString(take(getFirstPosssub)s)
+xsubstringBefore'___=XPVError"Call to xsubstringBefore' with a wrong argument"
+
+
+
+
+-- |
+-- string substring-after(string, string):
+-- returns the substring of the first argument string that follows the first occurrence of
+-- the second argument string
+-- in the first argument string, or the empty string if the first argument string does not
+-- contain the second argument string
+
+xsubstringAfter::XFct
+xsubstringAftercenvargs
+=xsubstringAfter'cenv(toXValuexstringcenvargs)
+
+xsubstringAfter'::XFct
+xsubstringAfter'__((XPVStrings):[XPVString[]])
+=XPVStrings
+xsubstringAfter'__((XPVStrings):[XPVStringsub])
+=ifgetFirstPosssub==-1
+then(XPVString"")
+elseXPVString(drop((getFirstPosssub)+lengthsub)s)
+xsubstringAfter'___
+=XPVError"Call to xsubstringAfter' with a wrong argument"
+
+
+-- |
+-- string substring(string, number, number?):
+-- returns the substring of the first argument starting at the position specified
+-- in the second argument
+-- with length specified in the third argument. If the third argument is not specified,
+-- it returns the substring
+-- starting at the position specified in the second argument and continuing to the end of the string.
+
+xsubstring::XFct
+xsubstringcenv(x:xs)
+=xsubstring'cenv((toXValuexstringcenv[x])++(toXValuexnumbercenvxs))
+xsubstring___
+=XPVError"Call to xsubstring with a wrong argument"
+
+xsubstring'::XFct
+xsubstring'cenv((XPVStrings):start:[])
+=casexroundcenv[start]of
+XPVNumberNaN->XPVString""
+XPVNumberPosInf->XPVString""
+XPVNumber(Floatf)->XPVString(drop((roundf)-1)s)
+XPVNumber_->XPVStrings
+_->XPVError"Call to xsubstring' with a wrong argument"
+
+xsubstring'cenv((XPVStrings):start:[end])
+=casexPathAddPlus(xroundcenv[start])(xroundcenv[end])of
+XPVNumber(Floatf)->xsubstring'cenv((XPVString(take((roundf)-1)s)):[start])
+XPVNumberPosInf->xsubstring'cenv((XPVStrings):[start])
+XPVNumber_->XPVString""
+_->XPVError"Call to xsubstring' with a wrong argument"
+xsubstring'___
+=XPVError"Call to xsubstring' with a wrong argument"
+
+
+-- |
+-- number string-length(string?):
+-- returns the number of characters in the string. If the argument is omitted,
+-- it defaults to the context node
+-- converted to a string, in other words the string-value of the context node.
+
+xstringLength::XFct
+xstringLengthc@(_,_,cn)env[]
+=XPVNumber(Float(fromIntegral$lengths))
+where(XPVStrings)=xstringcenv[XPVNode[cn]]
+xstringLengthcenvargs
+=XPVNumber$(\[XPVStrings]->int2XPNumber$lengths)(toXValuexstringcenvargs)
+
+
+-- |
+-- string normalize-space(string?):
+-- returns the argument string with whitespace normalized by stripping leading
+-- and trailing whitespace and replacing sequences
+-- of whitespace characters by a single space. If the argument is omitted,
+-- it defaults to the context node converted to a string,
+-- in other words the string-value of the context node.
+-- The string is parsed by a function parseStr from XPathParser module. <-- No longer! Tim Walkenhorst
+
+xnormalizeSpace::XFct
+xnormalizeSpacec@(_,_,cn)env[]
+=(\(XPVStrings)->XPVString$normStrs)(xstringcenv[XPVNode[cn]])
+xnormalizeSpacecenvargs
+=(\[XPVStrings]->XPVString$normStrs)(toXValuexstringcenvargs)
+
+-- Tim Walkenhorst normStr replaces the use of parseStr...
+normStr::String->String
+normStr=unwords.words
+
+-- |
+-- string translate(string, string, string):
+-- returns the first argument string with occurrences of characters in the second argument string replaced by the character at
+-- the corresponding position in the third argument string
+xtranslate::XFct
+xtranslatecenvargs
+=xtranslate'cenv(toXValuexstringcenvargs)
+
+xtranslate'::XFct
+xtranslate'__((XPVStringa):(XPVStringb):[XPVStringc])
+=XPVString(replaceabc)
+xtranslate'___
+=XPVError"Call to xtranslate' with a wrong argument"
+
+replace::String->String->String->String
+replacestr[]_=str
+
+-- remove all characters, if there is no corresponding character in the third argument
+replacestr(x:xs)[]
+=replace[s|s<-str,x/=s]xs[]
+
+replacestr(x:xs)(y:ys)
+=replace(repxystr)xsys
+where-- replace all characters in the first argument
+rep::Char->Char->String->String
+repab=foldr(\c->ifc==athen(b:)else(c:))""
+
+
+-- ------------------------------------------------------------
+-- boolean functions
+
+-- |
+-- boolean boolean(object): converts its argument to a boolean value
+xboolean::XFct
+xboolean__[XPVNumbera]=XPVBool(a/=NaN&&a/=Neg0&&a/=Pos0)
+xboolean__[XPVStrings]=XPVBool(lengths/=0)
+xboolean__[XPVBoolb]=XPVBoolb
+xboolean__[XPVNodens]=XPVBool(lengthns>0)
+xboolean__[XPVErrore]=XPVErrore
+xboolean___=XPVError"Call to xboolean with a wrong argument"
+
+
+-- |
+-- boolean not(boolean): returns true if its argument is false, and false otherwise
+xnot::XFct
+xnotcenvargs
+=XPVBool((\(XPVBoolb)->notb)(xbooleancenvargs))
+
+
+-- |
+-- boolean true(): returns true
+xtrue::XFct
+xtrue___=XPVBoolTrue
+
+
+-- |
+-- boolean false(): returns false
+xfalse::XFct
+xfalse___=XPVBoolFalse
+
+
+-- |
+-- boolean lang(string):
+-- returns true or false depending on whether the language of the context node as specified by xml:lang attributes
+-- is the same as or is a sublanguage of the language specified by the argument string
+
+-- function needs namespaces which are not supported by the toolbox
+xlang::XFct
+xlang___
+=XPVError"namespaces are not supported"
+
+-- xlang c env args
+-- = (\ (_, _, cn) [XPVString s] -> ...) c (toXValue xstring c env args)
+
+
+
+-- ------------------------------------------------------------
+-- number functions
+
+-- |
+-- number number(object?): converts its argument to a number
+xnumber::XFct
+xnumberc@(_,_,cn)env[]
+=(\(XPVStrings)->parseNumbers)(xstringcenv[XPVNode[cn]])
+xnumbercenv[n@(XPVNode_)]
+=(\(XPVStrings)->parseNumbers)(xstringcenv[n])
+
+xnumber__[XPVBoolb]
+|b=XPVNumber(Float1)
+|otherwise=XPVNumberPos0
+
+xnumber__[XPVStrings]=parseNumbers
+xnumber__[XPVNumbera]=XPVNumbera
+xnumber__[XPVErrore]=XPVErrore
+xnumber___=XPVError"Call to xnumber with a wrong argument"
+
+
+-- |
+-- number sum(node-set):
+-- returns the sum, for each node in the argument node-set, of the result of
+-- converting the string-values of the node to a number
+xsum::XFct
+xsum__[XPVNode[]]=XPVNumberNaN
+xsumcenv[XPVNodens]
+=foldr1(\ab->(xPathAddPlusab))(getValuesns)
+where
+getValues::NodeSet->[XPathValue]
+getValues=foldr(\n->([xnumbercenv$[stringValuen]]++))[]
+
+xsum___
+=XPVError"The value of the function sum is not a nodeset"
+
+-- |
+-- number floor(number): returns the largest (closest to positive infinity) number that is not greater
+-- than the argument and that is an integer
+xfloor::XFct
+xfloorcenvargs
+=xfloor'(toXValuexnumbercenvargs)
+where
+xfloor'[XPVNumber(Floatf)]
+|f>0&&f<1=XPVNumberPos0
+|otherwise=XPVNumber(Float(fromInteger$floorf))
+xfloor'[XPVNumbera]=XPVNumbera
+xfloor'_=XPVError"Call to xfloor' without a number"
+
+
+-- |
+-- number ceiling(number): returns the smallest (closest to negative infinity) number that is not less
+-- than the argument and that is an integer
+xceiling::XFct
+xceilingcenvargs
+=xceiling'(toXValuexnumbercenvargs)
+where
+xceiling'[XPVNumber(Floatf)]
+|f<0&&f>-1=XPVNumberPos0
+|otherwise=XPVNumber(Float(fromInteger$ceilingf))
+xceiling'[XPVNumbera]=XPVNumbera
+xceiling'_=XPVError"Call to xceiling' without a number"
+
+-- |
+-- number round(number):
+-- returns the number that is closest to the argument and that is an integer.
+-- If there are two such numbers, then the one that is closest to positive infinity is returned.
+xround::XFct
+xroundcenvargs
+=xround'cenv(toXValuexnumbercenvargs)
+
+xround'::XFct
+xround'__[XPVNumber(Floatf)]
+|f<0&&f>=-0.5=XPVNumberNeg0
+|f>=0&&f<0.5=XPVNumberPos0
+|otherwise=XPVNumber(Float(fromInteger$xPathRoundf))
+where
+xPathRounda
+=ifa-(fromInteger$floora)<0.5
+thenfloora
+elsefloor(a+1)
+
+xround'__[XPVNumbera]=XPVNumbera
+xround'___=XPVError"Call to xround' without a number"
+
+
+
+-- |
+-- node-set key(string, object):
+-- does for keys what the id function does for IDs
+-- The first argument specifies the name of the key.
+-- When the second argument is of type node-set, then the result is the
+-- union of the result of applying the key function to the string value
+-- of each of the nodes in the argument node-set.
+-- When the second argument is of any other type, the argument is
+-- converted to a string
+xkey::XFct
+xkey_env((XPVStrings):[XPVNodens])
+=isInKey(getKeyTabenv)s(strValuesns)
+where
+strValues=map((\(XPVStringstr)->str).stringValue)
+
+xkeycenv((XPVStrings):arg)
+-- = isInKey (getKeyTab env) s ( (\(XPVString s) -> words s) (xstring c env arg))
+=isInKey(getKeyTabenv)s[str]
+where
+(XPVStringstr)=xstringcenvarg
+
+xkey___=XPVError"Call to xkey with a wrong argument"
+
+
+isInKey::KeyTab->String->[String]->XPathValue
+isInKeyktknkv
+-- = remDups (XPVNode (map ntree ts) )
+=XPVNodets--(map ntree ts)
+where
+(_,_,ts)=unzip3$concat$map(isKeyVal(isKeyNamektkn))kv
+
+isKeyName::KeyTab->String->KeyTab
+isKeyNamektkn=filter(isOfKeyNamekn)kt
+
+isKeyVal::KeyTab->String->KeyTab
+isKeyValktkv=filter(isOfKeyValuekv)kt
+
+isOfKeyName::String->(QName,String,NavXmlTree)->Bool
+isOfKeyNamekn(qn,_,_)=(localPartqn)==kn
+
+
+isOfKeyValue::String->(QName,String,NavXmlTree)->Bool
+isOfKeyValuekv(_,v,_)=v==kv
+
+
+-- |
+-- string format-number(number, string, string?):
+-- converts its first argument to a string using the format pattern string
+-- specified by the second argument and the decimal-format named by the
+-- third argument, or the default decimal-format, if there is no third argument
+
+xformatNumber::XFct
+xformatNumbercenv(x:xs)
+=xsubstring'cenv((toXValuexstringcenv[x])++(toXValuexnumbercenvxs))
+xformatNumber___
+=XPVError"Call to xformatNumber with a wrong argument"
+
+
+-- Poor man's document(...) function. Opens exactly one document.
+-- Does not support "fragment identifiers". "Base-URI" is always current directory.
+-- Should still be good enough for home use.
+
+xdocument::XFct
+xdocumentceval=XPVNode$(\(XPVStrings)->xdocument's)$xstringceval
+
+xdocument'::String->[NavXmlTree]
+xdocument'uri=mapntree$
+unsafePerformIO$
+runX(readDocument[(a_validate,v_0)]uri
+>>>
+addAttr"rootId"("doc "++uri)
+)
+
+-- generate-id, should be fully compliant with XSLT specification.
+xgenerateId::XFct
+xgenerateId__[XPVNode(node:_)]=xgenerateId'node
+xgenerateId(_,_,node)_[]=xgenerateId'node
+xgenerateId___=error"illegal arguments in xgenerateId"
+
+xgenerateId'::NavXmlTree->XPathValue
+xgenerateId'=XPVString.("id_"++).str2XmlId.show.nodeID.Just
+
+str2XmlId::String->String
+str2XmlId=concatMapconvert
+whereconvertc=ifisAsciic&&(isUpperc||isLowerc||isDigitc)
+then[c]
+else"_"++(show$ordc)++"_"
+
+-- ------------------------------------------------------------
+
+xpNamePart::LAXmlTreeString->XmlTree->String
+xpNamePartgetNp
+=concat
+.
+runLA(ifAisRoot
+(constA"")
+getNp
+)
+
+xpLocalPartOf::XmlTree->String
+xpLocalPartOf=xpNamePartgetLocalPart
+
+xpNamespaceOf::XmlTree->String
+xpNamespaceOf=xpNamePartgetNamespaceUri
+
+xpNameOf::XmlTree->String
+xpNameOf=xpNamePartgetName
+
+getValue::String->XmlTree->String
+getValuen=concat.runLA(getAttrValuen)
+
+xpTextOf::XmlTree->String
+xpTextOf=concat.runLA(xshow((getCmt>>>mkText)<+>deepisText))
+
+-- ------------------------------------------------------------
+
-- |
+-- Convert an XPath result set into a node set
+--
+
+
+moduleText.XML.HXT.XPath.XPathToNodeSet
+(xPValue2NodeSet
+,emptyNodeSet
+)
+where
+
+importText.XML.HXT.DOM.TypeDefs
+importText.XML.HXT.XPath.XPathDataTypes
+
+importData.Maybe
+
+-- -----------------------------------------------------------------------------
+-- |
+-- Convert a a XPath-value into a XmlNodeSet represented by a tree structure
+--
+-- The XmlNodeSet can be used to traverse a tree an process all
+-- marked nodes.
+
+xPValue2NodeSet::XPathValue->XmlNodeSet
+xPValue2NodeSet(XPVNodens)
+=toNodeSetns
+
+xPValue2NodeSet_
+=emptyNodeSet
+
+emptyNodeSet::XmlNodeSet
+emptyNodeSet=XNSFalse[][]
+
+leafNodeSet::XmlNodeSet
+leafNodeSet=XNSTrue[][]
+
+toNodeSet::NodeSet->XmlNodeSet
+toNodeSet
+=pathListToNodeSet.maptoPath
+
+toPath::NavXmlTree->XmlNodeSet
+toPath
+=upTreeleafNodeSet
+
+
+upTree::XmlNodeSet->NavXmlTree->XmlNodeSet
+upTreepst@(NT(NTreen_)_parleft_right)
+=up(upNTt)
+where
+up(Justpt)
+|isJust.upNT$pt-- pt is a "real" node
+=upTree(pixn)pt
+|otherwise-- pt is the added root node, stop recursion
+=ps
+upNothing-- never used recursion should stop earler
+=ps
+
+pix(XAttrqn)=XNSFalse[qn][]
+pix_=XNSFalse[][(lengthleft,ps)]
+
+pathListToNodeSet::[XmlNodeSet]->XmlNodeSet
+pathListToNodeSet
+=foldrmergePathsemptyNodeSet
+where
+mergePaths(XNSp1al1cl1)(XNSp2al2cl2)
+=XNS(p1||p2)(al1++al2)(mergeSubPathscl1cl2)
+
+mergeSubPaths[]sp2=sp2
+mergeSubPaths(s1:sp1)sp2=mergeSubPaths1(mergeSubPathssp1sp2)
+
+mergeSubPaths1[]
+=[s1]
+mergeSubPaths1@(ix1,p1)sl@(s2@(ix2,p2):sl')
+|ix1<ix2=s1:sl
+|ix1>ix2=s2:mergeSubPaths1sl'-- ordered insert of s1
+|otherwise=(ix1,mergePathsp1p2):sl'-- same ix merge subpaths
+
+-- -----------------------------------------------------------------------------
+
-- ------------------------------------------------------------
+
+{- |
+ Module : Text.XML.HXT.XSLT.XsltArrows
+ Copyright : Copyright (C) 2006 Tim Walkenhorst, Uwe Schmidt
+ License : MIT
+
+ Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
+ Stability : experimental
+ Portability: portable
+ Version : $Id: XsltArrows.hs,v 1.1 2006/11/11 15:36:05 hxml Exp $
+
+ The HXT arrow interface for the XSLT module
+
+ The application programming interface to the arrow modules of the Haskell XML Toolbox.
+ This module exports all important arrows for input, output, parsing, validating and transforming XML.
+ It also exports all basic datatypes and functions of the toolbox.
+
+-}
+
+-- ------------------------------------------------------------
+
+
+moduleText.XML.HXT.XSLT.XsltArrows
+(xsltCompileStylesheet
+,xsltCompileStylesheetFromURI
+,xsltApplyStylesheet
+,xsltApplyStylesheetFromURI
+,CompiledStylesheet
+)
+where
+
+importqualifiedControl.ExceptionasE
+(catch
+,evaluate)
+
+importControl.Arrow.ListArrows
+
+importText.XML.HXT.DOM.Interface
+importText.XML.HXT.Arrow.XmlIOStateArrow
+importText.XML.HXT.Arrow.XmlArrow
+importText.XML.HXT.Arrow.ReadDocument
+
+importText.XML.HXT.XSLT.Names
+
+importText.XML.HXT.XSLT.CompiledStylesheet
+(CompiledStylesheet)
+
+importText.XML.HXT.XSLT.Compilation
+(prepareXSLTDocument
+,assembleStylesheet
+)
+
+importText.XML.HXT.XSLT.Application
+(applyStylesheet)
+
+-- ------------------------------------------------------------
+
+-- | arrow for applying a pure partial function, catch the error case and issue the error
+
+arrWithCatch::(a->b)->IOSArrowab
+arrWithCatchf
+=arrIOapplyf
+>>>
+((applyA(arrissueErr)>>>none)
+|||
+this
+)
+where
+-- applyf :: a -> IO (Either String b)
+applyfx
+=E.catch(do
+res<-E.evaluate(fx)
+return.Right$res
+)
+(\e->return.Left.("XSLT: "++).show$e)
+
+-- ------------------------------------------------------------
+
+-- | lift prepareXSLTDocument
+
+prepareXSLTDoc::IOSArrowXmlTreeXmlTree
+prepareXSLTDoc
+=(arrWithCatchprepareXSLTDocument
+>>>
+traceDoc"prepareXSLTDocument"
+)
+`when`
+documentStatusOk
+
+-- | read an XSLT stylesheet
+
+readXSLTDoc::Attributes->IOSArrowStringXmlTree
+readXSLTDocoptions
+=readFromDocument(options++defaultOptions)
+where
+defaultOptions
+=[(a_check_namespaces,v_1)
+,(a_validate,v_0)
+,(a_preserve_comment,v_0)
+]
+
+-- | Normalize stylesheet, expand includes, select imports and assemble the rules
+
+compileSSTWithIncludeStack::[String]->IOSArrowXmlTreeCompiledStylesheet
+compileSSTWithIncludeStackincStack
+=traceMsg2"compile stylesheet"
+>>>
+getChildren-- remove document root
+>>>
+isElem-- select XSLT root element
+>>>
+choiceA
+[isXsltLREstylesheet-- simplified syntax
+:->(xsltlre2stylesheet
+>>>
+assStylesheet[]
+)
+,isXsltStylesheetElem-- xsl:stylesheet or xsl:transform
+:->(expStylesheet
+$<(listA(getChildren-- take contents and expand includes
+>>>
+expandIncludesincStack
+)
+>>>
+partitionAisXsltImport-- separate imports from normal rules
+)
+)
+,this
+:->(issueErr"XSLT: Either xsl:stylesheet/xsl:transform or simplified syntax expected"
+>>>
+none
+)
+]
+where
+assStylesheetimports-- do the assembly, the compilation
+=arrWithCatch(flipassembleStylesheet$imports)
+
+expStylesheet(imports,rest)
+=traceMsg2"expandStylesheet"
+>>>
+setChildrenrest-- remove import rules from stylesheet
+>>>
+assStylesheet$<listA(constLimports-- read the imports and assemble the stylesheet
+>>>
+getXsltAttrValuexsltHRef
+>>>
+compileSSTFromUriWithIncludeStackincStack
+)
+
+-- | read an include and check for recursive includes
+
+readSSTWithIncludeStack::[String]->IOSArrowStringXmlTree
+readSSTWithIncludeStackincStack
+=ifP(`elem`incStack)
+((issueErr$<arrrecursiveInclude)>>>none)
+(readXSLTDoc[]
+>>>
+prepareXSLTDoc
+)
+where
+recursiveIncludeuri
+="XSLT error: "
+++showuri++" is recursively imported/included."
+++concatMap(("\n imported/included from: "++).show)incStack
+
+compileSSTFromUriWithIncludeStack::[String]->IOSArrowStringCompiledStylesheet
+compileSSTFromUriWithIncludeStackincStack
+=comp$<this
+where
+compuri
+=readSSTWithIncludeStackincStack
+>>>
+compileSSTWithIncludeStack(uri:incStack)
+
+expandIncludes::[String]->IOSArrowXmlTreeXmlTree
+expandIncludesincStack
+=isElem
+>>>
+((expandInclude$<getXsltAttrValuexsltHRef)
+`when`
+isXsltInclude
+)
+where
+expandIncludehref
+=(constAhref
+>>>
+readSSTWithIncludeStackincStack
+>>>
+getChildren
+>>>
+isElem
+>>>
+choiceA
+[isXsltLREstylesheet
+:->xsltlre2template
+
+,isXsltStylesheetElem
+:->(getChildren
+>>>
+expandIncludes(href:incStack)
+)
+
+,this
+:->issueFatal("XSLT error: Included file "++showhref++" is not a stylesheet")
+]
+)
+
+isXsltElem::ArrowXmla=>QName->aXmlTreeXmlTree
+isXsltElemqn=isElem>>>hasNameWith(equivQNameqn)
+
+isXsltAttr::ArrowXmla=>QName->aXmlTreeXmlTree
+isXsltAttrqn=isAttr>>>hasNameWith(equivQNameqn)
+
+hasXsltAttr::ArrowXmla=>QName->aXmlTreeXmlTree
+hasXsltAttrqn=(getAttrl>>>isXsltAttrqn)
+`guards`
+this
+
+isXsltInclude::ArrowXmla=>aXmlTreeXmlTree
+isXsltInclude=isXsltElemxsltInclude
+
+isXsltImport::ArrowXmla=>aXmlTreeXmlTree
+isXsltImport=isXsltElemxsltImport
+
+isXsltLREstylesheet::ArrowXmla=>aXmlTreeXmlTree
+isXsltLREstylesheet=hasXsltAttrxsltVersionLRE
+
+isXsltStylesheetElem::ArrowXmla=>aXmlTreeXmlTree
+isXsltStylesheetElem=(isXsltElemxsltTransform
+<+>
+isXsltElemxsltStylesheet
+)
+>>>
+hasXsltAttrxsltVersion
+
+getXsltAttrValue::ArrowXmla=>QName->aXmlTreeString
+getXsltAttrValueqn=getAttrl>>>isXsltAttrqn>>>xshowgetChildren
+
+xsltlre2template::ArrowXmla=>aXmlTreeXmlTree
+xsltlre2template=mkqelemxsltTemplate[sqattrxsltMatch"/"][this]
+
+xsltlre2stylesheet::ArrowXmla=>aXmlTreeXmlTree
+xsltlre2stylesheet=mkqelemxsltTransform[][this>>>xsltlre2template]
+
+--
+
+checkApplySST::IOSArrowXmlTreeXmlTree->IOSArrowXmlTreeXmlTree
+checkApplySSTappl
+=(isRoot
+>>>
+replaceChildrenappl
+>>>
+traceDoc"XSLT stylesheet applied"
+>>>
+setDocumentStatusFromSystemState"applying XSLT styleshhet"
+)
+`orElse`
+issueErr"XSLT: complete document with root node required for stylesheet application"
+
+-- | Compile a document representing an XSLT stylesheet into an internal representation
+--
+-- The internal representation is an abstract syntax tree for the XSLT rules.
+-- XSLT imports and includes are evaluated and the rules are normalized and prepared
+-- for easy application.
+
+xsltCompileStylesheet::IOSArrowXmlTreeCompiledStylesheet
+xsltCompileStylesheet
+=prepareXSLTDoc
+>>>
+compileSSTWithIncludeStack[]
+
+-- | A convinient function for combining reading a stylesheet and compilation.
+--
+-- Reading an XSLT stylesheet is always done without validation but with
+-- namespace propagation. Comments are removed from the stylesheet.
+
+xsltCompileStylesheetFromURI::IOSArrowStringCompiledStylesheet
+xsltCompileStylesheetFromURI=compileSSTFromUriWithIncludeStack[]
+
+-- | apply a compiled XSLT stylesheet to a whole document tree
+--
+-- The compiled stylesheet must have been created with 'xsltCompileStylesheet'
+-- or 'xsltCompileStylesheetFromURI'
+
+xsltApplyStylesheet::CompiledStylesheet->IOSArrowXmlTreeXmlTree
+xsltApplyStylesheetcss
+=checkApplySST(arrWithCatch(applyStylesheetcss)>>.concat)
+
+-- | apply an XSLT stylesheet given by an URI to a whole document tree
+--
+-- The string parameter is the URI of the XSLT stylesheet.
+-- In case of an error during stylesheet compilation or stylesheet application
+-- all children of the root node are removed and
+-- the error status is set in the attribute list of the root node of the input document.
+
+xsltApplyStylesheetFromURI::String->IOSArrowXmlTreeXmlTree
+xsltApplyStylesheetFromURIuri
+=xsltApplyStylesheet$<(constAuri>>>xsltCompileStylesheetFromURI)
+
+{-
+xsltApplyStylesheetWParams :: Map ExName Expr -> CompiledStylesheet -> IOSArrow XmlTree XmlTree
+xsltApplyStylesheetWParams wp css = arrL (applyStylesheetWParams wp css)
+-}
+
This module defines the interface for list arrows.
-
A list arrow is a function, that gives a list of results
-for a given argument. A single element result represents a normal function.
-An empty list oven indicates, the function is undefined for the given argument.
-The empty list may also represent False, none empty lists True.
-A list with more than one element gives all results for a nondeterministic function.
-
Synopsis
class (Arrow a, ArrowPlus a, ArrowZero a, ArrowApply a) => ArrowList a where
converts an arrow, that may fail, into an arrow that always succeeds
-
example: withDefault none "abc" is equivalent to constA "abc"
-
single :: a b c -> a b c
makes a list arrow deterministic, the number of results is at most 1
-
definition
-
single f = f >>. take 1
-
examples with strings:
-
runLA ( single none ) "x" == []
- runLA ( single this ) "x" == ["x"]
- runLA ( single
- (constA "y"
- <+> this ) ) "x" == ["y"]
-
applyA :: a b (a b c) -> a b c
compute an arrow from the input and apply the arrow to this input
-
definition: (f &&& this) >>> app
-
in a point free style, there is no way to use an argument in 2 places,
- this is a combinator for simulating this. first the argument is used to compute an arrow,
- then this new arrow is applied to the input
-
applyA coresponds to: apply f x = let g = f x in g x
-
infixString :: String -> String -> a String String
- infixString s1 s2
- = arr (\ s -> s1 ++ s ++ s2)
-
- runLA ( infixString $<< constA "y" &&& constA "z" ) "x" = ["yxz"]
- runLA ( infixString $<< this &&& this ) "x" = ["xxx"]
- runLA ( infixString $<< constA "y"
- &&& (constA "z" <+> this) ) "x" = ["yxz", "yxx"]
-
($<<<) :: (c1 -> c2 -> c3 -> a b d) -> a b (c1, (c2, c3)) -> a b d
version of $< for arrows with 3 extra parameters
-
typical usage
-
f $<<< g1 &&& g2 &&& g3
-
($<<<<) :: (c1 -> c2 -> c3 -> c4 -> a b d) -> a b (c1, (c2, (c3, c4))) -> a b d
version of $< for arrows with 4 extra parameters
-
typical usage
-
f $<<<< g1 &&& g2 &&& g3 &&& g4
-
($<$) :: (c -> a b b) -> a b c -> a b b
compute the parameter for an arrow f with an extra parameter by an arrow g
- and apply all the results from g sequentially to the input
-
infixl 2 ($<$)
-
typical usage:
-
g :: a b c
- g = ...
-
- f :: c -> a b b
- f x = ... x ...
-
- f $<$ g
-
f computes the extra parameters for g from the input of type b and g is applied with this
- parameter to the input. This allows programming in a point wise style in g, which becomes
- neccessary, when a value is needed more than once.
-
this combinator is useful, when transforming a single value (document) step by step,
- with g for collecting the data for all steps, and f for transforming the input step by step
-
if g is deterministic (computes exactly one result),
- g $<$ f == g $< f holds
-
if g fails, f $<$ g == this
-
if g computes more than one result, f is applied sequentially to the input for every result from g
-
examples with simple list arrows with strings
-
prefixString :: String -> a String String
- prefixString s = arr (s++)
-
- runLA ( prefixString $<$ none ) "x" == ["x"]
- runLA ( prefixString $<$ constA "y" ) "x" == ["yx"]
- runLA ( prefixString $<$ constA "y" <+> constA "z" ) "x" == ["zyx"]
- runLA ( prefixString $<$ constA "y" <+> this
- <+> constA "z" ) "x" == ["zxyx"]
-
example with two extra parameter
-
g1 :: a b c1
- g2 :: a b c2
-
- f :: (c1, c2) -> a b b
- f (x1, x2) = ... x1 ... x2 ...
-
- f $<$ g1 &&& g2
-
complete evaluation of an arrow result using deepSeq
- and strict
-
this is sometimes useful for preventing space leaks, especially after reading
- and validation of a document, all DTD stuff is not longer in use and can be
- recycled by the GC.
-
processChildren :: Tree t => a (t b) (t b) -> a (t b) (t b)
apply an arrow element wise to all children of the root of a tree
- collect these results and substitute the children with this result
-
example: processChildren isText deletes all subtrees, for which isText does not hold
-
example: processChildren (none `when` isCmt) removes all children, for which isCmt holds
-
replaceChildren :: Tree t => a (t b) (t b) -> a (t b) (t b)
similar to processChildren, but the new children are computed by processing
- the whole input tree
-
example: replaceChildren (deep isText) selects all subtrees for which isText holds
- and substitutes the children component of the root node with this list
-
(/>) :: Tree t => a (t b) (t b) -> a (t b) (t b) -> a (t b) (t b)
This expression selects
- all "h1" elements in the "body" element of an "html" element, an expression, that
- corresponds 1-1 to the XPath selection path "html/body/h1"
-
(</) :: Tree t => a (t b) (t b) -> a (t b) (t b) -> a (t b) (t b)
pronounced "outside" meaning f containing g
-
defined as f </ g = f `containing` (getChildren >>> g)
-
recursively searches a whole tree for subtrees, for which a predicate holds.
- The search is performed top down. When a tree is found, this becomes an element of the result
- list. The tree found is not further examined for any subtress, for which the predicate also could hold.
- See multi for this kind of search.
-
example: deep isHtmlTable selects all top level table elements in a document
- (with an appropriate definition for isHtmlTable) but no tables occuring within a table cell.
-
deepest :: Tree t => a (t b) (t b) -> a (t b) (t b)
recursively searches a whole tree for subrees, for which a predicate holds.
- The search is performed bottom up.
-
example: deepest isHtmlTable selects all innermost table elements in a document
- but no table elements containing tables. See deep and multi for other search strategies.
-
recursively searches a whole tree for subtrees, for which a predicate holds.
- The search is performed top down. All nodes of the tree are searched, even within the
- subtrees of trees for which the predicate holds.
-
example: multy isHtmlTable selects all table elements, even nested ones.
-
processBottomUp :: Tree t => a (t b) (t b) -> a (t b) (t b)
recursively transforms a whole tree by applying an arrow to all subtrees,
- this is done bottom up depth first, leaves first, root as last tree
-
example: processBottomUp (getChildren `when` isHtmlFont) removes all font tags in a HTML document, even nested ones
- (with an appropriate definition of isHtmlFont)
-
processTopDown :: Tree t => a (t b) (t b) -> a (t b) (t b)
similar to processBottomUp, but recursively transforms a whole tree by applying an arrow to all subtrees
- with a top down depth first traversal strategie. In many cases processBottomUp and processTopDown
- give same results.
-
processBottomUpWhenNot :: Tree t => a (t b) (t b) -> a (t b) (t b) -> a (t b) (t b)
recursively transforms a whole tree by applying an arrow to all subtrees,
- but transformation stops when a predicte does not hold for a subtree,
- leaves are transformed first
-
processTopDownUntil :: Tree t => a (t b) (t b) -> a (t b) (t b)
recursively transforms a whole tree by applying an arrow to all subtrees,
- but transformation stops when a tree is successfully transformed.
- the transformation is done top down
-
example: processTopDownUntil (isHtmlTable `guards` tranformTable)
- transforms all top level table elements into something else, but inner tables remain unchanged
-
insertChildrenAt :: Tree t => Int -> a (t b) (t b) -> a (t b) (t b)
computes a list of trees by applying an arrow to the input
- and inserts this list in front of index i in the list of children
-
example: insertChildrenAt 0 (deep isCmt) selects all subtrees for which isCmt holds
- and copies theses in front of the existing children
-
insertChildrenAfter :: Tree t => a (t b) (t b) -> a (t b) (t b) -> a (t b) (t b)
similar to insertChildrenAt, but the insertion position is searched with a predicate
-
insertTreeTemplate :: Tree t => a (t b) (t b) -> [IfThen (a (t b) c) (a (t b) (t b))] -> a (t b) (t b)
an arrow for inserting a whole subtree with some holes in it (a template)
- into a document. The holes can be filled with contents from the input.
-
Example
-
insertTreeTemplateTest :: ArrowXml a => a b XmlTree
- insertTreeTemplateTest
- = doc
- >>>
- insertTemplate template pattern
- where
- doc -- the input data
- = constA "<x><y>The Title</y><z>The content</z></x>"
- >>> xread
- template -- the output template with 2 holes: xxx and yyy
- = constA "<html><head><title>xxx</title></head><body><h1>yyy</h1></body></html>"
- >>> xread
- pattern
- = [ hasText (== "xxx") -- fill the xxx hole with the input contents from element "x/y"
- :-> ( getChildren >>> hasName "y" >>> deep isText )
-
- , hasText (== "yyy") -- fill the yyy hole with the input contents from element "x/z"
- :-> ( getChildren >>> hasName "z" >>> getChildren )
- ]
-
computes the XML tree for the following document
-
stolen from comp.lang.functional from Dean Herington
-
DeepSeq.lhs -- deep strict evaluation support
-
The DeepSeq class provides a method deepSeq that is similar to
-seq except that it forces deep evaluation of its first argument
-before returning its second argument.
-
Instances of DeepSeq are provided for Prelude types. Other
-instances must be supplied by users of this module.
-
Navigable tree structure which allow a program to traverse
- up the tree as well as down.
- copied and modified from HXML (http://www.flightlab.com/~joe/hxml/)
-
a navigable tree consists of a n-ary tree for the current fragment tree,
- a navigable tree for all ancestors, and two n-ary trees for
- the previous- and following siblings
-
The input must be a root node (constructed with root), usually without children.
- The attribute list contains all input parameters, e.g. URI or source file name, encoding preferences, ...
- If the source name is empty, the input is read from standard input.
-
The source is transformed into an absolute URI. If the source is a relative URI, or a file name,
- it is expanded into an absolut URI with respect to the current base URI.
- The default base URI is of protocol "file" and points to the current working directory.
-
The currently supported protocols are "http", "file", "stdin" and "string".
-
The latter two are internal protocols. An uri of the form "stdin:" stands for the content of
- the standard input stream.
-
"string:some text" means, that "some text" is taken as input.
- This internal protocol is used for reading from normal String values.
-
Applies some Canonical XML rules to a document 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.
-
Rules: remove DTD parts, processing instructions, comments and substitute char refs in attribute
- values and text
-
Not implemented yet:
-
Whitespace within start and end tags is normalized
-
Special characters in attribute values and character content are replaced by character references
-
substitutes all char refs in text and attribute values,
- removes CDATA section and combines all sequences of resulting text
- nodes into a single text node
-
Collects sequences of text nodes in the list of children of a node into one single text node.
- This is useful, e.g. after char and entity reference substitution
-
escape all special XML chars into XML entity references or char references
-
convert the special XML chars < and & in text nodes into prefefiened XML entity references,
- in attribute values also ', ", >, \n, \r and \t are converted into entity or char references,
- in comments nothing is converted (see XML standard 2.4, useful e.g. for JavaScript).
-
escape all special HTML chars into XHTML entity references or char references
-
convert the special XML chars < and & and all none ASCII chars in text nodes into prefefiened XML or XHTML entity references,
- in attribute values also ', ", >, \n, \r and \t are converted into entity or char references,
- in comments nothing is converted
-
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 or a document fragment
- result is the semantically equivalent formatted tree.
-
filter for removing all not significant whitespace.
-
the tree traversed for removing whitespace between elements,
- 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
-
attach all valid namespace declarations to the attribute list of element nodes.
-
This arrow is useful for document processing, that requires access to all namespace
- declarations at any element node, but which cannot be done with a simple processWithNsEnv.
-
collect all (namePrefix, namespaceUri) pairs from a tree
-
all qualified names are inspected, whether a namespace uri is defined,
- for these uris the prefix and uri is returned. This arrow is useful for
- namespace cleanup, e.g. for documents generated with XSLT. It can be used
- together with collectNamespaceDecl to cleanupNamespaces
-
test whether an attribute node contains an XML Namespace declaration
-
getNamespaceDecl :: ArrowXml a => a XmlTree (String, String)
get the namespace prefix and the namespace URI out of
- an attribute tree with a namespace declaration (see isNamespaceDeclAttr)
- for all other nodes this arrow fails
-
process all element nodes of a document tree with an arrow, containing always the
- valid namespace environment as extra parameter. Attribute lists are not processed.
-
substitution of all predefined XHTMT entities for none ASCII chars
-
This arrow recurses through a whole XML tree and substitutes all
- entity refs within text nodes and attribute values by a text node
- containing of a single char corresponding to this entity.
-
Datatypes and functions for building a content model
-for XML picklers. A schema is part of every pickler
-and can be used to derive a corrensponding DTD (or Relax NG schema).
-This schema further enables checking the picklers.
-
Pickler functions for converting between user defined data types
-and XmlTree data. Usefull for persistent storage and retreival
-of arbitray data as XML documents
-
This module is an adaptation of the pickler combinators
-developed by Andrew Kennedy
-( http://research.microsoft.com/~akenn/fun/picklercombinators.pdf )
-
The difference to Kennedys approach is that the target is not
-a list of Chars but a list of XmlTrees. The basic picklers will
-convert data into XML text nodes. New are the picklers for
-creating elements and attributes.
-
One extension was neccessary: The unpickling may fail.
-Therefore the unpickler has a Maybe result type.
-Failure is used to unpickle optional elements
-(Maybe data) and lists of arbitray length
-
There is an example program demonstrating the use
-of the picklers for a none trivial data structure.
-(see "examples/arrows/pickle" directory)
-
Conversion of an XML document tree into an arbitrary data type
-
The inverse of pickleDoc.
- This law should hold for all picklers: unpickle px . pickle px $ v == Just v .
- Not every possible combination of picklers make sense.
- For reconverting a value from an XML tree, is becomes neccessary,
- to introduce "enough" markup for unpickling the value
-
Nothing is mapped to the zero pickler, Just x is pickled with xpLift x.
-
xpCondSeq :: PU b -> (b -> a) -> PU a -> (a -> PU b) -> PU b
pickle/unpickle combinator for sequence and choice.
-
When the first unpickler fails,
- the second one is taken, else the third one configured with the result from the first
- is taken. This pickler is a generalisation for xpSeq and xpChoice .
-
The schema must be attached later, e.g. in xpPair or other higher level combinators
-
Run two picklers in sequence like with xpSeq.
- When during unpickling the first one fails,
- an alternative pickler (first argument) is applied.
- This pickler only is used as combinator for unpickling.
-
One of the most often used primitive picklers. Attention:
- For pickling empty strings use xpText0. If the text has a more
- specific datatype than xsd:string, use xpTextDT
-
Text pickler with a description of the structure of the text
- by a schema. A schema for a data type can be defined by scDT.
- In Schema there are some more functions for creating
- simple datatype descriptions.
-
Pickle a possibly empty string into an XML node.
-
Must be used in all places, where empty strings are legal values.
- If the content of an element can be an empty string, this string disapears
- during storing the DOM into a document and reparse the document.
- So the empty text node becomes nothing, and the pickler must deliver an empty string,
- if there is no text node in the document.
-
Pickle an arbitrary value by applyling show during pickling
- and read during unpickling.
-
Real pickling is then done with xpString.
- One of the most often used pimitive picklers. Applicable for all
- types which are instances of Read and Show
-
Encoding of list values by pickling all list elements sequentially.
-
Unpickler relies on failure for detecting the end of the list.
- The standard pickler for lists. Can also be used in combination with xpWrap
- for constructing set and map picklers
-
Every constructor is mapped to an index into the list of picklers.
- The index is used only during pickling, not during unpickling, there the 1. match is taken
-
Pickler functions for converting between user defined data types
-and XmlTree data. Usefull for persistent storage and retreival
-of arbitray data as XML documents
-
This module is an adaptation of the pickler combinators
-developed by Andrew Kennedy
-( http://research.microsoft.com/~akenn/fun/picklercombinators.pdf )
-
The difference to Kennedys approach is that the target is not
-a list of Chars but a list of XmlTrees. The basic picklers will
-convert data into XML text nodes. New are the picklers for
-creating elements and attributes.
-
One extension was neccessary: The unpickling may fail.
-Therefore the unpickler has a Maybe result type.
-Failure is used to unpickle optional elements
-(Maybe data) and lists of arbitray length
-
There is an example program demonstrating the use
-of the picklers for a none trivial data structure.
-(see "examples/arrows/pickle" directory)
-
The document is read with readDocument. Options are passed
- to readDocument. The conversion from XmlTree is done with the
- pickler.
-
xpickleDocument xp al dest >>> xunpickleDocument xp al' dest is the identity arrow
- when applied with the appropriate options. When during pickling indentation is switched on,
- the whitespace must be removed during unpickling.
-
A value is transformed into an XML document by a given pickler,
- the associated DTD is extracted from the pickler and checked,
- the document including the DTD is tranlated into a string,
- this string is read and validated against the included DTD,
- and unpickled.
- The last step is the equality with the input.
-
If the check succeeds, the arrow works like this, else it fails.
-
Conversion of an XML document tree into an arbitrary data type
-
The inverse of pickleDoc.
- This law should hold for all picklers: unpickle px . pickle px $ v == Just v .
- Not every possible combination of picklers make sense.
- For reconverting a value from an XML tree, is becomes neccessary,
- to introduce "enough" markup for unpickling the value
-
Every constructor is mapped to an index into the list of picklers.
- The index is used only during pickling, not during unpickling, there the 1. match is taken
-
Run two picklers in sequence like with xpSeq.
- When during unpickling the first one fails,
- an alternative pickler (first argument) is applied.
- This pickler only is used as combinator for unpickling.
-
xpCondSeq :: PU b -> (b -> a) -> PU a -> (a -> PU b) -> PU b
pickle/unpickle combinator for sequence and choice.
-
When the first unpickler fails,
- the second one is taken, else the third one configured with the result from the first
- is taken. This pickler is a generalisation for xpSeq and xpChoice .
-
The schema must be attached later, e.g. in xpPair or other higher level combinators
-
Encoding of list values by pickling all list elements sequentially.
-
Unpickler relies on failure for detecting the end of the list.
- The standard pickler for lists. Can also be used in combination with xpWrap
- for constructing set and map picklers
-
Pickle an arbitrary value by applyling show during pickling
- and read during unpickling.
-
Real pickling is then done with xpString.
- One of the most often used pimitive picklers. Applicable for all
- types which are instances of Read and Show
-
One of the most often used primitive picklers. Attention:
- For pickling empty strings use xpText0. If the text has a more
- specific datatype than xsd:string, use xpTextDT
-
Pickle a possibly empty string into an XML node.
-
Must be used in all places, where empty strings are legal values.
- If the content of an element can be an empty string, this string disapears
- during storing the DOM into a document and reparse the document.
- So the empty text node becomes nothing, and the pickler must deliver an empty string,
- if there is no text node in the document.
-
Text pickler with a description of the structure of the text
- by a schema. A schema for a data type can be defined by scDT.
- In Schema there are some more functions for creating
- simple datatype descriptions.
-
Input tree must be a root tree with a text tree as child containing the document to be parsed.
-The parser generates from the input string a tree of a wellformed XML document,
-processes the DTD (parameter substitution, conditional DTD parts, ...) and
-substitutes all general entity references. Next step is character reference substitution.
-Last step is the document validation.
-Validation can be controlled by an extra parameter.
-
Example:
-
parseXmlDocument True -- parse and validate document
-
- parseXmlDocument False -- only parse document, don't validate
-
This parser is useful for applications processing correct XML documents.
-
Input tree must be a root tree with a text tree as child containing the document to be parsed.
-The parser tries to parse everything as HTML, if the HTML document is not wellformed XML or if
-errors occur, warnings are generated. The warnings can be issued, or suppressed.
-
Example: parseHtmlDocument True : parse document and issue warnings
-
This parser is useful for applications like web crawlers, where the pages may contain
-arbitray errors, but the application is only interested in parts of the document, e.g. the plain text.
-
Input must be a complete document tree. The document
-is validated with respect to the DTD spec.
-Only useful for XML documents containing a DTD.
-
If the document is valid, it is transformed with respect to the DTD,
-normalization of attribute values, adding default values, sorting attributes by name,...
-
If no error was found, result is the normalized tree,
-else the error status is set in the list of attributes
-of the root node "/" and the document content is removed from the tree.
-
Input must be a complete document tree. The namespace declarations
-are evaluated and all element and attribute names are processed by
-splitting the name into prefix, local part and namespace URI.
-
Naames are checked with respect to the XML namespace definition
-
If no error was found, result is the unchanged input tree,
-else the error status is set in the list of attributes
-of the root node "/" and the document content is removed from the tree.
-
this filter can be configured by an option list, a value of type Attributes
-
available options:
-
a_parse_html: use HTML parser, else use XML parser (default)
-
a_tagsoup : use light weight and lasy parser based on tagsoup lib
-
a_parse_by_mimetype : select the parser by the mime type of the document
- (pulled out of the HTTP header). When the mime type is set to "text/html"
- the HTML parser (parsec or tagsoup) is taken, when it's set to
- "text/xml" or "text/xhtml" the XML parser (parsec or tagsoup) is taken.
- If the mime type is something else no further processing is performed,
- the contents is given back to the application in form of a single text node.
- If the default document encoding (a_encoding) is set to isoLatin1, this even enables processing
- of arbitray binary data.
-
a_relax_schema : validate document with Relax NG, the options value is the schema URI
- this implies using XML parser, no validation against DTD, and canonicalisation
-
All attributes not evaluated by readDocument are stored in the created document root node for easy access of the various
-options in e.g. the input/output modules
-
If the document name is the empty string or an uri of the form "stdin:", the document is read from standard input.
-
examples:
-
readDocument [ ] "test.xml"
-
reads and validates a document "test.xml", no namespace propagation, only canonicalization is performed
-
reads a HTML document from standard input, no validation is done when parsing HTML, default encoding is isoLatin1,
-parsing is done with tagsoup parser
-
a_output_xml : (default) issue XML: quote special XML chars >,<,",',& where neccessary
- add XML processing instruction
- and encode document with respect to a_output_encoding,
- if explicitly switched of, the plain text is issued, this is useful
- for non XML output, e.g. generated Haskell code, LaTex, Java, ...
-
a_output_html : issue XHTML: quote alle XML chars, use HTML entity refs or char refs for none ASCII chars
-
Most of the XPath arrows come in two versions,
- one without dealing with namespaces, element and attribute names
- in XPath expressions are taken as they ar ignoring any prefix:localname structure.
-
The second variant uses a namespace environment for associating the right
- namespace for the appropriate prefix. an entry for the empty prefix
- defines the default namespace for the expression.
-
The second variant should be used, when in the application namespaces
- are significant, that means when namespace propagation is done for
- the documents to be processed.
-
NodeSets are sets of "pointer" into an XML tree to reference
- subnodes. These nodesets can be computed by XPath expressions or
- normal arrows. The nodesets can then be used later for selecting
- or modifying subtrees of this tree in an efficient way.
-
Select parts of a whole XML document with root node by a XPath expression.
-
The main filter for selecting parts of a document via XPath.
-
The string argument must be a XPath expression with an absolute location path,
- the argument tree must be a complete document tree.
-
Before evaluating the xpath query, the document is canonicalized
- with canonicalizeForXPath
-
Result is a possibly empty list of XmlTrees forming the set of selected XPath values.
- XPath values other than XmlTrees (numbers, attributes, tagnames, ...)
- are convertet to text nodes.
-
Select parts of an arbitrary XML tree by a XPath expression.
-
The main filter for selecting parts of an arbitrary XML tree via XPath.
- The string argument must be a XPath expression with an absolute location path,
- There are no restrictions on the argument tree.
-
No canonicalization is performed before evaluating the query
-
Result is a possibly empty list of XmlTrees forming the set of selected XPath values.
- XPath values other than XmlTrees (numbers, attributes, tagnames, ...)
- are convertet to text nodes.
-
Select a set of nodes via an XPath expression from an arbitray XML tree
-
The result is a set of "pointers" to nodes. This set can be used to
- access or modify the values of the subnodes in subsequent calls to getFromNodeSet or processFromNodeSet.
-
This function enables for parsing an XPath expressions and traversing the tree for node selection once
- and reuse this result possibly many times for later selection and modification operations.
-
process all subtrees specified by a previously computed node set in bottom up manner
-
the follwoing law holds:
-
processFromNodeSet g $< getElemNodeSet f == processBottomUp (g `when` f)
-
when attributes are contained in the node set (see getElemAndAttrNodeSet), these are processed
- after the children and before the node itself
-
the advantage of processFromNodeSet is the separation of the selection of set of nodes to be processed (e.g. modified)
- from the real proccessing. The selection sometimes can be done once, the processing possibly many times.
-
XPath selection for simple XPath expressions with list arrows
- instead of navigatable trees.
-
It is recomended, that this module is imported qualified,
- e.g like Text.XML.HXT.Arrow.XPathSimple as XS.
-
The arrows defined in this module have the same
- functionality as the functions in XPath.
-
The computation modell in XPath is a navigatable tree,
- that means a tree wicht can be traveresed in arbitrary directions,
- not only from the root to the leafs. Sometimes this modell
- leads to inefficent XPath processing for simple queries, which
- only need a top down tree traversal.
-
When evaluating an XPath expression with these functions, first an attempt is made
- to map the XPath expression to a pure arrow. If this is possible
- due to the siplicity of the XPath expressions, the result is computed
- directly, else the query is processed by the corresponding
- function in XPath.
-
The simple evaluation is possible, when in the XPath expression
- only the top down axis (self, child, descendant, descendant or self are used,
- when no builtin functions concerning the position of a node are used,
- and no comparison of nodes e.g. in node set union is required.
-
convenient op for adding attributes or children to a node
-
usage: tf += cf
-
the tf arrow computes an element node, and all trees computed by cf are
- added to this node, if a tree is an attribute, it is inserted in the attribute list
- else it is appended to the content list.
-
attention: do not build long content list this way because += is implemented by ++
-
and results in the XML fragment: <a href="page.html" name="here">look here</a>
-
advantage of the += operator is, that attributes and content can be added
- any time step by step.
- if tf computes a whole list of trees, e.g. a list of "td" or "tr" elements,
- the attributes or content is added to all trees. useful for adding "class" or "style" attributes
- to table elements.
-
These are separated, because they are not needed for document processing,
-only when processing the DTD, e.g. for generating access funtions for the toolbox
-from a DTD (se example DTDtoHaskell in the examples directory)
-
A state is needed for global processing options,
-like encoding options, document base URI, trace levels
-and error message handling
-
The state is separated into a user defined state
-and a system state. The system state contains variables
-for error message handling, for tracing, for the document base
-for accessing XML documents with relative references, e.g. DTDs,
-and a global key value store. This assoc list has strings as keys
-and lists of XmlTrees as values. It is used to store arbitrary
-XML and text values, e.g. user defined global options.
-
The user defined part of the store is in the default case empty, defined as ().
-It can be extended with an arbitray data type
-
the main entry point for running a state arrow with IO
-
when running runX f an empty XML root node is applied to f.
- usually f will start with a constant arrow (ignoring the input), e.g. a readDocument arrow.
-
Run an arrow with an extended user state component, The old component
- is stored together with a new one in a pair, the arrow is executed with this
- extended state, and the augmented state component is removed form the state
- when the arrow has finished its execution
-
if error messages are collected by the error handler for
- processing these messages by the calling application,
- this arrow reads the stored messages and clears the error message store
-
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.
- called by setDocumentStatusFromSystemState when the system state indicates an error
-
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 the module name where the error occured and the error level are added as attributes with setDocumentStatus
- else nothing is changed
-
change the base URI with a possibly relative URI, can be used for
- evaluating the xml:base attribute. Returns the new absolute base URI.
- Fails, if input is not parsable with parseURIReference
-
setDefaultBaseURI :: String -> IOStateArrow s b String
set the default base URI, if parameter is null, the system base ( file:///<cwd>/ ) is used,
- else the parameter, must be called before any document is read
-
The application programming interface to the arrow modules of the Haskell XML Toolbox.
- This module exports all important arrows for input, output, parsing, validating and transforming XML.
- It also exports all basic datatypes and functions of the toolbox.
-
Compute the name prefix and the namespace uri for a qualified name.
-
This function does not test whether the name is a wellformed qualified name.
- see Namespaces in XML Rule [6] to [8]. Error checking is done with separate functions,
- see isWellformedQName and isWellformedQualifiedName for error checking.
-
xmlnsQN :: QName
isNCName :: String -> Bool
test for wellformed NCName, rule [4] XML Namespaces
-
isWellformedQualifiedName :: String -> Bool
test for wellformed QName, rule [6] XML Namespaces
- predicate is used in filter valdateNamespaces.
-
isWellformedQName :: QName -> Bool
test for wellformed QName values.
- A QName is wellformed, if the local part is a NCName, the namePrefix, if not empty, is also a NCName.
- predicate is used in filter valdateNamespaces.
-
isWellformedNSDecl :: QName -> Bool
test for a wellformed namespace declaration
- all namespace prefixes starting with "xml" are reserved for XML related definitions.
- predicate is used in filter valdateNamespaces.
-
Namespace support for element and attribute names.
-
A qualified name consists of a name prefix, a local name
- and a namespace uri.
- All modules, which are not namespace aware, use only the localPart component.
- When dealing with namespaces, the document tree must be processed by propagateNamespaces
- to split names of structure "prefix:localPart" and label the name with the apropriate namespace uri
-
Constructors
QN
namePrefix :: String
the name prefix part of a qualified name "namePrefix:localPart"
-
localPart :: String
the local part of a qualified name "namePrefix:localPart"
-
builds the "universal" name, that is the namespace uri surrounded with "{" and "}" followed by the local part
- (specialisation of buildUniversalName)
-
builds an "universal" uri, that is the namespace uri followed by the local part. This is usefull for RDF applications,
- where the subject, predicate and object often are concatenated from namespace uri and local part
- (specialisation of buildUniversalName)
-
builds a string from the namespace uri and the local part. If the namespace uri is empty, the local part is returned, else
- namespace uri and local part are combined with the combining function given by the first parameter
-
Equality of QNames: Two QNames are equal, if the local parts are equal
- and the namespace URIs are equal.
- The comparison works with and without namespace propagation.
- If namespaces have been propagated, the name is split into prefix and local part
- and the namespace uri is set. In this case the prefix is not significant for equality test.
- If namespaces have not been propagated, the local part contains the full name, prefix
- and namespace URI are empty. The full name (prefix and local part) is used for comparison.
-
Sometimes a weaker equality relation than equalQName is appropriate, e.g no case significance in names, ...
- a name normalization function can be applied to the strings before comparing. Called by equalQName and
- equivQName
-
normalizeNsUri :: String -> String
Normalization of URIs: Normalization is done by conversion into lowercase letters. A trailing "/" is ignored
-
Processing Instr with qualified name (leaf)
- with list of attributes.
- If tag name is xml, attributs are "version", "encoding", "standalone",
- else attribute list is empty, content is a text child node
-
Type for the namespace association list, used when propagating namespaces by
- modifying the QName values in a tree
-
c_ok :: Int
no error, everything is ok
-
c_warn :: Int
Error level for XError, type warning
-
c_err :: Int
Error level for XError, type error
-
c_fatal :: Int
Error level for XError, type fatal error
-
dataXmlNodeSet
data type for representing a set of nodes as a tree structure
-
this structure is e.g. used to repesent the result of an XPath query
- such that the selected nodes can be processed or selected later in
- processing a document tree
-
checking for XML control or permanently discouraged char
-
see Errata to XML1.0 (http://www.w3.org/XML/xml-V10-2e-errata) No 46
-
Document authors are encouraged to avoid compatibility characters,
- as defined in section 6.8 of [Unicode] (see also D21 in section 3.6 of [Unicode3]).
- The characters defined in the following ranges are also discouraged.
- They are either control characters or permanently undefined Unicode characters:
-
removes all non ascii chars, may be used to transform
- a document into a pure ascii representation by removing
- all non ascii chars from tag and attibute names
-
removes all non latin1 chars, may be used to transform
- a document into a pure ascii representation by removing
- all non ascii chars from tag and attibute names
-
The main entry point to the MySQL datatype library.
-
The DTC constructor exports the list of supported datatypes and params.
- It also exports the specialized functions to validate a XML instance value with
- respect to a datatype.
-
This modul exports the list of supported datatype libraries.
- It also exports the main functions to validate an XML instance value
- with respect to a datatype.
-
List of all supported datatypes and there allowed params
-
dataDatatypeCheck
The Constructor exports the list of supported datatypes for a library.
- It also exports the specialized datatype library functions to validate
- a XML instance value with respect to a datatype.
-
If error levels are different, the more important is taken,
- if level is 2 (max level) both error messages are taken
- else the 1. error mesage is taken
-
Validation of a XML document with respect to a valid Relax NG schema in simple form.
- Copied and modified from "An algorithm for RELAX NG validation" by James Clark
- (http://www.thaiopensource.com/relaxng/derivative.html).
-
normalize a document for validation with Relax NG: remove all namespace declaration attributes,
- remove all processing instructions and merge all sequences of text nodes into a single text node
-
This module exports the core functions from the basic validation und simplification libraries.
- It also exports some helper functions for easier access to the validation functionality.
-
normalize a document for Relax NG validation,
- call the validateRelax function for doing the hard work,
- and issue errors
-
1.parameter : the arrow for computing the schema
-
arrow-input : the document to be validated
-
arrow-output : nothing
-
Document validation
-
Validates a xml document with respect to a Relax NG schema.
-
First, the schema is validated with respect to the Relax NG Spezification. If no error is found, the xml document is validated with respect to the schema.
-
1.parameter : list of options; namespace progagation is always done
-
2.parameter : XML document
-
3.parameter : Relax NG schema file
-
available options:
-
a_do_not_check_restrictions : do not check Relax NG schema restrictions (includes do-not-validate-externalRef, do-not-validate-include)
-
Validates a xml document with respect to a Relax NG schema. Similar to validate, but the Relax NG Specification is not created. Can be used, to check a list of documents more efficiently.
-
1.parameter : list of available options (see also: validate)
-
2.parameter : XML document
-
3.parameter : Relax NG schema file
-
arrow-input : Relax NG Specification in simple form
-
Validates a xml document with respect to a Relax NG schema, but the schema is not validated with respect to a specification first. Should be used only for valid Relax NG schemes.
-
1.parameter : list of available options (see also: validate)
-
The main entry point to the W3C XML schema datatype library.
-
The DTC constructor exports the list of supported datatypes and params.
- It also exports the specialized functions to validate a XML instance value with
- respect to a datatype.
-
The application programming interface to the arrow modules of the Haskell XML Toolbox.
- This module exports all important arrows for input, output, parsing, validating and transforming XML.
- It also exports all basic datatypes and functions of the toolbox.
-
Compile a document representing an XSLT stylesheet into an internal representation
-
The internal representation is an abstract syntax tree for the XSLT rules.
- XSLT imports and includes are evaluated and the rules are normalized and prepared
- for easy application.
-
apply an XSLT stylesheet given by an URI to a whole document tree
-
The string parameter is the URI of the XSLT stylesheet.
- In case of an error during stylesheet compilation or stylesheet application
- all children of the root node are removed and
- the error status is set in the attribute list of the root node of the input document.
-
stolen from comp.lang.functional from Dean Herington
-
DeepSeq.lhs -- deep strict evaluation support
-
The DeepSeq class provides a method deepSeq that is similar to
-seq except that it forces deep evaluation of its first argument
-before returning its second argument.
-
Instances of DeepSeq are provided for Prelude types. Other
-instances must be supplied by users of this module.
-
Navigable tree structure which allow a program to traverse
- up the tree as well as down.
- copied and modified from HXML (http://www.flightlab.com/~joe/hxml/)
-
a navigable tree consists of a n-ary tree for the current fragment tree,
- a navigable tree for all ancestors, and two n-ary trees for
- the previous- and following siblings
-
all children are processed with a filter mapping lists to lists,
- this enables not only elementwise editing by lifting a normal
- filter to a list filter with (f $$) (see '($$)') but also manipulation
- of the order of the elements, e.g. reverse is an appropriate childen
- editing function.
-
filter for substituting the children of a tree by
- a new list of childen computed by applying a filter to the input tree.
- modifyChildren can be expressed by substChildren:
- modifyChildren f t is equal to substChildren (f . getChildren)
-
apply a list of filters sequentially with '(.>)', for predicate filters the generalized AND
-
see also : '(.>)'
-
(..>) :: (a -> [b]) -> (a -> b -> [d]) -> a -> [d]
special sequential composition.
-
filter f is applied to an argument t.
- then filter g is applied to all elements of the result list,
- but the argument t is also passed as extra parameter to g.
-
This allows for step by step transformations of a tree
- with access to the original tree in every
- transformation step.
-
binary parallel composition, the logical OR for predicate filter
-
1.parameter f1 : the 1. filter
-
2.parameter f2 : the 2. filter
-
returns : the filter for applying f1 and f2 both to an argument tree and concatenating the results
-
cat :: [a -> [b]] -> a -> [b]
apply a list of filters, a "union" for lists, for predicate filters the generalized OR
-
1.parameter fs : the list of filters
-
returns : the composing filter
-
orElse :: (a -> [b]) -> (a -> [b]) -> a -> [b]
directional choice, usually written in infix notation as f orElse g
-
1.parameter f : the 1. filter
-
2.parameter g : the 2. filter
-
3.parameter t : the tree
-
returns : the filter, that applies f to t, if the result is not the empty list, the result is found, else g t is the result
-
iff :: (a -> [c]) -> (a -> [b]) -> (a -> [b]) -> a -> [b]
if then else lifted to filters
-
1.parameter p : the predicate filter
-
2.parameter t : the "then" filter
-
3.parameter e : the "else" filter
-
returns : the resulting conditional filter
-
choice :: [IfThen (a -> [c]) (a -> [b])] -> a -> [b]
multiway branch. The list of cases f :-> g is processed sequentially,
- in the first case for that f holds g is applied, if no case matches, none is
- applied.
- This filter can be used like a case expression: choice [ p1 :-> f1, p2 :-> f2, ... , this :-> defaultFilter]
-
first the children are processed,
- if this does not succeed, the node itself is processed
- can e.g. be used for finding all innermost tag nodes of a specific kind
-
insertion of trees into the list of children at a given position
-
useful for inserting something into the list of children at a given position
- the list of children is split with the splitAt function
- the nodes are inserted between these two sublists.
-
examples: insertChildrenAt 0 ins t inserts all elements computed with ins t in front
- of the childen of t, insertChildrenAt 1 ins t behind the first child
-
insertion of trees into the list of children after specific elements
-
useful for inserting something into the list of children of a node
- the list of children is split with the span function and the filter p as predicate
- the nodes are inserted between these two sublists
-
examples: insertChildrenAfter none ins t inserts all elements computed with ins t in front
- of the childen of t, insertChildrenAfter this ins t appends the elements to the children
-
(.>>) :: Monad m => (a -> m [b]) -> (b -> m [c]) -> a -> m [c]
sequential composition of monadic filters, monadic version of ".>".
-
1.parameter f1 : the 1. monadic filter
-
2.parameter f2 : the 2. monadic filter
-
returns : the monadic fiter applying first f1 to n and then f2 to the result (like function composition)
-
see also : '(.>)'
-
seqM :: Monad m => [a -> m [a]] -> a -> m [a]
generalized sequential composition of monadic filters
-
(+++>>) :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]
binary parallel composition, the logical OR for predicate filter
-
1.parameter f1 : the 1. filter
-
2.parameter f2 : the 2. filter
-
returns : the filter for applying f1 and f2 both to an argument tree and concatenating the results
- see also: cat, +++, catM
-
catM :: Monad m => [a -> m [b]] -> a -> m [b]
apply a list of monadic filters
-
1.parameter fs : the list of filters
-
returns : the composing filter
- see also: cat, +++, +++>>
-
ifM :: Monad m => (a -> [b]) -> (a -> m [c]) -> (a -> m [c]) -> a -> m [c]
monadic if-then-else.
-
1.parameter p : the predicate
-
2.parameter thenP : the then part: the monadic filter, that is applied if p holds for the input tree
-
3.parameter elseP : the else part
-
returns : the monadic filter for the conditional
-
choiceM :: Monad m => [IfThen (a -> [c]) (a -> m [b])] -> a -> m [b]
monadic version of multiway branch. The list of cases f :-> g is processed sequentially,
- in the first case for that f holds g is applied, if no case matches, noneM is
- applied.
- This filter can be used like a case expression: choiceM [ p1 :-> f1, p2 :-> f2, ... , thisM :-> defaultFilter]
-
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.
-
Compute the name prefix and the namespace uri for a qualified name.
-
This function does not test whether the name is a wellformed qualified name.
- see Namespaces in XML Rule [6] to [8]. Error checking is done with separate functions,
- see isWellformedQName and isWellformedQualifiedName for error checking.
-
test for wellformed QName values.
- A QName is wellformed, if the local part is a NCName, the namePrefix, if not empty, is also a NCName.
- predicate is used in filter valdateNamespaces.
-
test for a wellformed namespace declaration
- all namespace prefixes starting with "xml" are reserved for XML related definitions.
- predicate is used in filter valdateNamespaces.
-
Namespace support for element and attribute names.
-
A qualified name consists of a name prefix, a local name
- and a namespace uri.
- All modules, which are not namespace aware, use only the localPart component.
- When dealing with namespaces, the document tree must be processed by propagateNamespaces
- to split names of structure "prefix:localPart" and label the name with the apropriate namespace uri
-
Constructors
QN
namePrefix :: String
the name prefix part of a qualified name "namePrefix:localPart"
-
localPart :: String
the local part of a qualified name "namePrefix:localPart"
-
builds the "universal" name, that is the namespace uri surrounded with "{" and "}" followed by the local part
- (specialisation of buildUniversalName)
-
builds an "universal" uri, that is the namespace uri followed by the local part. This is usefull for RDF applications,
- where the subject, predicate and object often are concatenated from namespace uri and local part
- (specialisation of buildUniversalName)
-
builds a string from the namespace uri and the local part. If the namespace uri is empty, the local part is returned, else
- namespace uri and local part are combined with the combining function given by the first parameter
-
Equality of QNames: Two QNames are equal, if the local parts are equal
- and the namespace URIs are equal.
- The comparison works with and without namespace propagation.
- If namespaces have been propagated, the name is split into prefix and local part
- and the namespace uri is set. In this case the prefix is not significant for equality test.
- If namespaces have not been propagated, the local part contains the full name, prefix
- and namespace URI are empty. The full name (prefix and local part) is used for comparison.
-
Sometimes a weaker equality relation than equalQName is appropriate, e.g no case significance in names, ...
- a name normalization function can be applied to the strings before comparing. Called by equalQName and
- equivQName
-
normalizeNsUri :: String -> String
Normalization of URIs: Normalization is done by conversion into lowercase letters. A trailing "/" is ignored
-
Processing Instr with qualified name (leaf)
- with list of attributes.
- If tag name is xml, attributs are "version", "encoding", "standalone",
- else attribute list is empty, content is a text child node
-
Type for the namespace association list, used when propagating namespaces by
- modifying the QName values in a tree
-
c_ok :: Int
no error, everything is ok
-
c_warn :: Int
Error level for XError, type warning
-
c_err :: Int
Error level for XError, type error
-
c_fatal :: Int
Error level for XError, type fatal error
-
dataXmlNodeSet
data type for representing a set of nodes as a tree structure
-
this structure is e.g. used to repesent the result of an XPath query
- such that the selected nodes can be processed or selected later in
- processing a document tree
-
checking for XML control or permanently discouraged char
-
see Errata to XML1.0 (http://www.w3.org/XML/xml-V10-2e-errata) No 46
-
Document authors are encouraged to avoid compatibility characters,
- as defined in section 6.8 of [Unicode] (see also D21 in section 3.6 of [Unicode3]).
- The characters defined in the following ranges are also discouraged.
- They are either control characters or permanently undefined Unicode characters:
-
removes all non ascii chars, may be used to transform
- a document into a pure ascii representation by removing
- all non ascii chars from tag and attibute names
-
removes all non latin1 chars, may be used to transform
- a document into a pure ascii representation by removing
- all non ascii chars from tag and attibute names
-
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".
-
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
like chain' but forget the final user state
-
1.parameter initialUserState : the initial user state
-
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.
-
All filter are pure XmlFilter,
- errror handling and IO is done in HtmlParser
- or other modules
-
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)
-
end of line handling (2.11)
- #x0D and #x0D#x0A are mapped to #x0A
- is done in XmlInput before parsing
- otherwise #x0D in internal parsing, e.g. for entities would normalize,
- would be transformed
-
parse a tokenized DTD declaration represented by a DTD tree.
- The content is represented by the children containing text and parameter entity reference nodes.
- The parameter entity reference nodes contain their value in the children list, consisting of text
- and possibly again parameter entity reference nodes. This structure is build by the parameter entity
- substitution.
- Output is again a DTD declaration node, but this time completely parsed and ready for further DTD processing
-
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 inverse function to xshow, (for XML content).
-
the string parameter is parsed with the XML content parser.
- result is the list of trees or in case of an error a single element list with the
- error message as node. No entity or character subtitution is done.
-
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
-
Navigable tree structure which allow a program to traverse
- for XPath expressions
- copied and modified from HXML (http://www.flightlab.com/~joe/hxml/)
-
Select parts of a document by an XPath expression.
-
The main filter for selecting parts of a document via XPath.
- The string argument must be a XPath expression with an absolute location path,
- the argument tree must be a complete document tree.
- Result is a possibly empty list of XmlTrees forming the set of selected XPath values.
- XPath values other than XmlTrees (numbers, attributes, tagnames, ...)
- are convertet to text nodes.
-
Select parts of an XML tree by a XPath expression.
-
The main filter for selecting parts of an arbitrary XML tree via XPath.
- The string argument must be a XPath expression with an absolute location path,
- There are no restrictions on the arument tree.
-
No canonicalization is performed before evaluating the query
-
Result is a possibly empty list of XmlTrees forming the set of selected XPath values.
- XPath values other than XmlTrees (numbers, attributes, tagnames, ...)
- are convertet to text nodes.
-
The main evaluation entry point.
- Each XPath-Expr is mapped to an evaluation function. The Env-parameter contains the set of global variables
- for the evaluator, the Context-parameter the root of the tree in which the expression is evaluated.
-
The module contains the core-functions of the XPath function library.
- All functions are implemented as XFct. Each XFct contains the evaluation context,
- the variable environment and the function arguments.
-
Evaluates a function.
- Calculation of the function value is done by looking up the function name in the function table,
- check the number of arguments and calculate the funtion, if no
- argument evaluation returns an error.
-
Format a XPath-value in string representation.
- Text output is done by formatXmlTree for node-sets (trees),
- all other values are represented as strings.
-
@@ -31,17 +32,26 @@
The Haskell XML Toolbox is a collection of tools for
processing XML with
Haskell.
- It is itself purely written in Haskell.
+ It is purely written in Haskell.
The Haskell XML Toolbox is a project of the
University of Applied Sciences Wedel,
- initiated by
- Uwe Schmidt.
-
+
-
@@ -50,21 +60,25 @@
The Haskell XML Toolbox bases on the ideas of
HaXml and
HXML,
- but introduces a more general approach for processing XML with
+ but introduces a more general and flexible approach for processing XML with
Haskell.
The Haskell XML Toolbox uses a generic data model for
representing XML documents,
including the DTD subset and the document subset, in Haskell.
This data model makes it possible to use filter functions
as a uniform design of XML processing applications.
- The whole XML parser including the validator parts
- was implemented using this design.
- Libraries with filters and combinators are provided for processing the generic data model.
+ The processing filters are implemented as
+ arrows.
+ This is more flexible than the filter approach from HXML and
+ HaXml,
+ but all filter applications can easily be transformed into
+ arrows.
- An new more flexible and typesaver API based on arrows instead
- of filters is included since version 5.2.
+ Since version 5.2 HXT works with arrows instead of filters.
+ The filter part has been separated from this library and is
+ available in an extra package (see HXT with Filters)
There is a cookbook for using this arrow interface
to build (nontrivial) applications. Manuel Ohlendorf
has developed examples for processing RDF and has documented the
@@ -96,8 +110,16 @@
This version works with ghc 6.8 and ghc 6.6 with cabal
1.2. For ghc 6.6 and cabal < 1.2 please use HXT 7.3.
+
This version does not contain the filter part of hxt any
+ more.
+ That functionality is separated into a package hxt-filter.
+
Includes sources for building a ghc package
hxt with Cabal or make.
This package contains a Haskell DOM, an XML parser, a HTML parser based on parsec,
@@ -187,26 +210,18 @@
or with an external program curl
The HTTP module must be installed before installing the
toolbox.
- In the past the installation procedure for HTTP was a bit clumsy because of further
- dependencies on The Haskell Cryptographic Library
- and NewBinary package. The latest HTTP module
- from 2006-07-07 has removed these dependencies and consists only of one HTTP module (not HTTP and Browser).
- So there has only one package HTTP to be installed before installing HXT.
Includes various examples, e.g. in example dir
examples/arrows/hparser/
a validating parser, which can be used as a starting point for
a HXT command line application.
-
Provides a HUnit test HUnitTest for testing
- and demonstration of the available set of filters.
-
Includes an arrow interface with type classes and
overloading for a more flexible use of the filter technique.
Before installing this version, install the Haskell HTTP module.
For a quick install with Cabal execute the following commands in
- .../HXT-7.5
+ .../HXT-8.0.0
+ Old filter interface separated from the hxt package and moved
+ to an extra package hxt-filter.
+
+
+ Version numbers added in hxt.cabal for required package versions.
+
+
+ DTD validation and XPath modules refactored to work with arrows instead of
+ filters.
+ This is done for separating the old hxt filter library
+ from the actively developed and maintained arrow part.
+
+ For older applications using the filter functionality,
+ there is an extra package hxt-filter.
+ This package must be installed on top of hxt.
+ The filter package will not be actively developed any more.
+ Please move to the arrow version for long term projects.
+ Installation works with cabal in the usual way.
+ Download archive is hxt-filter-8.0.0.tar.gz,
+ HXT Filter API Documentation
+ with source links is availabe as well as a
+ darcs repository under http://darcs.fh-wedel.de/hxt-filter.
+
+
Related work
@@ -471,8 +518,8 @@
-
Last modified: 2008-03-01
-
+
Last modified: 2008-04-24
+
diff --git a/examples/Makefile b/examples/Makefile
--- a/examples/Makefile
+++ b/examples/Makefile
@@ -3,13 +3,13 @@
# Example Applications
#
+include ../Version.mk
+
HXT_HOME = ..
-VERSION = 7.5
-LASTVERSION = 7.4
-EXAMPLES = mini hparser hxpath hfilter hunit hsvg dtd2haskell arrows
-MORE_SAMPLES = w3ctest blutgraetsche photoalbum
-DIST = $(HXT_HOME)/dist
+EXAMPLES = arrows
+MORE_SAMPLES =
+DIST = ../$(DIST_NAME)
DIST_DIR = $(DIST)/examples
all :
@@ -19,7 +19,7 @@
fi
alllocal :
- $(foreach i,$(EXAMPLES),$(MAKE) -C $i PKGFLAGS="-ignore-package hxt-$(LASTVERSION) -package-conf `pwd`/$(HXT_HOME)/lib/hxt/package.conf -package hxt" all ;)
+ $(foreach i,$(EXAMPLES),$(MAKE) -C $i PKGFLAGS="-package-conf `pwd`/$(HXT_HOME)/lib/hxt/package.conf -package hxt-$(VERSION)" all ;)
alldist :
$(foreach i,$(EXAMPLES),$(MAKE) -C $i all ;)
@@ -28,7 +28,7 @@
dist :
[ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR)
- for i in $(EXAMPLES) ; do $(MAKE) -C $$i dist DIST=../$(DIST_DIR) ; done
+ $(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)
@@ -36,13 +36,10 @@
clean :
$(foreach i,$(EXAMPLES),$(MAKE) -C $i $@ ;)
-RunTestCases :
- $(MAKE) -C w3ctest $@
-
# under construction
hxslt/runXslt : hxslt/runXslt.hs
$(GHC) --make -o $@ $<
-.PHONY : all clean test dist RunTestCases
+.PHONY : all alllocal alldist test dist clean
diff --git a/examples/arrows/AGentleIntroductionToHXT/AGentleIntroductionToHXT/PicklerExample/Baseball. b/examples/arrows/AGentleIntroductionToHXT/AGentleIntroductionToHXT/PicklerExample/Baseball.
new file mode 100644
--- /dev/null
+++ b/examples/arrows/AGentleIntroductionToHXT/AGentleIntroductionToHXT/PicklerExample/Baseball.
@@ -0,0 +1,313 @@
+{- |
+ Example for usage of pickler functions
+ to de-/serialise from/to XML
+
+ Example data is taken from haskell wiki
+ http://www.haskell.org/haskellwiki/HXT/Practical/Simple2
+-}
+
+module Main
+where
+
+import Data.Map (Map, fromList, toList)
+import qualified Data.Map as M
+
+import Text.XML.HXT.Arrow
+
+-- Example data drawn from:
+-- http://www.ibiblio.org/xml/books/bible/examples/05/5-1.xml
+
+-- ------------------------------------------------------------
+-- the data modell
+
+data Season = Season
+ { sYear :: Int
+ , sLeagues :: Leagues
+ }
+ deriving (Show, Eq)
+
+type Leagues = Map String Divisions
+
+type Divisions = Map String [Team]
+
+data Team = Team
+ { teamName :: String
+ , city :: String
+ , players :: [Player]
+ }
+ deriving (Show, Eq)
+
+data Player = Player
+ { firstName :: String
+ , lastName :: String
+ , position :: String
+ , atBats :: Maybe Int
+ , hits :: Maybe Int
+ , era :: Maybe Float
+ }
+ deriving (Show, Eq)
+
+-- ------------------------------------------------------------
+-- the pickler instance declarations
+-- in this case just for uniform naming
+
+instance XmlPickler Season where
+ xpickle = xpSeason
+
+instance XmlPickler Team where
+ xpickle = xpTeam
+
+instance XmlPickler Player where
+ xpickle = xpPlayer
+
+-- ------------------------------------------------------------
+-- for every data type there is a pickler
+
+-- the XML root element
+
+xpSeason :: PU Season
+xpSeason
+ = xpElem "SEASON" $
+ xpWrap ( uncurry Season
+ , \ s -> (sYear s, sLeagues s)) $
+ xpPair (xpAttr "YEAR" xpickle) xpLeagues
+
+xpLeagues :: PU Leagues
+xpLeagues
+ = xpWrap ( fromList
+ , toList ) $
+ xpList $
+ xpElem "LEAGUE" $
+ xpPair (xpAttr "NAME" xpText) xpDivisions
+
+xpDivisions :: PU Divisions
+xpDivisions
+ = xpWrap ( fromList
+ , toList
+ ) $
+ xpList $
+ xpElem "DIVISION" $
+ xpPair (xpAttr "NAME" xpText) xpickle
+
+xpTeam :: PU Team
+xpTeam
+ = xpElem "TEAM" $
+ xpWrap ( uncurry3 Team
+ , \ t -> (teamName t, city t, players t)) $
+ xpTriple (xpAttr "NAME" xpText) (xpAttr "CITY" xpText) (xpList xpickle)
+
+xpPlayer :: PU Player
+xpPlayer
+ = xpElem "PLAYER" $
+ xpWrap ( \ ((f,l,p),(a,h,e)) -> Player f l p a h e
+ , \ t -> ((firstName t, lastName t, position t),(atBats t, hits t, era t))) $
+ xpPair (xpTriple (xpAttr "GIVEN_NAME" xpText)
+ (xpAttr "SURNAME" xpText)
+ (xpAttr "POSITION" xpText))
+ (xpTriple (xpOption (xpAttr "AT_BATS" xpickle))
+ (xpOption (xpAttr "HITS" xpickle))
+ (xpOption (xpAttr "ERA" xpPrim )))
+
+
+-- ------------------------------------------------------------
+
+-- a simple pickle/unpickle application
+
+main :: IO ()
+main
+ = do
+ runX ( xunpickleDocument xpSeason [ (a_validate,v_0)
+ , (a_trace, v_1)
+ , (a_remove_whitespace,v_1)
+ , (a_preserve_comment, v_0)
+ ] "simple2.xml"
+ >>>
+ processSeason
+ >>>
+ xpickleDocument xpSeason [ (a_indent, v_1)
+ ] "new-simple2.xml"
+ )
+ return ()
+
+-- the dummy for processing the unpickled data
+
+processSeason :: IOSArrow Season Season
+processSeason
+ = arrIO ( \ x -> do {print x ; return x})
+
+-- ------------------------------------------------------------
+
+-- the internal data of "simple2.xml"
+
+season1998 :: Season
+season1998
+ = Season
+ { sYear = 1998
+ , sLeagues = fromList
+ [ ( "American League"
+ , fromList
+ [ ( "Central"
+ , [ Team { teamName = "White Sox"
+ , city = "Chicago"
+ , players = []}
+ , Team { teamName = "Royals"
+ , city = "Kansas City"
+ , players = []}
+ , Team { teamName = "Tigers"
+ , city = "Detroit"
+ , players = []}
+ , Team { teamName = "Indians"
+ , city = "Cleveland"
+ , players = []}
+ , Team { teamName = "Twins"
+ , city = "Minnesota"
+ , players = []}
+ ])
+ , ( "East"
+ , [ Team { teamName = "Orioles"
+ , city = "Baltimore"
+ , players = []}
+ , Team { teamName = "Red Sox"
+ , city = "Boston"
+ , players = []}
+ , Team { teamName = "Yankees"
+ , city = "New York"
+ , players = []}
+ , Team { teamName = "Devil Rays"
+ , city = "Tampa Bay"
+ , players = []}
+ , Team { teamName = "Blue Jays"
+ , city = "Toronto"
+ , players = []}
+ ])
+ , ( "West"
+ , [ Team { teamName = "Angels"
+ , city = "Anaheim"
+ , players = []}
+ , Team { teamName = "Athletics"
+ , city = "Oakland"
+ , players = []}
+ , Team { teamName = "Mariners"
+ , city = "Seattle"
+ , players = []}
+ , Team { teamName = "Rangers"
+ , city = "Texas"
+ , players = []}
+ ])
+ ])
+ , ( "National League"
+ , fromList
+ [ ( "Central"
+ , [ Team { teamName = "Cubs"
+ , city = "Chicago"
+ , players = []}
+ , Team { teamName = "Reds"
+ , city = "Cincinnati"
+ , players = []}
+ , Team { teamName = "Astros"
+ , city = "Houston"
+ , players = []}
+ , Team { teamName = "Brewers"
+ , city = "Milwaukee"
+ , players = []}
+ , Team { teamName = "Pirates"
+ , city = "Pittsburgh"
+ , players = []}
+ , Team { teamName = "Cardinals"
+ , city = "St. Louis"
+ , players = []}
+ ])
+ , ( "East"
+ , [ Team { teamName = "Braves"
+ , city = "Atlanta"
+ , players =
+ [ Player { firstName = "Marty"
+ , lastName = "Malloy"
+ , position = "Second Base"
+ , atBats = Just 28
+ , hits = Just 5
+ , era = Nothing}
+ , Player { firstName = "Ozzie"
+ , lastName = "Guillen"
+ , position = "Shortstop"
+ , atBats = Just 264
+ , hits = Just 73
+ , era = Nothing}
+ , Player { firstName = "Danny"
+ , lastName = "Bautista"
+ , position = "Outfield"
+ , atBats = Just 144
+ , hits = Just 36
+ , era = Nothing}
+ , Player { firstName = "Gerald"
+ , lastName = "Williams"
+ , position = "Outfield"
+ , atBats = Just 266
+ , hits = Just 81
+ , era = Nothing}
+ , Player { firstName = "Tom"
+ , lastName = "Glavine"
+ , position = "Starting Pitcher"
+ , atBats = Nothing
+ , hits = Nothing
+ , era = Just 2.47}
+ , Player { firstName = "Javier"
+ , lastName = "Lopez"
+ , position = "Catcher"
+ , atBats = Just 489
+ , hits = Just 139
+ , era = Nothing}
+ , Player { firstName = "Ryan"
+ , lastName = "Klesko"
+ , position = "Outfield"
+ , atBats = Just 427
+ , hits = Just 117
+ , era = Nothing}
+ , Player { firstName = "Andres"
+ , lastName = "Galarraga"
+ , position = "First Base"
+ , atBats = Just 555
+ , hits = Just 169
+ , era = Nothing}
+ , Player { firstName = "Wes"
+ , lastName = "Helms"
+ , position = "Third Base"
+ , atBats = Just 13
+ , hits = Just 4
+ , era = Nothing}
+ ]}
+ , Team { teamName = "Marlins"
+ , city = "Florida"
+ , players = []}
+ , Team { teamName = "Expos"
+ , city = "Montreal"
+ , players = []}
+ , Team { teamName = "Mets"
+ , city = "New York"
+ , players = []}
+ , Team { teamName = "Phillies"
+ , city = "Philadelphia"
+ , players = []}
+ ])
+ , ( "West"
+ , [ Team { teamName = "Diamondbacks"
+ , city = "Arizona"
+ , players = []}
+ , Team { teamName = "Rockies"
+ , city = "Colorado"
+ , players = []}
+ , Team { teamName = "Dodgers"
+ , city = "Los Angeles"
+ , players = []}
+ , Team { teamName = "Padres"
+ , city = "San Diego"
+ , players = []}
+ , Team { teamName = "Giants"
+ , city = "San Francisco"
+ , players = []}
+ ])
+ ])
+ ]
+ }
+
+-- ------------------------------------------------------------
diff --git a/examples/arrows/AGentleIntroductionToHXT/AGentleIntroductionToHXT/PicklerExample/Football. b/examples/arrows/AGentleIntroductionToHXT/AGentleIntroductionToHXT/PicklerExample/Football.
new file mode 100644
--- /dev/null
+++ b/examples/arrows/AGentleIntroductionToHXT/AGentleIntroductionToHXT/PicklerExample/Football.
@@ -0,0 +1,313 @@
+{- |
+ Example for usage of pickler functions
+ to de-/serialise from/to XML
+
+ Example data is taken from haskell wiki
+ http://www.haskell.org/haskellwiki/HXT/Practical/Simple2
+-}
+
+module Main
+where
+
+import Data.Map (Map, fromList, toList)
+import qualified Data.Map as M
+
+import Text.XML.HXT.Arrow
+
+-- Example data drawn from:
+-- http://www.ibiblio.org/xml/books/bible/examples/05/5-1.xml
+
+-- ------------------------------------------------------------
+-- the data modell
+
+data Season = Season
+ { sYear :: Int
+ , sLeagues :: Leagues
+ }
+ deriving (Show, Eq)
+
+type Leagues = Map String Divisions
+
+type Divisions = Map String [Team]
+
+data Team = Team
+ { teamName :: String
+ , city :: String
+ , players :: [Player]
+ }
+ deriving (Show, Eq)
+
+data Player = Player
+ { firstName :: String
+ , lastName :: String
+ , position :: String
+ , atBats :: Maybe Int
+ , hits :: Maybe Int
+ , era :: Maybe Float
+ }
+ deriving (Show, Eq)
+
+-- ------------------------------------------------------------
+-- the pickler instance declarations
+-- in this case just for uniform naming
+
+instance XmlPickler Season where
+ xpickle = xpSeason
+
+instance XmlPickler Team where
+ xpickle = xpTeam
+
+instance XmlPickler Player where
+ xpickle = xpPlayer
+
+-- ------------------------------------------------------------
+-- for every data type there is a pickler
+
+-- the XML root element
+
+xpSeason :: PU Season
+xpSeason
+ = xpElem "SEASON" $
+ xpWrap ( uncurry Season
+ , \ s -> (sYear s, sLeagues s)) $
+ xpPair (xpAttr "YEAR" xpickle) xpLeagues
+
+xpLeagues :: PU Leagues
+xpLeagues
+ = xpWrap ( fromList
+ , toList ) $
+ xpList $
+ xpElem "LEAGUE" $
+ xpPair (xpAttr "NAME" xpText) xpDivisions
+
+xpDivisions :: PU Divisions
+xpDivisions
+ = xpWrap ( fromList
+ , toList
+ ) $
+ xpList $
+ xpElem "DIVISION" $
+ xpPair (xpAttr "NAME" xpText) xpickle
+
+xpTeam :: PU Team
+xpTeam
+ = xpElem "TEAM" $
+ xpWrap ( uncurry3 Team
+ , \ t -> (teamName t, city t, players t)) $
+ xpTriple (xpAttr "NAME" xpText) (xpAttr "CITY" xpText) (xpList xpickle)
+
+xpPlayer :: PU Player
+xpPlayer
+ = xpElem "PLAYER" $
+ xpWrap ( \ ((f,l,p),(a,h,e)) -> Player f l p a h e
+ , \ t -> ((firstName t, lastName t, position t),(atBats t, hits t, era t))) $
+ xpPair (xpTriple (xpAttr "GIVEN_NAME" xpText)
+ (xpAttr "SURNAME" xpText)
+ (xpAttr "POSITION" xpText))
+ (xpTriple (xpOption (xpAttr "AT_BATS" xpickle))
+ (xpOption (xpAttr "HITS" xpickle))
+ (xpOption (xpAttr "ERA" xpPrim )))
+
+
+-- ------------------------------------------------------------
+
+-- a simple pickle/unpickle application
+
+main :: IO ()
+main
+ = do
+ runX ( xunpickleDocument xpSeason [ (a_validate,v_0)
+ , (a_trace, v_1)
+ , (a_remove_whitespace,v_1)
+ , (a_preserve_comment, v_0)
+ ] "simple2.xml"
+ >>>
+ processSeason
+ >>>
+ xpickleDocument xpSeason [ (a_indent, v_1)
+ ] "new-simple2.xml"
+ )
+ return ()
+
+-- the dummy for processing the unpickled data
+
+processSeason :: IOSArrow Season Season
+processSeason
+ = arrIO ( \ x -> do {print x ; return x})
+
+-- ------------------------------------------------------------
+
+-- the internal data of "simple2.xml"
+
+season1998 :: Season
+season1998
+ = Season
+ { sYear = 1998
+ , sLeagues = fromList
+ [ ( "American League"
+ , fromList
+ [ ( "Central"
+ , [ Team { teamName = "White Sox"
+ , city = "Chicago"
+ , players = []}
+ , Team { teamName = "Royals"
+ , city = "Kansas City"
+ , players = []}
+ , Team { teamName = "Tigers"
+ , city = "Detroit"
+ , players = []}
+ , Team { teamName = "Indians"
+ , city = "Cleveland"
+ , players = []}
+ , Team { teamName = "Twins"
+ , city = "Minnesota"
+ , players = []}
+ ])
+ , ( "East"
+ , [ Team { teamName = "Orioles"
+ , city = "Baltimore"
+ , players = []}
+ , Team { teamName = "Red Sox"
+ , city = "Boston"
+ , players = []}
+ , Team { teamName = "Yankees"
+ , city = "New York"
+ , players = []}
+ , Team { teamName = "Devil Rays"
+ , city = "Tampa Bay"
+ , players = []}
+ , Team { teamName = "Blue Jays"
+ , city = "Toronto"
+ , players = []}
+ ])
+ , ( "West"
+ , [ Team { teamName = "Angels"
+ , city = "Anaheim"
+ , players = []}
+ , Team { teamName = "Athletics"
+ , city = "Oakland"
+ , players = []}
+ , Team { teamName = "Mariners"
+ , city = "Seattle"
+ , players = []}
+ , Team { teamName = "Rangers"
+ , city = "Texas"
+ , players = []}
+ ])
+ ])
+ , ( "National League"
+ , fromList
+ [ ( "Central"
+ , [ Team { teamName = "Cubs"
+ , city = "Chicago"
+ , players = []}
+ , Team { teamName = "Reds"
+ , city = "Cincinnati"
+ , players = []}
+ , Team { teamName = "Astros"
+ , city = "Houston"
+ , players = []}
+ , Team { teamName = "Brewers"
+ , city = "Milwaukee"
+ , players = []}
+ , Team { teamName = "Pirates"
+ , city = "Pittsburgh"
+ , players = []}
+ , Team { teamName = "Cardinals"
+ , city = "St. Louis"
+ , players = []}
+ ])
+ , ( "East"
+ , [ Team { teamName = "Braves"
+ , city = "Atlanta"
+ , players =
+ [ Player { firstName = "Marty"
+ , lastName = "Malloy"
+ , position = "Second Base"
+ , atBats = Just 28
+ , hits = Just 5
+ , era = Nothing}
+ , Player { firstName = "Ozzie"
+ , lastName = "Guillen"
+ , position = "Shortstop"
+ , atBats = Just 264
+ , hits = Just 73
+ , era = Nothing}
+ , Player { firstName = "Danny"
+ , lastName = "Bautista"
+ , position = "Outfield"
+ , atBats = Just 144
+ , hits = Just 36
+ , era = Nothing}
+ , Player { firstName = "Gerald"
+ , lastName = "Williams"
+ , position = "Outfield"
+ , atBats = Just 266
+ , hits = Just 81
+ , era = Nothing}
+ , Player { firstName = "Tom"
+ , lastName = "Glavine"
+ , position = "Starting Pitcher"
+ , atBats = Nothing
+ , hits = Nothing
+ , era = Just 2.47}
+ , Player { firstName = "Javier"
+ , lastName = "Lopez"
+ , position = "Catcher"
+ , atBats = Just 489
+ , hits = Just 139
+ , era = Nothing}
+ , Player { firstName = "Ryan"
+ , lastName = "Klesko"
+ , position = "Outfield"
+ , atBats = Just 427
+ , hits = Just 117
+ , era = Nothing}
+ , Player { firstName = "Andres"
+ , lastName = "Galarraga"
+ , position = "First Base"
+ , atBats = Just 555
+ , hits = Just 169
+ , era = Nothing}
+ , Player { firstName = "Wes"
+ , lastName = "Helms"
+ , position = "Third Base"
+ , atBats = Just 13
+ , hits = Just 4
+ , era = Nothing}
+ ]}
+ , Team { teamName = "Marlins"
+ , city = "Florida"
+ , players = []}
+ , Team { teamName = "Expos"
+ , city = "Montreal"
+ , players = []}
+ , Team { teamName = "Mets"
+ , city = "New York"
+ , players = []}
+ , Team { teamName = "Phillies"
+ , city = "Philadelphia"
+ , players = []}
+ ])
+ , ( "West"
+ , [ Team { teamName = "Diamondbacks"
+ , city = "Arizona"
+ , players = []}
+ , Team { teamName = "Rockies"
+ , city = "Colorado"
+ , players = []}
+ , Team { teamName = "Dodgers"
+ , city = "Los Angeles"
+ , players = []}
+ , Team { teamName = "Padres"
+ , city = "San Diego"
+ , players = []}
+ , Team { teamName = "Giants"
+ , city = "San Francisco"
+ , players = []}
+ ])
+ ])
+ ]
+ }
+
+-- ------------------------------------------------------------
diff --git a/examples/arrows/AGentleIntroductionToHXT/AGentleIntroductionToHXT/PicklerExample/Makefile b/examples/arrows/AGentleIntroductionToHXT/AGentleIntroductionToHXT/PicklerExample/Makefile
new file mode 100644
--- /dev/null
+++ b/examples/arrows/AGentleIntroductionToHXT/AGentleIntroductionToHXT/PicklerExample/Makefile
@@ -0,0 +1,41 @@
+# $Id: Makefile,v 1.2 2006/11/17 17:16:24 hxml Exp $
+#
+# hello world application of Haskell XML Toolbox
+
+HXT_HOME = ../../../..
+PKGFLAGS =
+GHCFLAGS = -W -O2
+GHC = ghc $(GHCFLAGS) $(PKGFLAGS)
+
+DIST = $(HXT_HOME)/dist/examples/arrows/AGentleIntroductionToHXT/
+DIST_DIR = $(DIST)/AGentleIntroductionToHXT/PicklerExample/
+
+src = Baseball.hs
+prog = ./Baseball
+
+all :
+ $(MAKE) $(prog)
+
+force :
+ $(MAKE) distclean all
+
+test : $(prog)
+ $(prog)
+
+dist :
+ [ -d $(DIST_DIR) ] || mkdir -p $(DIST_DIR)
+ cp $(src) simple2.xm new-simple2.xm Makefile $(DIST_DIR)
+
+clean :
+ rm -f *.o *.hi
+
+distclean :
+ $(MAKE) clean
+ rm -f $(prog)
+
+.PHONY : all test dist clean distclean force
+
+$(prog) : $(src)
+ $(GHC) --make -o $@ $<
+
+
diff --git a/examples/arrows/RelaxTestSuite/TestCases.hs b/examples/arrows/RelaxTestSuite/TestCases.hs
--- a/examples/arrows/RelaxTestSuite/TestCases.hs
+++ b/examples/arrows/RelaxTestSuite/TestCases.hs
@@ -10,7 +10,7 @@
import Text.XML.HXT.RelaxNG.Validator
import Text.XML.HXT.RelaxNG.Schema
import Text.XML.HXT.Arrow
-import Text.XML.HXT.Parser ( formatXmlTree )
+import Text.XML.HXT.DOM.FormatXmlTree
import Test.HUnit
import Data.List
diff --git a/examples/arrows/performance/GenDoc.hs b/examples/arrows/performance/GenDoc.hs
--- a/examples/arrows/performance/GenDoc.hs
+++ b/examples/arrows/performance/GenDoc.hs
@@ -153,6 +153,7 @@
readDoc :: String -> IOSArrow b XmlTree
readDoc src
= readDocument [ (a_tagsoup, v_1)
+ , (a_parse_xml, v_1)
, (a_remove_whitespace, v_1)
, (a_encoding, isoLatin1)
, (a_issue_warnings, v_0)
diff --git a/examples/arrows/performance/Makefile b/examples/arrows/performance/Makefile
--- a/examples/arrows/performance/Makefile
+++ b/examples/arrows/performance/Makefile
@@ -43,13 +43,16 @@
# the size of the XML file for i=20 is about 36Mb
# these tests have run on a box with 1Gb memory
-tests = 2 3 10 11 12 13 14 15 16 17 18 19 20
+tests = 2 3 10 11 12
test : $(prog)
- $(MAKE) genfiles
- $(MAKE) readfiles
- $(MAKE) pruneright
- $(MAKE) pruneleft
+ $(MAKE) genfiles tests="$(tests)"
+ $(MAKE) readfiles tests="$(tests)"
+ $(MAKE) pruneright tests="$(tests)"
+ $(MAKE) pruneleft tests="$(tests)"
+
+perftest : $(prog)
+ $(MAKE) test tests="2 3 10 11 12 13 14 15 16 17 18 19 20"
genfiles :
@for i in $(tests) ; \
diff --git a/examples/arrows/pickle/Makefile b/examples/arrows/pickle/Makefile
--- a/examples/arrows/pickle/Makefile
+++ b/examples/arrows/pickle/Makefile
@@ -10,8 +10,10 @@
DIST = $(HXT_HOME)/dist/examples/arrows
DIST_DIR = $(DIST)/pickle
-all : pickleTest
+PROG = ./pickleTest
+all : $(PROG)
+
force :
$(MAKE) distclean all
@@ -27,11 +29,10 @@
cp PickleTest.hs Makefile $(DIST_DIR)
clean :
- rm -f *.o *.hi pickle.xml
+ rm -f *.o *.hi pickle.xml $(PROG)
distclean :
$(MAKE) clean
- rm -f pickleTest
.PHONY : all test dist clean distclean force
diff --git a/examples/dtd2haskell/DTDtoHXT.hs b/examples/dtd2haskell/DTDtoHXT.hs
deleted file mode 100644
--- a/examples/dtd2haskell/DTDtoHXT.hs
+++ /dev/null
@@ -1,434 +0,0 @@
--- |
--- 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
deleted file mode 100644
--- a/examples/dtd2haskell/Makefile
+++ /dev/null
@@ -1,56 +0,0 @@
-# $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
deleted file mode 100644
--- a/examples/hfilter/FilterExample.hs
+++ /dev/null
@@ -1,172 +0,0 @@
--- |
--- 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
deleted file mode 100644
--- a/examples/hfilter/Makefile
+++ /dev/null
@@ -1,63 +0,0 @@
-# $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
deleted file mode 100644
--- a/examples/hfilter/lousy.html
+++ /dev/null
@@ -1,26 +0,0 @@
-
-
-
- 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
deleted file mode 100644
--- a/examples/hparser/HXmlParser.hs
+++ /dev/null
@@ -1,136 +0,0 @@
--- |
--- 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
deleted file mode 100644
--- a/examples/hparser/Makefile
+++ /dev/null
@@ -1,111 +0,0 @@
-# $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
deleted file mode 100644
--- a/examples/hparser/example1.xml
+++ /dev/null
@@ -1,22 +0,0 @@
-
-
-
-
-
-
-
-]>
-
-
-
-
-
- hello world äöüß test
-
diff --git a/examples/hparser/invalid.xml b/examples/hparser/invalid.xml
deleted file mode 100644
--- a/examples/hparser/invalid.xml
+++ /dev/null
@@ -1,13 +0,0 @@
-
-
-
-
-
-
-]>
-
-
-
- hello world
-
diff --git a/examples/hparser/lousy.html b/examples/hparser/lousy.html
deleted file mode 100644
--- a/examples/hparser/lousy.html
+++ /dev/null
@@ -1,26 +0,0 @@
-
-
-
- A HTML Documents with some Errors
-
-
-
-
Instances